3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
6 last modified 8th Oct 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.
43 1.14 - Made it illegal to tie an associative array to a RECNO
44 database and an ordinary array to a HASH or BTREE database.
45 1.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
46 undefined value" warning with db_get and db_seq.
47 1.16 - Minor additions to DB_File.xs to support multithreaded perl.
55 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
56 * shortly #included by the <db.h>) __attribute__ to the possibly
57 * already defined __attribute__, for example by GNUC or by Perl. */
61 /* #ifdef DB_VERSION_MAJOR */
62 /* #include <db_185.h> */
71 #define DB_Prefix_t mDB_Prefix_t
78 #define DB_Hash_t mDB_Hash_t
97 typedef DB_File_type * DB_File ;
103 #define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
104 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
105 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
106 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
108 #define db_close(db) ((db->dbp)->close)(db->dbp)
109 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
110 #define db_fd(db) (db->in_memory \
112 : ((db->dbp)->fd)(db->dbp) )
113 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
114 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
115 #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
116 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
119 #define OutputValue(arg, name) \
120 { if (RETVAL == 0) { \
121 sv_setpvn(arg, name.data, name.size) ; \
125 #define OutputKey(arg, name) \
128 if (db->type != DB_RECNO) { \
129 sv_setpvn(arg, name.data, name.size); \
132 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
136 /* Internal Global Data */
137 static recno_t Value ;
138 static DB_File CurrentDB ;
139 static recno_t zero = 0 ;
140 static DBTKEY empty = { &zero, sizeof(recno_t) } ;
144 btree_compare(key1, key2)
149 void * data1, * data2 ;
156 /* As newSVpv will assume that the data pointer is a null terminated C
157 string if the size parameter is 0, make sure that data points to an
158 empty string if the length is 0
170 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
171 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
174 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
179 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
191 btree_prefix(key1, key2)
196 void * data1, * data2 ;
203 /* As newSVpv will assume that the data pointer is a null terminated C
204 string if the size parameter is 0, make sure that data points to an
205 empty string if the length is 0
217 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
218 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
221 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
226 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
249 /* DGH - Next two lines added to fix corrupted stack problem */
255 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
258 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
263 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
281 printf ("HASH Info\n") ;
282 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
283 printf (" bsize = %d\n", hash->bsize) ;
284 printf (" ffactor = %d\n", hash->ffactor) ;
285 printf (" nelem = %d\n", hash->nelem) ;
286 printf (" cachesize = %d\n", hash->cachesize) ;
287 printf (" lorder = %d\n", hash->lorder) ;
295 printf ("RECNO Info\n") ;
296 printf (" flags = %d\n", recno->flags) ;
297 printf (" cachesize = %d\n", recno->cachesize) ;
298 printf (" psize = %d\n", recno->psize) ;
299 printf (" lorder = %d\n", recno->lorder) ;
300 printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
301 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
302 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
309 printf ("BTREE Info\n") ;
310 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
311 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
312 printf (" flags = %d\n", btree->flags) ;
313 printf (" cachesize = %d\n", btree->cachesize) ;
314 printf (" psize = %d\n", btree->psize) ;
315 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
316 printf (" minkeypage = %d\n", btree->minkeypage) ;
317 printf (" lorder = %d\n", btree->lorder) ;
322 #define PrintRecno(recno)
323 #define PrintHash(hash)
324 #define PrintBtree(btree)
337 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
339 RETVAL = *(I32 *)key.data ;
340 else if (RETVAL == 1) /* No key means empty file */
343 return ((I32)RETVAL) ;
347 GetRecnoKey(db, value)
352 /* Get the length of the array */
353 I32 length = GetArrayLength(db->dbp) ;
355 /* check for attempt to write before start of array */
356 if (length + value + 1 <= 0)
357 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
359 value = length + value + 1 ;
368 ParseOpenInfo(isHASH, name, flags, mode, sv)
377 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
378 void * openinfo = NULL ;
379 union INFO * info = &RETVAL->info ;
381 /* Default to HASH */
382 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
383 RETVAL->type = DB_HASH ;
385 /* DGH - Next line added to avoid SEGV on existing hash DB */
388 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
389 RETVAL->in_memory = (name == NULL) ;
394 croak ("type parameter is not a reference") ;
396 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
397 if (svp && SvOK(*svp))
398 action = (HV*) SvRV(*svp) ;
400 croak("internal error") ;
402 if (sv_isa(sv, "DB_File::HASHINFO"))
406 croak("DB_File can only tie an associative array to a DB_HASH database") ;
408 RETVAL->type = DB_HASH ;
409 openinfo = (void*)info ;
411 svp = hv_fetch(action, "hash", 4, FALSE);
413 if (svp && SvOK(*svp))
415 info->hash.hash = hash_cb ;
416 RETVAL->hash = newSVsv(*svp) ;
419 info->hash.hash = NULL ;
421 svp = hv_fetch(action, "bsize", 5, FALSE);
422 info->hash.bsize = svp ? SvIV(*svp) : 0;
424 svp = hv_fetch(action, "ffactor", 7, FALSE);
425 info->hash.ffactor = svp ? SvIV(*svp) : 0;
427 svp = hv_fetch(action, "nelem", 5, FALSE);
428 info->hash.nelem = svp ? SvIV(*svp) : 0;
430 svp = hv_fetch(action, "cachesize", 9, FALSE);
431 info->hash.cachesize = svp ? SvIV(*svp) : 0;
433 svp = hv_fetch(action, "lorder", 6, FALSE);
434 info->hash.lorder = svp ? SvIV(*svp) : 0;
438 else if (sv_isa(sv, "DB_File::BTREEINFO"))
441 croak("DB_File can only tie an associative array to a DB_BTREE database");
443 RETVAL->type = DB_BTREE ;
444 openinfo = (void*)info ;
446 svp = hv_fetch(action, "compare", 7, FALSE);
447 if (svp && SvOK(*svp))
449 info->btree.compare = btree_compare ;
450 RETVAL->compare = newSVsv(*svp) ;
453 info->btree.compare = NULL ;
455 svp = hv_fetch(action, "prefix", 6, FALSE);
456 if (svp && SvOK(*svp))
458 info->btree.prefix = btree_prefix ;
459 RETVAL->prefix = newSVsv(*svp) ;
462 info->btree.prefix = NULL ;
464 svp = hv_fetch(action, "flags", 5, FALSE);
465 info->btree.flags = svp ? SvIV(*svp) : 0;
467 svp = hv_fetch(action, "cachesize", 9, FALSE);
468 info->btree.cachesize = svp ? SvIV(*svp) : 0;
470 svp = hv_fetch(action, "minkeypage", 10, FALSE);
471 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
473 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
474 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
476 svp = hv_fetch(action, "psize", 5, FALSE);
477 info->btree.psize = svp ? SvIV(*svp) : 0;
479 svp = hv_fetch(action, "lorder", 6, FALSE);
480 info->btree.lorder = svp ? SvIV(*svp) : 0;
485 else if (sv_isa(sv, "DB_File::RECNOINFO"))
488 croak("DB_File can only tie an array to a DB_RECNO database");
490 RETVAL->type = DB_RECNO ;
491 openinfo = (void *)info ;
493 svp = hv_fetch(action, "flags", 5, FALSE);
494 info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
496 svp = hv_fetch(action, "cachesize", 9, FALSE);
497 info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
499 svp = hv_fetch(action, "psize", 5, FALSE);
500 info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
502 svp = hv_fetch(action, "lorder", 6, FALSE);
503 info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
505 svp = hv_fetch(action, "reclen", 6, FALSE);
506 info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
508 svp = hv_fetch(action, "bval", 4, FALSE);
509 if (svp && SvOK(*svp))
512 info->recno.bval = (u_char)*SvPV(*svp, na) ;
514 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
518 if (info->recno.flags & R_FIXEDLEN)
519 info->recno.bval = (u_char) ' ' ;
521 info->recno.bval = (u_char) '\n' ;
524 svp = hv_fetch(action, "bfname", 6, FALSE);
525 if (svp && SvOK(*svp)) {
526 char * ptr = SvPV(*svp,na) ;
527 info->recno.bfname = (char*) (na ? ptr : NULL) ;
530 info->recno.bfname = NULL ;
535 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
539 /* OS2 Specific Code */
546 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
556 croak("DB_File::%s not implemented on this architecture", s);
570 if (strEQ(name, "BTREEMAGIC"))
576 if (strEQ(name, "BTREEVERSION"))
586 if (strEQ(name, "DB_LOCK"))
592 if (strEQ(name, "DB_SHMEM"))
598 if (strEQ(name, "DB_TXN"))
612 if (strEQ(name, "HASHMAGIC"))
618 if (strEQ(name, "HASHVERSION"))
634 if (strEQ(name, "MAX_PAGE_NUMBER"))
635 #ifdef MAX_PAGE_NUMBER
636 return (U32)MAX_PAGE_NUMBER;
640 if (strEQ(name, "MAX_PAGE_OFFSET"))
641 #ifdef MAX_PAGE_OFFSET
642 return MAX_PAGE_OFFSET;
646 if (strEQ(name, "MAX_REC_NUMBER"))
647 #ifdef MAX_REC_NUMBER
648 return (U32)MAX_REC_NUMBER;
662 if (strEQ(name, "RET_ERROR"))
668 if (strEQ(name, "RET_SPECIAL"))
674 if (strEQ(name, "RET_SUCCESS"))
680 if (strEQ(name, "R_CURSOR"))
686 if (strEQ(name, "R_DUP"))
692 if (strEQ(name, "R_FIRST"))
698 if (strEQ(name, "R_FIXEDLEN"))
704 if (strEQ(name, "R_IAFTER"))
710 if (strEQ(name, "R_IBEFORE"))
716 if (strEQ(name, "R_LAST"))
722 if (strEQ(name, "R_NEXT"))
728 if (strEQ(name, "R_NOKEY"))
734 if (strEQ(name, "R_NOOVERWRITE"))
736 return R_NOOVERWRITE;
740 if (strEQ(name, "R_PREV"))
746 if (strEQ(name, "R_RECNOSYNC"))
752 if (strEQ(name, "R_SETCURSOR"))
758 if (strEQ(name, "R_SNAPSHOT"))
782 if (strEQ(name, "__R_UNUSED"))
798 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
807 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
814 char * name = (char *) NULL ;
815 SV * sv = (SV *) NULL ;
817 if (items >= 3 && SvOK(ST(2)))
818 name = (char*) SvPV(ST(2), na) ;
823 RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
824 if (RETVAL->dbp == NULL)
837 SvREFCNT_dec(db->hash) ;
839 SvREFCNT_dec(db->compare) ;
841 SvREFCNT_dec(db->prefix) ;
846 db_DELETE(db, key, flags=0)
863 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
869 db_FETCH(db, key, flags=0)
878 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
879 ST(0) = sv_newmortal();
881 sv_setpvn(ST(0), value.data, value.size);
885 db_STORE(db, key, value, flags=0)
904 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
905 ST(0) = sv_newmortal();
908 if (db->type != DB_RECNO)
909 sv_setpvn(ST(0), key.data, key.size);
911 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
925 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
926 ST(0) = sv_newmortal();
929 if (db->type != DB_RECNO)
930 sv_setpvn(ST(0), key.data, key.size);
932 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
937 # These would be nice for RECNO
953 for (i = items-1 ; i > 0 ; --i)
955 value.data = SvPV(ST(i), na) ;
959 key.size = sizeof(int) ;
960 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
978 /* First get the final value */
979 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
980 ST(0) = sv_newmortal();
984 /* the call to del will trash value, so take a copy now */
985 sv_setpvn(ST(0), value.data, value.size);
986 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
988 sv_setsv(ST(0), &sv_undef);
1002 /* get the first value */
1003 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
1004 ST(0) = sv_newmortal();
1008 /* the call to del will trash value, so take a copy now */
1009 sv_setpvn(ST(0), value.data, value.size);
1010 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
1012 sv_setsv (ST(0), &sv_undef) ;
1023 DBTKEY * keyptr = &key ;
1029 /* Set the Cursor to the Last element */
1030 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1035 for (i = items - 1 ; i > 0 ; --i)
1037 value.data = SvPV(ST(i), na) ;
1039 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1054 RETVAL = GetArrayLength(db->dbp) ;
1060 # Now provide an interface to the rest of the DB functionality
1064 db_del(db, key, flags=0)
1073 db_get(db, key, value, flags=0)
1084 db_put(db, key, value, flags=0)
1092 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1101 db_sync(db, flags=0)
1109 db_seq(db, key, value, flags)