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.
56 /* #ifdef DB_VERSION_MAJOR */
57 /* #include <db_185.h> */
66 #define DB_Prefix_t mDB_Prefix_t
73 #define DB_Hash_t mDB_Hash_t
92 typedef DB_File_type * DB_File ;
98 #define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
99 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
100 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
101 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
103 #define db_close(db) ((db->dbp)->close)(db->dbp)
104 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
105 #define db_fd(db) (db->in_memory \
107 : ((db->dbp)->fd)(db->dbp) )
108 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
109 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
110 #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
111 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
114 #define OutputValue(arg, name) \
115 { if (RETVAL == 0) { \
116 sv_setpvn(arg, name.data, name.size) ; \
120 #define OutputKey(arg, name) \
123 if (db->type != DB_RECNO) { \
124 sv_setpvn(arg, name.data, name.size); \
127 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
131 /* Internal Global Data */
132 static recno_t Value ;
133 static DB_File CurrentDB ;
134 static recno_t zero = 0 ;
135 static DBTKEY empty = { &zero, sizeof(recno_t) } ;
139 btree_compare(key1, key2)
145 void * data1, * data2 ;
152 /* As newSVpv will assume that the data pointer is a null terminated C
153 string if the size parameter is 0, make sure that data points to an
154 empty string if the length is 0
166 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
167 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
170 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
175 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
187 btree_prefix(key1, key2)
193 void * data1, * data2 ;
200 /* As newSVpv will assume that the data pointer is a null terminated C
201 string if the size parameter is 0, make sure that data points to an
202 empty string if the length is 0
214 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
215 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
218 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
223 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
247 /* DGH - Next two lines added to fix corrupted stack problem */
253 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
256 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
261 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
279 printf ("HASH Info\n") ;
280 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
281 printf (" bsize = %d\n", hash->bsize) ;
282 printf (" ffactor = %d\n", hash->ffactor) ;
283 printf (" nelem = %d\n", hash->nelem) ;
284 printf (" cachesize = %d\n", hash->cachesize) ;
285 printf (" lorder = %d\n", hash->lorder) ;
293 printf ("RECNO Info\n") ;
294 printf (" flags = %d\n", recno->flags) ;
295 printf (" cachesize = %d\n", recno->cachesize) ;
296 printf (" psize = %d\n", recno->psize) ;
297 printf (" lorder = %d\n", recno->lorder) ;
298 printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
299 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
300 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
307 printf ("BTREE Info\n") ;
308 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
309 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
310 printf (" flags = %d\n", btree->flags) ;
311 printf (" cachesize = %d\n", btree->cachesize) ;
312 printf (" psize = %d\n", btree->psize) ;
313 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
314 printf (" minkeypage = %d\n", btree->minkeypage) ;
315 printf (" lorder = %d\n", btree->lorder) ;
320 #define PrintRecno(recno)
321 #define PrintHash(hash)
322 #define PrintBtree(btree)
335 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
337 RETVAL = *(I32 *)key.data ;
338 else if (RETVAL == 1) /* No key means empty file */
341 return ((I32)RETVAL) ;
345 GetRecnoKey(db, value)
350 /* Get the length of the array */
351 I32 length = GetArrayLength(db->dbp) ;
353 /* check for attempt to write before start of array */
354 if (length + value + 1 <= 0)
355 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
357 value = length + value + 1 ;
366 ParseOpenInfo(isHASH, name, flags, mode, sv)
375 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
376 void * openinfo = NULL ;
377 union INFO * info = &RETVAL->info ;
379 /* Default to HASH */
380 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
381 RETVAL->type = DB_HASH ;
383 /* DGH - Next line added to avoid SEGV on existing hash DB */
386 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
387 RETVAL->in_memory = (name == NULL) ;
392 croak ("type parameter is not a reference") ;
394 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
395 if (svp && SvOK(*svp))
396 action = (HV*) SvRV(*svp) ;
398 croak("internal error") ;
400 if (sv_isa(sv, "DB_File::HASHINFO"))
404 croak("DB_File can only tie an associative array to a DB_HASH database") ;
406 RETVAL->type = DB_HASH ;
407 openinfo = (void*)info ;
409 svp = hv_fetch(action, "hash", 4, FALSE);
411 if (svp && SvOK(*svp))
413 info->hash.hash = hash_cb ;
414 RETVAL->hash = newSVsv(*svp) ;
417 info->hash.hash = NULL ;
419 svp = hv_fetch(action, "bsize", 5, FALSE);
420 info->hash.bsize = svp ? SvIV(*svp) : 0;
422 svp = hv_fetch(action, "ffactor", 7, FALSE);
423 info->hash.ffactor = svp ? SvIV(*svp) : 0;
425 svp = hv_fetch(action, "nelem", 5, FALSE);
426 info->hash.nelem = svp ? SvIV(*svp) : 0;
428 svp = hv_fetch(action, "cachesize", 9, FALSE);
429 info->hash.cachesize = svp ? SvIV(*svp) : 0;
431 svp = hv_fetch(action, "lorder", 6, FALSE);
432 info->hash.lorder = svp ? SvIV(*svp) : 0;
436 else if (sv_isa(sv, "DB_File::BTREEINFO"))
439 croak("DB_File can only tie an associative array to a DB_BTREE database");
441 RETVAL->type = DB_BTREE ;
442 openinfo = (void*)info ;
444 svp = hv_fetch(action, "compare", 7, FALSE);
445 if (svp && SvOK(*svp))
447 info->btree.compare = btree_compare ;
448 RETVAL->compare = newSVsv(*svp) ;
451 info->btree.compare = NULL ;
453 svp = hv_fetch(action, "prefix", 6, FALSE);
454 if (svp && SvOK(*svp))
456 info->btree.prefix = btree_prefix ;
457 RETVAL->prefix = newSVsv(*svp) ;
460 info->btree.prefix = NULL ;
462 svp = hv_fetch(action, "flags", 5, FALSE);
463 info->btree.flags = svp ? SvIV(*svp) : 0;
465 svp = hv_fetch(action, "cachesize", 9, FALSE);
466 info->btree.cachesize = svp ? SvIV(*svp) : 0;
468 svp = hv_fetch(action, "minkeypage", 10, FALSE);
469 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
471 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
472 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
474 svp = hv_fetch(action, "psize", 5, FALSE);
475 info->btree.psize = svp ? SvIV(*svp) : 0;
477 svp = hv_fetch(action, "lorder", 6, FALSE);
478 info->btree.lorder = svp ? SvIV(*svp) : 0;
483 else if (sv_isa(sv, "DB_File::RECNOINFO"))
486 croak("DB_File can only tie an array to a DB_RECNO database");
488 RETVAL->type = DB_RECNO ;
489 openinfo = (void *)info ;
491 svp = hv_fetch(action, "flags", 5, FALSE);
492 info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
494 svp = hv_fetch(action, "cachesize", 9, FALSE);
495 info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
497 svp = hv_fetch(action, "psize", 5, FALSE);
498 info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
500 svp = hv_fetch(action, "lorder", 6, FALSE);
501 info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
503 svp = hv_fetch(action, "reclen", 6, FALSE);
504 info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
506 svp = hv_fetch(action, "bval", 4, FALSE);
507 if (svp && SvOK(*svp))
510 info->recno.bval = (u_char)*SvPV(*svp, na) ;
512 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
516 if (info->recno.flags & R_FIXEDLEN)
517 info->recno.bval = (u_char) ' ' ;
519 info->recno.bval = (u_char) '\n' ;
522 svp = hv_fetch(action, "bfname", 6, FALSE);
523 if (svp && SvOK(*svp)) {
524 char * ptr = SvPV(*svp,na) ;
525 info->recno.bfname = (char*) (na ? ptr : NULL) ;
528 info->recno.bfname = NULL ;
533 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
537 /* OS2 Specific Code */
544 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
554 croak("DB_File::%s not implemented on this architecture", s);
568 if (strEQ(name, "BTREEMAGIC"))
574 if (strEQ(name, "BTREEVERSION"))
584 if (strEQ(name, "DB_LOCK"))
590 if (strEQ(name, "DB_SHMEM"))
596 if (strEQ(name, "DB_TXN"))
610 if (strEQ(name, "HASHMAGIC"))
616 if (strEQ(name, "HASHVERSION"))
632 if (strEQ(name, "MAX_PAGE_NUMBER"))
633 #ifdef MAX_PAGE_NUMBER
634 return (U32)MAX_PAGE_NUMBER;
638 if (strEQ(name, "MAX_PAGE_OFFSET"))
639 #ifdef MAX_PAGE_OFFSET
640 return MAX_PAGE_OFFSET;
644 if (strEQ(name, "MAX_REC_NUMBER"))
645 #ifdef MAX_REC_NUMBER
646 return (U32)MAX_REC_NUMBER;
660 if (strEQ(name, "RET_ERROR"))
666 if (strEQ(name, "RET_SPECIAL"))
672 if (strEQ(name, "RET_SUCCESS"))
678 if (strEQ(name, "R_CURSOR"))
684 if (strEQ(name, "R_DUP"))
690 if (strEQ(name, "R_FIRST"))
696 if (strEQ(name, "R_FIXEDLEN"))
702 if (strEQ(name, "R_IAFTER"))
708 if (strEQ(name, "R_IBEFORE"))
714 if (strEQ(name, "R_LAST"))
720 if (strEQ(name, "R_NEXT"))
726 if (strEQ(name, "R_NOKEY"))
732 if (strEQ(name, "R_NOOVERWRITE"))
734 return R_NOOVERWRITE;
738 if (strEQ(name, "R_PREV"))
744 if (strEQ(name, "R_RECNOSYNC"))
750 if (strEQ(name, "R_SETCURSOR"))
756 if (strEQ(name, "R_SNAPSHOT"))
780 if (strEQ(name, "__R_UNUSED"))
796 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
805 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
812 char * name = (char *) NULL ;
813 SV * sv = (SV *) NULL ;
815 if (items >= 3 && SvOK(ST(2)))
816 name = (char*) SvPV(ST(2), na) ;
821 RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
822 if (RETVAL->dbp == NULL)
835 SvREFCNT_dec(db->hash) ;
837 SvREFCNT_dec(db->compare) ;
839 SvREFCNT_dec(db->prefix) ;
844 db_DELETE(db, key, flags=0)
861 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
867 db_FETCH(db, key, flags=0)
876 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
877 ST(0) = sv_newmortal();
879 sv_setpvn(ST(0), value.data, value.size);
883 db_STORE(db, key, value, flags=0)
902 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
903 ST(0) = sv_newmortal();
906 if (db->type != DB_RECNO)
907 sv_setpvn(ST(0), key.data, key.size);
909 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
923 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
924 ST(0) = sv_newmortal();
927 if (db->type != DB_RECNO)
928 sv_setpvn(ST(0), key.data, key.size);
930 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
935 # These would be nice for RECNO
951 for (i = items-1 ; i > 0 ; --i)
953 value.data = SvPV(ST(i), na) ;
957 key.size = sizeof(int) ;
958 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
976 /* First get the final value */
977 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
978 ST(0) = sv_newmortal();
982 /* the call to del will trash value, so take a copy now */
983 sv_setpvn(ST(0), value.data, value.size);
984 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
986 sv_setsv(ST(0), &sv_undef);
1000 /* get the first value */
1001 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
1002 ST(0) = sv_newmortal();
1006 /* the call to del will trash value, so take a copy now */
1007 sv_setpvn(ST(0), value.data, value.size);
1008 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
1010 sv_setsv (ST(0), &sv_undef) ;
1021 DBTKEY * keyptr = &key ;
1027 /* Set the Cursor to the Last element */
1028 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1033 for (i = items - 1 ; i > 0 ; --i)
1035 value.data = SvPV(ST(i), na) ;
1037 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1052 RETVAL = GetArrayLength(db->dbp) ;
1058 # Now provide an interface to the rest of the DB functionality
1062 db_del(db, key, flags=0)
1071 db_get(db, key, value, flags=0)
1082 db_put(db, key, value, flags=0)
1090 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1099 db_sync(db, flags=0)
1107 db_seq(db, key, value, flags)