3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
6 last modified 27th Apr 1997
9 All comments/suggestions/problems are welcome
11 Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
12 This program is free software; you can redistribute it and/or
13 modify it under the same terms as Perl itself.
17 0.2 - No longer bombs out if dbopen returns an error.
18 0.3 - Added some support for multiple btree compares
19 1.0 - Complete support for multiple callbacks added.
20 Fixed a problem with pushing a value onto an empty list.
21 1.01 - Fixed a SunOS core dump problem.
22 The return value from TIEHASH wasn't set to NULL when
23 dbopen returned an error.
24 1.02 - Use ALIAS to define TIEARRAY.
25 Removed some redundant commented code.
26 Merged OS2 code into the main distribution.
27 Allow negative subscripts with RECNO interface.
28 Changed the default flags to O_CREAT|O_RDWR
30 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by
31 Dave Hammen, hammen@gothamcity.jsc.nasa.gov
32 1.05 - Added logic to allow prefix & hash types to be specified via
34 1.06 - Minor namespace cleanup: Localized PrintBtree.
35 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n".
36 1.08 - No change to DB_File.xs
37 1.09 - Default mode for dbopen changed to 0666
38 1.10 - Fixed fd method so that it still returns -1 for
39 in-memory files when db 1.86 is used.
40 1.11 - No change to DB_File.xs
41 1.12 - No change to DB_File.xs
42 1.13 - Tidied up a few casts.
58 #define DB_Prefix_t mDB_Prefix_t
65 #define DB_Hash_t mDB_Hash_t
84 typedef DB_File_type * DB_File ;
90 #define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
91 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
92 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
93 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
95 #define db_close(db) ((db->dbp)->close)(db->dbp)
96 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
97 #define db_fd(db) (db->in_memory \
99 : ((db->dbp)->fd)(db->dbp) )
100 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
101 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
102 #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
103 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
106 #define OutputValue(arg, name) \
107 { if (RETVAL == 0) { \
108 sv_setpvn(arg, name.data, name.size) ; \
112 #define OutputKey(arg, name) \
115 if (db->type != DB_RECNO) { \
116 sv_setpvn(arg, name.data, name.size); \
119 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
123 /* Internal Global Data */
124 static recno_t Value ;
125 static DB_File CurrentDB ;
126 static recno_t zero = 0 ;
127 static DBTKEY empty = { &zero, sizeof(recno_t) } ;
131 btree_compare(key1, key2)
136 void * data1, * data2 ;
143 /* As newSVpv will assume that the data pointer is a null terminated C
144 string if the size parameter is 0, make sure that data points to an
145 empty string if the length is 0
157 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
158 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
161 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
166 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
178 btree_prefix(key1, key2)
183 void * data1, * data2 ;
190 /* As newSVpv will assume that the data pointer is a null terminated C
191 string if the size parameter is 0, make sure that data points to an
192 empty string if the length is 0
204 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
205 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
208 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
213 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
236 /* DGH - Next two lines added to fix corrupted stack problem */
242 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
245 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
250 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
268 printf ("HASH Info\n") ;
269 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
270 printf (" bsize = %d\n", hash->bsize) ;
271 printf (" ffactor = %d\n", hash->ffactor) ;
272 printf (" nelem = %d\n", hash->nelem) ;
273 printf (" cachesize = %d\n", hash->cachesize) ;
274 printf (" lorder = %d\n", hash->lorder) ;
282 printf ("RECNO Info\n") ;
283 printf (" flags = %d\n", recno->flags) ;
284 printf (" cachesize = %d\n", recno->cachesize) ;
285 printf (" psize = %d\n", recno->psize) ;
286 printf (" lorder = %d\n", recno->lorder) ;
287 printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
288 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
289 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
296 printf ("BTREE Info\n") ;
297 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
298 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
299 printf (" flags = %d\n", btree->flags) ;
300 printf (" cachesize = %d\n", btree->cachesize) ;
301 printf (" psize = %d\n", btree->psize) ;
302 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
303 printf (" minkeypage = %d\n", btree->minkeypage) ;
304 printf (" lorder = %d\n", btree->lorder) ;
309 #define PrintRecno(recno)
310 #define PrintHash(hash)
311 #define PrintBtree(btree)
324 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
326 RETVAL = *(I32 *)key.data ;
327 else if (RETVAL == 1) /* No key means empty file */
330 return ((I32)RETVAL) ;
334 GetRecnoKey(db, value)
339 /* Get the length of the array */
340 I32 length = GetArrayLength(db->dbp) ;
342 /* check for attempt to write before start of array */
343 if (length + value + 1 <= 0)
344 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
346 value = length + value + 1 ;
355 ParseOpenInfo(name, flags, mode, sv)
363 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
364 void * openinfo = NULL ;
365 union INFO * info = &RETVAL->info ;
367 /* Default to HASH */
368 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
369 RETVAL->type = DB_HASH ;
371 /* DGH - Next line added to avoid SEGV on existing hash DB */
374 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
375 RETVAL->in_memory = (name == NULL) ;
380 croak ("type parameter is not a reference") ;
382 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
383 if (svp && SvOK(*svp))
384 action = (HV*) SvRV(*svp) ;
386 croak("internal error") ;
388 if (sv_isa(sv, "DB_File::HASHINFO"))
390 RETVAL->type = DB_HASH ;
391 openinfo = (void*)info ;
393 svp = hv_fetch(action, "hash", 4, FALSE);
395 if (svp && SvOK(*svp))
397 info->hash.hash = hash_cb ;
398 RETVAL->hash = newSVsv(*svp) ;
401 info->hash.hash = NULL ;
403 svp = hv_fetch(action, "bsize", 5, FALSE);
404 info->hash.bsize = svp ? SvIV(*svp) : 0;
406 svp = hv_fetch(action, "ffactor", 7, FALSE);
407 info->hash.ffactor = svp ? SvIV(*svp) : 0;
409 svp = hv_fetch(action, "nelem", 5, FALSE);
410 info->hash.nelem = svp ? SvIV(*svp) : 0;
412 svp = hv_fetch(action, "cachesize", 9, FALSE);
413 info->hash.cachesize = svp ? SvIV(*svp) : 0;
415 svp = hv_fetch(action, "lorder", 6, FALSE);
416 info->hash.lorder = svp ? SvIV(*svp) : 0;
420 else if (sv_isa(sv, "DB_File::BTREEINFO"))
422 RETVAL->type = DB_BTREE ;
423 openinfo = (void*)info ;
425 svp = hv_fetch(action, "compare", 7, FALSE);
426 if (svp && SvOK(*svp))
428 info->btree.compare = btree_compare ;
429 RETVAL->compare = newSVsv(*svp) ;
432 info->btree.compare = NULL ;
434 svp = hv_fetch(action, "prefix", 6, FALSE);
435 if (svp && SvOK(*svp))
437 info->btree.prefix = btree_prefix ;
438 RETVAL->prefix = newSVsv(*svp) ;
441 info->btree.prefix = NULL ;
443 svp = hv_fetch(action, "flags", 5, FALSE);
444 info->btree.flags = svp ? SvIV(*svp) : 0;
446 svp = hv_fetch(action, "cachesize", 9, FALSE);
447 info->btree.cachesize = svp ? SvIV(*svp) : 0;
449 svp = hv_fetch(action, "minkeypage", 10, FALSE);
450 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
452 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
453 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
455 svp = hv_fetch(action, "psize", 5, FALSE);
456 info->btree.psize = svp ? SvIV(*svp) : 0;
458 svp = hv_fetch(action, "lorder", 6, FALSE);
459 info->btree.lorder = svp ? SvIV(*svp) : 0;
464 else if (sv_isa(sv, "DB_File::RECNOINFO"))
466 RETVAL->type = DB_RECNO ;
467 openinfo = (void *)info ;
469 svp = hv_fetch(action, "flags", 5, FALSE);
470 info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
472 svp = hv_fetch(action, "cachesize", 9, FALSE);
473 info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
475 svp = hv_fetch(action, "psize", 5, FALSE);
476 info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
478 svp = hv_fetch(action, "lorder", 6, FALSE);
479 info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
481 svp = hv_fetch(action, "reclen", 6, FALSE);
482 info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
484 svp = hv_fetch(action, "bval", 4, FALSE);
485 if (svp && SvOK(*svp))
488 info->recno.bval = (u_char)*SvPV(*svp, na) ;
490 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
494 if (info->recno.flags & R_FIXEDLEN)
495 info->recno.bval = (u_char) ' ' ;
497 info->recno.bval = (u_char) '\n' ;
500 svp = hv_fetch(action, "bfname", 6, FALSE);
501 if (svp && SvOK(*svp)) {
502 char * ptr = SvPV(*svp,na) ;
503 info->recno.bfname = (char*) (na ? ptr : NULL) ;
506 info->recno.bfname = NULL ;
511 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
515 /* OS2 Specific Code */
522 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
532 croak("DB_File::%s not implemented on this architecture", s);
546 if (strEQ(name, "BTREEMAGIC"))
552 if (strEQ(name, "BTREEVERSION"))
562 if (strEQ(name, "DB_LOCK"))
568 if (strEQ(name, "DB_SHMEM"))
574 if (strEQ(name, "DB_TXN"))
588 if (strEQ(name, "HASHMAGIC"))
594 if (strEQ(name, "HASHVERSION"))
610 if (strEQ(name, "MAX_PAGE_NUMBER"))
611 #ifdef MAX_PAGE_NUMBER
612 return (U32)MAX_PAGE_NUMBER;
616 if (strEQ(name, "MAX_PAGE_OFFSET"))
617 #ifdef MAX_PAGE_OFFSET
618 return MAX_PAGE_OFFSET;
622 if (strEQ(name, "MAX_REC_NUMBER"))
623 #ifdef MAX_REC_NUMBER
624 return (U32)MAX_REC_NUMBER;
638 if (strEQ(name, "RET_ERROR"))
644 if (strEQ(name, "RET_SPECIAL"))
650 if (strEQ(name, "RET_SUCCESS"))
656 if (strEQ(name, "R_CURSOR"))
662 if (strEQ(name, "R_DUP"))
668 if (strEQ(name, "R_FIRST"))
674 if (strEQ(name, "R_FIXEDLEN"))
680 if (strEQ(name, "R_IAFTER"))
686 if (strEQ(name, "R_IBEFORE"))
692 if (strEQ(name, "R_LAST"))
698 if (strEQ(name, "R_NEXT"))
704 if (strEQ(name, "R_NOKEY"))
710 if (strEQ(name, "R_NOOVERWRITE"))
712 return R_NOOVERWRITE;
716 if (strEQ(name, "R_PREV"))
722 if (strEQ(name, "R_RECNOSYNC"))
728 if (strEQ(name, "R_SETCURSOR"))
734 if (strEQ(name, "R_SNAPSHOT"))
758 if (strEQ(name, "__R_UNUSED"))
774 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
783 db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
789 char * name = (char *) NULL ;
790 SV * sv = (SV *) NULL ;
792 if (items >= 2 && SvOK(ST(1)))
793 name = (char*) SvPV(ST(1), na) ;
798 RETVAL = ParseOpenInfo(name, flags, mode, sv) ;
799 if (RETVAL->dbp == NULL)
812 SvREFCNT_dec(db->hash) ;
814 SvREFCNT_dec(db->compare) ;
816 SvREFCNT_dec(db->prefix) ;
821 db_DELETE(db, key, flags=0)
838 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
844 db_FETCH(db, key, flags=0)
853 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
854 ST(0) = sv_newmortal();
856 sv_setpvn(ST(0), value.data, value.size);
860 db_STORE(db, key, value, flags=0)
879 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
880 ST(0) = sv_newmortal();
883 if (Db->type != DB_RECNO)
884 sv_setpvn(ST(0), key.data, key.size);
886 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
900 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
901 ST(0) = sv_newmortal();
904 if (Db->type != DB_RECNO)
905 sv_setpvn(ST(0), key.data, key.size);
907 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
912 # These would be nice for RECNO
928 for (i = items-1 ; i > 0 ; --i)
930 value.data = SvPV(ST(i), na) ;
934 key.size = sizeof(int) ;
935 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
953 /* First get the final value */
954 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
955 ST(0) = sv_newmortal();
959 /* the call to del will trash value, so take a copy now */
960 sv_setpvn(ST(0), value.data, value.size);
961 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
963 sv_setsv(ST(0), &sv_undef);
977 /* get the first value */
978 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
979 ST(0) = sv_newmortal();
983 /* the call to del will trash value, so take a copy now */
984 sv_setpvn(ST(0), value.data, value.size);
985 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
987 sv_setsv (ST(0), &sv_undef) ;
998 DBTKEY * keyptr = &key ;
1004 /* Set the Cursor to the Last element */
1005 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1010 for (i = items - 1 ; i > 0 ; --i)
1012 value.data = SvPV(ST(i), na) ;
1014 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1029 RETVAL = GetArrayLength(db->dbp) ;
1035 # Now provide an interface to the rest of the DB functionality
1039 db_del(db, key, flags=0)
1048 db_get(db, key, value, flags=0)
1059 db_put(db, key, value, flags=0)
1067 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1076 db_sync(db, flags=0)
1084 db_seq(db, key, value, flags)