1 /*-
2 * Copyright (c) 2012-2017 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)fth-dbm.c 1.16 12/31/17
27 *
28 * Commentary:
29 *
30 * dl-load dbm Init_dbm
31 *
32 * dbm.so provides the following functions:
33 *
34 * dbm? ( obj -- f )
35 * dbm-name ( dbm -- name )
36 * .dbm ( dbm -- )
37 * make-dbm ( fname -- dbm )
38 * dbm{} alias for make-dbm
39 * dbm-open alias for make-dbm
40 * >dbm ( key-vals len -- dbm )
41 * dbm-close ( dbm -- )
42 * dbm-closed? ( dbm -- f )
43 * dbm-ref ( dbm key -- data )
44 * dbm-fetch alias for dbm-ref
45 * dbm-set! ( dbm key data -- )
46 * dbm-store alias for dbm-set!
47 * dbm-delete ( dbm key -- data|#f )
48 * dbm-member? ( dbm key -- f )
49 * dbm->array ( dbm -- array )
50 * dbm->hash ( dbm -- hash )
51 * hash->dbm ( hash fname -- dbm )
52 * dbm{ key-data pairs } ( fname <ccc>} -- ) "dbm-test" dbm{ 'foo 10 } value db
53 *
54 * and the general object functions:
55 *
56 * object->string
57 * object-dump
58 * object->array
59 * object-copy
60 * object-ref
61 * object-length (alias length)
62 * object-apply (alias apply)
63 *
64 * object-ref implies each ( #( key data ) ) ... end-each
65 * db each { val }
66 * val 0 array-ref { key }
67 * val 1 array-ref { data }
68 * ...
69 * end-each
70 */
71
72 #if !defined(lint)
73 const char dbm_sccsid[] = "@(#)fth-dbm.c 1.16 12/31/17";
74 #endif /* not lint */
75
76 #if defined(HAVE_CONFIG_H)
77 #include "config.h"
78 #endif
79
80 #include "fth.h"
81
82 #if HAVE_DBM
83
84 #if defined(HAVE_FCNTL_H)
85 #include <fcntl.h>
86 #endif
87 #if defined(HAVE_NDBM_H)
88 #include <ndbm.h>
89 #endif
90
91 static FTH dbm_tag;
92 static int dbm_type;
93
94 typedef struct {
95 ficlInteger length; /* key-data pairs */
96 DBM *data; /* DBM database */
97 int closed; /* flag if db is closed */
98 FTH filename; /* db file name w/o suffix '.db' */
99 FTH array; /* db content as array of arrays for each ...
100 * end-each */
101 } FDbm;
102
103 #define FTH_STR_DBM "dbm"
104 #define STR_DBM_ERROR "dbm-error"
105 #define FTH_DBM_ERROR fth_exception(STR_DBM_ERROR)
106
107 #define FTH_DBM_OBJECT(Obj) FTH_INSTANCE_REF_GEN(Obj, FDbm)
108 #define FTH_DBM_LENGTH(Obj) FTH_DBM_OBJECT(Obj)->length
109 #define FTH_DBM_DATA(Obj) FTH_DBM_OBJECT(Obj)->data
110 #define FTH_DBM_CLOSED_P(Obj) FTH_DBM_OBJECT(Obj)->closed
111 #define FTH_DBM_FILENAME(Obj) FTH_DBM_OBJECT(Obj)->filename
112 #define FTH_DBM_ARRAY(Obj) FTH_DBM_OBJECT(Obj)->array
113
114 #define FTH_DBM_P(Obj) \
115 (fth_instance_p(Obj) && FTH_INSTANCE_TYPE(Obj) == (fobj_t)dbm_type)
116 #define FTH_DBM_NOT_CLOSED_P(Obj) \
117 (FTH_DBM_P(Obj) && !FTH_DBM_CLOSED_P(Obj))
118
119 #define FTH_DBM_THROW_ERROR(db) do { \
120 int _e; \
121 \
122 _e = dbm_error(db); \
123 dbm_clearerr(db); \
124 fth_throw(FTH_DBM_ERROR, "%s (%s): %d", RUNNING_WORD(), __func__, _e);\
125 } while (0)
126
127 /*
128 * XXX
129 * FreeBSD: int datum.dsize
130 * Others(?): size_t datum.dsize
131 */
132
133 #if defined(__FreeBSD__)
134 #define dbm_strlen(Str) (int)strlen(Str)
135 #else
136 #define dbm_strlen(Str) strlen(Str)
137 #endif
138
139 static FTH dbm_copy(FTH);
140 static FTH dbm_dump(FTH);
141 static FTH dbm_dump_each(datum, datum, FTH);
142 static void dbm_free(FTH);
143 static FTH dbm_length(FTH);
144 static void dbm_mark(FTH);
145 static FTH dbm_ref(FTH, FTH);
146 static FTH dbm_set(FTH, FTH, FTH);
147 static FTH dbm_to_array(FTH);
148 static FTH dbm_to_array_each(datum, datum, FTH);
149 static FTH dbm_to_hash_each(datum, datum, FTH);
150 static FTH dbm_to_string(FTH);
151 static FTH dbm_to_string_each(datum, datum, FTH);
152 static void ficl_begin_dbm(ficlVm *);
153 static void ficl_dbm_close(ficlVm *);
154 static void ficl_dbm_closed_p(ficlVm *);
155 static void ficl_dbm_delete(ficlVm *);
156 static void ficl_dbm_member_p(ficlVm *);
157 static void ficl_dbm_name(ficlVm *);
158 static void ficl_dbm_p(ficlVm *);
159 static void ficl_dbm_print(ficlVm *);
160 static void ficl_dbm_ref(ficlVm *);
161 static void ficl_dbm_set(ficlVm *);
162 static void ficl_dbm_to_array(ficlVm *);
163 static void ficl_dbm_to_hash(ficlVm *);
164 static void ficl_hash_to_dbm(ficlVm *);
165 static void ficl_make_dbm(ficlVm *);
166 static void ficl_values_to_dbm(ficlVm *);
167 static FTH fth_dbm_each(FTH, FTH (*) (datum, datum, FTH), FTH);
168 static FTH hash_to_dbm_each(FTH, FTH, FTH);
169 static FTH make_dbm(FTH);
170 void Init_dbm (void);
171
172 static FTH
make_dbm(FTH name)173 make_dbm(FTH name)
174 {
175 DBM *dbm;
176 FDbm *db;
177 datum k;
178 char *s;
179
180 s = fth_string_ref(name);
181 dbm = dbm_open(s, O_RDWR | O_CREAT, 0660);
182
183 if (dbm == NULL) {
184 dbm = dbm_open(s, O_RDONLY, 0660);
185 if (dbm == NULL)
186 FTH_DBM_THROW_ERROR(dbm);
187 }
188
189 db = FTH_MALLOC(sizeof(FDbm));
190 db->length = 0;
191 db->data = dbm;
192 db->closed = 0;
193 db->filename = name;
194 db->array = FTH_FALSE;
195
196 for (k = dbm_firstkey(dbm); k.dptr != NULL; k = dbm_nextkey(dbm))
197 db->length++;
198
199 return (fth_make_instance(dbm_tag, db));
200 }
201
202 /*
203 * Loops through entire data base and calls func on every key.
204 */
205 static FTH
fth_dbm_each(FTH db,FTH (* func)(datum key,datum val,FTH data),FTH data)206 fth_dbm_each(FTH db,
207 FTH (*func) (datum key, datum val, FTH data),
208 FTH data)
209 {
210 DBM *d;
211 datum k, v;
212
213 FTH_ASSERT_ARGS(FTH_DBM_NOT_CLOSED_P(db), db, FTH_ARG1, "open dbm");
214 d = FTH_DBM_DATA(db);
215
216 for (k = dbm_firstkey(d); k.dptr != NULL; k = dbm_nextkey(d)) {
217 v = dbm_fetch(d, k);
218 data = (*func) (k, v, data);
219 }
220
221 return (data);
222 }
223
224 static FTH
dbm_to_string_each(datum k,datum v,FTH fs)225 dbm_to_string_each(datum k, datum v, FTH fs)
226 {
227 return (fth_string_sformat(fs, " \"%.*s\" => \"%.*s\" ",
228 k.dsize, k.dptr,
229 v.dsize, v.dptr));
230 }
231
232 /*
233 * dbm object->string => dbm{ "key" => "data" "key" => "data" ... }
234 */
235 static FTH
dbm_to_string(FTH self)236 dbm_to_string(FTH self)
237 {
238 FTH fs;
239
240 fs = fth_make_string("dbm{");
241
242 if (FTH_DBM_CLOSED_P(self))
243 return (fth_string_scat(fs, " closed "));
244
245 if (FTH_DBM_LENGTH(self) > 0)
246 fth_dbm_each(self, dbm_to_string_each, fs);
247
248 return (fth_string_scat(fs, "}"));
249 }
250
251 static FTH
dbm_dump_each(datum k,datum v,FTH fs)252 dbm_dump_each(datum k, datum v, FTH fs)
253 {
254 return (fth_string_sformat(fs, " \"%.*s\" \"%.*s\" ",
255 k.dsize, k.dptr,
256 v.dsize, v.dptr));
257 }
258
259 /*
260 * dbm object-dump => "dbm-filename" dbm{ "key" "data" "key" "data" ... }
261 */
262 static FTH
dbm_dump(FTH self)263 dbm_dump(FTH self)
264 {
265 FTH fs;
266
267 fs = fth_make_string_format("\"%S\" dbm{", FTH_DBM_FILENAME(self));
268
269 if (FTH_DBM_LENGTH(self) > 0)
270 fth_dbm_each(self, dbm_dump_each, fs);
271
272 return (fth_string_scat(fs, "}"));
273 }
274
275 static FTH
dbm_to_array_each(datum k,datum v,FTH array)276 dbm_to_array_each(datum k, datum v, FTH array)
277 {
278 FTH fsk, fsv;
279
280 fsk = fth_make_string_len(k.dptr, (ficlInteger) k.dsize);
281 fsv = fth_make_string_len(v.dptr, (ficlInteger) v.dsize);
282 return (fth_array_push(array, FTH_LIST_2(fsk, fsv)));
283 }
284
285 /*
286 * dbm object->array => dbm as array of arrays
287 */
288 static FTH
dbm_to_array(FTH self)289 dbm_to_array(FTH self)
290 {
291 FTH array;
292
293 array = FTH_DBM_ARRAY(self);
294
295 if (FTH_FALSE_P(array) || FTH_INSTANCE_CHANGED_P(self)) {
296 FTH a;
297
298 a = fth_make_empty_array();
299 array = fth_dbm_each(self, dbm_to_array_each, a);
300 FTH_INSTANCE_CHANGED_CLR(self);
301 }
302 return (array);
303 }
304
305 static int copy_number;
306
307 /*
308 * dbm object-copy => dbm-copy with dbm-filename-0x
309 */
310 static FTH
dbm_copy(FTH self)311 dbm_copy(FTH self)
312 {
313 FTH fs, nfs, copy;
314 DBM *d;
315 datum k, v;
316
317 fs = FTH_DBM_FILENAME(self);
318 nfs = fth_make_string_format("%S-%02d", fs, ++copy_number);
319 copy = make_dbm(nfs);
320 d = FTH_DBM_DATA(self);
321
322 for (k = dbm_firstkey(d); k.dptr != NULL; k = dbm_nextkey(d)) {
323 v = dbm_fetch(d, k);
324
325 if (dbm_store(FTH_DBM_DATA(copy), k, v, DBM_REPLACE) == -1)
326 FTH_DBM_THROW_ERROR(FTH_DBM_DATA(copy));
327 }
328
329 return (copy);
330 }
331
332 /*
333 * dbm object-ref => #( "key" "data" )
334 * Returns #( "key" "data" ) pair for object-ref and each ... end-each.
335 */
336 static FTH
dbm_ref(FTH self,FTH idx)337 dbm_ref(FTH self, FTH idx)
338 {
339 return (fth_array_ref(dbm_to_array(self), FIX_TO_INT(idx)));
340 }
341
342 static FTH
dbm_set(FTH self,FTH fkey,FTH fdata)343 dbm_set(FTH self, FTH fkey, FTH fdata)
344 {
345 datum k, v, f;
346
347 k.dptr = fth_to_c_string(fkey);
348 k.dsize = dbm_strlen(k.dptr);
349 v.dptr = fth_to_c_string(fdata);
350 v.dsize = dbm_strlen(v.dptr);
351 f = dbm_fetch(FTH_DBM_DATA(self), k);
352
353 if (f.dptr == NULL)
354 FTH_DBM_LENGTH(self)++;
355
356 if (dbm_store(FTH_DBM_DATA(self), k, v, DBM_REPLACE) == -1)
357 FTH_DBM_THROW_ERROR(FTH_DBM_DATA(self));
358
359 FTH_INSTANCE_CHANGED(self);
360 return (self);
361 }
362
363 /*
364 * dbm object-length => count of key-data pairs
365 */
366 static FTH
dbm_length(FTH self)367 dbm_length(FTH self)
368 {
369 return (INT_TO_FIX(FTH_DBM_LENGTH(self)));
370 }
371
372 static void
dbm_mark(FTH self)373 dbm_mark(FTH self)
374 {
375 fth_gc_mark(FTH_DBM_ARRAY(self));
376 fth_gc_mark(FTH_DBM_FILENAME(self));
377 }
378
379 static void
dbm_free(FTH self)380 dbm_free(FTH self)
381 {
382 if (FTH_DBM_OBJECT(self) == NULL)
383 return;
384
385 if (!FTH_DBM_CLOSED_P(self))
386 dbm_close(FTH_DBM_DATA(self));
387
388 FTH_FREE(FTH_DBM_OBJECT(self));
389 }
390
391 static void
ficl_dbm_p(ficlVm * vm)392 ficl_dbm_p(ficlVm *vm)
393 {
394 #define h_dbm_p "( obj -- f ) test if OBJ is a dbm\n\
395 nil dbm? => #f\n\
396 dbm dbm? => #t\n\
397 Return #t if OBJ is a dbm object, otherwise #f."
398 FTH obj;
399
400 FTH_STACK_CHECK(vm, 1, 1);
401 obj = fth_pop_ficl_cell(vm);
402 ficlStackPushBoolean(vm->dataStack, FTH_DBM_P(obj));
403 }
404
405 static void
ficl_dbm_name(ficlVm * vm)406 ficl_dbm_name(ficlVm *vm)
407 {
408 #define h_dbm_name "( dbm -- name ) return file name of dbm\n\
409 dbm dbm-name => \"dbm-filename\"\n\
410 Return file name of DBM object."
411 FTH db;
412
413 FTH_STACK_CHECK(vm, 1, 1);
414 db = fth_pop_ficl_cell(vm);
415 FTH_ASSERT_ARGS(FTH_DBM_P(db), db, FTH_ARG1, "a dbm");
416 ficlStackPushFTH(vm->dataStack, FTH_DBM_FILENAME(db));
417 }
418
419 static void
ficl_dbm_print(ficlVm * vm)420 ficl_dbm_print(ficlVm *vm)
421 {
422 #define h_dbm_print "( dbm -- ) print dbm\n\
423 dbm .dbm\n\
424 Print DBM object to current output."
425 FTH db;
426
427 FTH_STACK_CHECK(vm, 1, 0);
428 db = fth_pop_ficl_cell(vm);
429 FTH_ASSERT_ARGS(FTH_DBM_P(db), db, FTH_ARG1, "a dbm");
430 fth_print(fth_string_ref(dbm_to_string(db)));
431 }
432
433 static void
ficl_make_dbm(ficlVm * vm)434 ficl_make_dbm(ficlVm *vm)
435 {
436 #define h_make_dbm "( fname -- dbm ) create new dbm\n\
437 \"dbm-name\" make-dbm value dbm\n\
438 Create FNAME as new database."
439 FTH fs;
440
441 FTH_STACK_CHECK(vm, 1, 1);
442 fs = fth_pop_ficl_cell(vm);
443 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
444 ficlStackPushFTH(vm->dataStack, make_dbm(fs));
445 }
446
447 static void
ficl_values_to_dbm(ficlVm * vm)448 ficl_values_to_dbm(ficlVm *vm)
449 {
450 #define h_values_to_dbm "( key-vals len name -- dbm ) create dbm\n\
451 'foo 0 2 \"test-db\" >dbm => dbm{ \"'foo\" => \"0\" }\n\
452 Return a new dbm with LEN/2 key-data pairs found on stack."
453 FTH key, val, fs, db;
454 ficlInteger i, len;
455
456 FTH_STACK_CHECK(vm, 2, 0);
457 fs = fth_pop_ficl_cell(vm);
458 len = ficlStackPopInteger(vm->dataStack);
459
460 if (len < 0)
461 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "negative");
462
463 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG2, "a string");
464 FTH_STACK_CHECK(vm, len, 1);
465 db = make_dbm(fs);
466
467 for (i = 0; i < len; i += 2) {
468 val = fth_pop_ficl_cell(vm);
469 key = fth_pop_ficl_cell(vm);
470 dbm_set(db, key, val);
471 }
472
473 fth_push_ficl_cell(vm, db);
474 }
475
476 static void
ficl_dbm_close(ficlVm * vm)477 ficl_dbm_close(ficlVm *vm)
478 {
479 #define h_dbm_close "( dbm -- ) close dbm\n\
480 dbm dbm-close\n\
481 Close DBM database."
482 FTH db;
483
484 FTH_STACK_CHECK(vm, 1, 0);
485 db = fth_pop_ficl_cell(vm);
486 FTH_ASSERT_ARGS(FTH_DBM_P(db), db, FTH_ARG1, "a dbm");
487
488 if (!FTH_DBM_CLOSED_P(db))
489 dbm_close(FTH_DBM_DATA(db));
490
491 FTH_DBM_CLOSED_P(db) = 1;
492 }
493
494 static void
ficl_dbm_closed_p(ficlVm * vm)495 ficl_dbm_closed_p(ficlVm *vm)
496 {
497 #define h_dbm_closed_p "( dbm -- f ) test if dbm is closed\n\
498 dbm dbm-closed? => flag\n\
499 Return #t if DBM is closed, otherwise #f."
500 FTH db;
501
502 FTH_STACK_CHECK(vm, 1, 1);
503 db = fth_pop_ficl_cell(vm);
504 FTH_ASSERT_ARGS(FTH_DBM_P(db), db, FTH_ARG1, "a dbm");
505 ficlStackPushBoolean(vm->dataStack, FTH_DBM_CLOSED_P(db));
506 }
507
508 static void
ficl_dbm_ref(ficlVm * vm)509 ficl_dbm_ref(ficlVm *vm)
510 {
511 #define h_dbm_ref "( dbm key -- data|#f ) return KEY's data\n\
512 dbm 'foo dbm-ref => \"#( 0 1 2 )\"\n\
513 dbm 'bar dbm-ref => #f\n\
514 Return data associated with KEY or #f if no key was found."
515 datum k, v;
516 FTH db, fkey, fdata;
517
518 FTH_STACK_CHECK(vm, 2, 1);
519 fkey = fth_pop_ficl_cell(vm);
520 db = fth_pop_ficl_cell(vm);
521 FTH_ASSERT_ARGS(FTH_DBM_NOT_CLOSED_P(db), db, FTH_ARG1, "open dbm");
522 k.dptr = fth_to_c_string(fkey);
523 k.dsize = dbm_strlen(k.dptr);
524 fdata = FTH_FALSE;
525 v = dbm_fetch(FTH_DBM_DATA(db), k);
526
527 if (v.dptr != NULL)
528 fdata = fth_make_string_len(v.dptr, (ficlInteger) v.dsize);
529
530 fth_push_ficl_cell(vm, fdata);
531 }
532
533 static void
ficl_dbm_set(ficlVm * vm)534 ficl_dbm_set(ficlVm *vm)
535 {
536 #define h_dbm_set "( dbm key data -- ) set KEY to DATA\n\
537 dbm 'foo #( 0 1 2 ) dbm-set!\n\
538 Set KEY-DATA pair."
539 FTH db, fkey, fdata;
540
541 FTH_STACK_CHECK(vm, 3, 0);
542 fdata = fth_pop_ficl_cell(vm);
543 fkey = fth_pop_ficl_cell(vm);
544 db = fth_pop_ficl_cell(vm);
545 FTH_ASSERT_ARGS(FTH_DBM_NOT_CLOSED_P(db), db, FTH_ARG1, "open dbm");
546 dbm_set(db, fkey, fdata);
547 }
548
549 static void
ficl_dbm_delete(ficlVm * vm)550 ficl_dbm_delete(ficlVm *vm)
551 {
552 #define h_dbm_delete "( dbm key -- data|#f ) delete KEY-data pair\n\
553 dbm 'foo dbm-delete => \"#( 0 1 2 )\"\n\
554 dbm 'bar dbm-delete => #f\n\
555 Delete KEY and associated data from DBM. \
556 If KEY exists, return associated data, otherwise #f."
557 FTH db, fkey, fdata;
558 datum k, v;
559
560 FTH_STACK_CHECK(vm, 2, 1);
561 fkey = fth_pop_ficl_cell(vm);
562 db = fth_pop_ficl_cell(vm);
563 FTH_ASSERT_ARGS(FTH_DBM_NOT_CLOSED_P(db), db, FTH_ARG1, "open dbm");
564 k.dptr = fth_to_c_string(fkey);
565 k.dsize = dbm_strlen(k.dptr);
566 fdata = FTH_FALSE;
567 v = dbm_fetch(FTH_DBM_DATA(db), k);
568
569 if (v.dptr != NULL)
570 fdata = fth_make_string_len(v.dptr, (ficlInteger) v.dsize);
571
572 if (dbm_delete(FTH_DBM_DATA(db), k) == -1)
573 FTH_DBM_THROW_ERROR(FTH_DBM_DATA(db));
574
575 fth_push_ficl_cell(vm, fdata);
576 }
577
578 static void
ficl_dbm_member_p(ficlVm * vm)579 ficl_dbm_member_p(ficlVm *vm)
580 {
581 #define h_dbm_member_p "( dbm key -- f ) test if KEY exist in DBM\n\
582 dbm 'foo dbm-member? => #t\n\
583 dbm 'bar dbm-member? => #f\n\
584 If KEY exists in DBM, return #t, otherwise #f."
585 FTH db, fkey;
586 datum k, v;
587
588 FTH_STACK_CHECK(vm, 2, 1);
589 fkey = fth_pop_ficl_cell(vm);
590 db = fth_pop_ficl_cell(vm);
591 FTH_ASSERT_ARGS(FTH_DBM_NOT_CLOSED_P(db), db, FTH_ARG1, "open dbm");
592 k.dptr = fth_to_c_string(fkey);
593 k.dsize = dbm_strlen(k.dptr);
594 v = dbm_fetch(FTH_DBM_DATA(db), k);
595 ficlStackPushBoolean(vm->dataStack, v.dptr != NULL);
596 }
597
598 static void
ficl_dbm_to_array(ficlVm * vm)599 ficl_dbm_to_array(ficlVm *vm)
600 {
601 #define h_dbm_to_array "( dbm -- ary ) return DBM as array\n\
602 dbm dbm->array => #( #( \"'foo\" \"#( 0 1 2 )\" ) )\n\
603 Return an array of #( key data ) arrays."
604 FTH db;
605
606 FTH_STACK_CHECK(vm, 1, 1);
607 db = fth_pop_ficl_cell(vm);
608 FTH_ASSERT_ARGS(FTH_DBM_P(db), db, FTH_ARG1, "a dbm");
609 ficlStackPushFTH(vm->dataStack, dbm_to_array(db));
610 }
611
612 static FTH
dbm_to_hash_each(datum k,datum v,FTH hash)613 dbm_to_hash_each(datum k, datum v, FTH hash)
614 {
615 FTH fsk, fsv;
616
617 fsk = fth_make_string_len(k.dptr, (ficlInteger) k.dsize);
618 fsv = fth_make_string_len(v.dptr, (ficlInteger) v.dsize);
619 fth_hash_set(hash, fsk, fsv);
620 return (hash);
621 }
622
623 static void
ficl_dbm_to_hash(ficlVm * vm)624 ficl_dbm_to_hash(ficlVm *vm)
625 {
626 #define h_dbm_to_hash "( dbm -- hash ) return DBM as hash\n\
627 dbm dbm->hash => #{ \"'foo\" => \"#( 0 1 2 )\" }\n\
628 Return content of DBM as a hash."
629 FTH db, d;
630
631 FTH_STACK_CHECK(vm, 1, 1);
632 db = fth_pop_ficl_cell(vm);
633 FTH_ASSERT_ARGS(FTH_DBM_NOT_CLOSED_P(db), db, FTH_ARG1, "open dbm");
634 d = fth_dbm_each(db, dbm_to_hash_each, fth_make_hash());
635 ficlStackPushFTH(vm->dataStack, d);
636 }
637
638 static FTH
hash_to_dbm_each(FTH key,FTH val,FTH db)639 hash_to_dbm_each(FTH key, FTH val, FTH db)
640 {
641 return (dbm_set(db, key, val));
642 }
643
644 static void
ficl_hash_to_dbm(ficlVm * vm)645 ficl_hash_to_dbm(ficlVm *vm)
646 {
647 #define h_hash_to_dbm "( hash fname -- dbm ) create dbm from HASH\n\
648 #{ 'foo 10 'bar 20 } \"test-db\" hash->dbm =>\n\
649 dbm{ \"'foo\" => \"10\" \"'bar\" => \"20\" }\n\
650 Create FNAME as new database with content of HASH."
651 FTH fs, hs, d;
652
653 FTH_STACK_CHECK(vm, 2, 1);
654 fs = fth_pop_ficl_cell(vm);
655 hs = fth_pop_ficl_cell(vm);
656 FTH_ASSERT_ARGS(FTH_HASH_P(hs), hs, FTH_ARG1, "a hash");
657 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG2, "a string");
658 d = fth_hash_each(hs, hash_to_dbm_each, make_dbm(fs));
659 ficlStackPushFTH(vm->dataStack, d);
660 }
661
662 static void
ficl_begin_dbm(ficlVm * vm)663 ficl_begin_dbm(ficlVm *vm)
664 {
665 #define h_begin_dbm "( fname -- ) create new dbm FNAME\n\
666 \"new-db\" dbm{ 'foo 10 'bar 20 } =>\n\
667 dbm{ \"'foo\" => \"10\" \"'bar\" => \"20\" }\n\
668 Return a new dbm object."
669 FTH_STACK_CHECK(vm, 1, 0);
670 fth_begin_values_to_obj(vm, ">dbm", fth_pop_ficl_cell(vm));
671 }
672
673 void
Init_dbm(void)674 Init_dbm(void)
675 {
676 FTH_DBM_ERROR;
677
678 /* filename suffix number */
679 copy_number = 0;
680
681 /* init dbm object type and add 'dbm' to *features* */
682 dbm_tag = fth_make_object_type(FTH_STR_DBM);
683 dbm_type = FTH_OBJECT_TYPE(dbm_tag);
684 fth_set_object_to_string(dbm_tag, dbm_to_string);
685 fth_set_object_dump(dbm_tag, dbm_dump);
686 fth_set_object_to_array(dbm_tag, dbm_to_array);
687 fth_set_object_copy(dbm_tag, dbm_copy);
688 fth_set_object_value_ref(dbm_tag, dbm_ref);
689 fth_set_object_length(dbm_tag, dbm_length);
690 fth_set_object_mark(dbm_tag, dbm_mark);
691 fth_set_object_free(dbm_tag, dbm_free);
692 fth_set_object_apply(dbm_tag, (void *) dbm_ref, 1, 0, 0);
693
694 /* dbm exception */
695 fth_make_exception(STR_DBM_ERROR, "DBM error");
696
697 /* dbm words */
698 FTH_PRI1("dbm?", ficl_dbm_p, h_dbm_p);
699 FTH_PRI1("dbm-name", ficl_dbm_name, h_dbm_name);
700 FTH_PRI1(".dbm", ficl_dbm_print, h_dbm_print);
701 FTH_PRI1("make-dbm", ficl_make_dbm, h_make_dbm);
702 FTH_PRI1("dbm{}", ficl_make_dbm, h_make_dbm);
703 FTH_PRI1("dbm-open", ficl_make_dbm, h_make_dbm);
704 FTH_PRI1(">dbm", ficl_values_to_dbm, h_values_to_dbm);
705 FTH_PRI1("dbm-close", ficl_dbm_close, h_dbm_close);
706 FTH_PRI1("dbm-closed?", ficl_dbm_closed_p, h_dbm_closed_p);
707 FTH_PRI1("dbm-ref", ficl_dbm_ref, h_dbm_ref);
708 FTH_PRI1("dbm-fetch", ficl_dbm_ref, h_dbm_ref);
709 FTH_PRI1("dbm-set!", ficl_dbm_set, h_dbm_set);
710 FTH_PRI1("dbm-store", ficl_dbm_set, h_dbm_set);
711 FTH_PRI1("dbm-delete", ficl_dbm_delete, h_dbm_delete);
712 FTH_PRI1("dbm-member?", ficl_dbm_member_p, h_dbm_member_p);
713 FTH_PRI1("dbm->array", ficl_dbm_to_array, h_dbm_to_array);
714 FTH_PRI1("dbm->hash", ficl_dbm_to_hash, h_dbm_to_hash);
715 FTH_PRI1("hash->dbm", ficl_hash_to_dbm, h_hash_to_dbm);
716 FTH_PRI1("dbm{", ficl_begin_dbm, h_begin_dbm);
717 }
718
719 #endif /* HAVE_DBM */
720
721 /*
722 * fth-dbm.c ends here
723 */
724