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)
144 void * data1, * data2 ;
151 /* As newSVpv will assume that the data pointer is a null terminated C
152 string if the size parameter is 0, make sure that data points to an
153 empty string if the length is 0
165 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
166 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
169 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
174 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
186 btree_prefix(key1, key2)
191 void * data1, * data2 ;
198 /* As newSVpv will assume that the data pointer is a null terminated C
199 string if the size parameter is 0, make sure that data points to an
200 empty string if the length is 0
212 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
213 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
216 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
221 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
244 /* DGH - Next two lines added to fix corrupted stack problem */
250 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
253 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
258 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
276 printf ("HASH Info\n") ;
277 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
278 printf (" bsize = %d\n", hash->bsize) ;
279 printf (" ffactor = %d\n", hash->ffactor) ;
280 printf (" nelem = %d\n", hash->nelem) ;
281 printf (" cachesize = %d\n", hash->cachesize) ;
282 printf (" lorder = %d\n", hash->lorder) ;
290 printf ("RECNO Info\n") ;
291 printf (" flags = %d\n", recno->flags) ;
292 printf (" cachesize = %d\n", recno->cachesize) ;
293 printf (" psize = %d\n", recno->psize) ;
294 printf (" lorder = %d\n", recno->lorder) ;
295 printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
296 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
297 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
304 printf ("BTREE Info\n") ;
305 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
306 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
307 printf (" flags = %d\n", btree->flags) ;
308 printf (" cachesize = %d\n", btree->cachesize) ;
309 printf (" psize = %d\n", btree->psize) ;
310 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
311 printf (" minkeypage = %d\n", btree->minkeypage) ;
312 printf (" lorder = %d\n", btree->lorder) ;
317 #define PrintRecno(recno)
318 #define PrintHash(hash)
319 #define PrintBtree(btree)
332 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
334 RETVAL = *(I32 *)key.data ;
335 else if (RETVAL == 1) /* No key means empty file */
338 return ((I32)RETVAL) ;
342 GetRecnoKey(db, value)
347 /* Get the length of the array */
348 I32 length = GetArrayLength(db->dbp) ;
350 /* check for attempt to write before start of array */
351 if (length + value + 1 <= 0)
352 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
354 value = length + value + 1 ;
363 ParseOpenInfo(isHASH, name, flags, mode, sv)
372 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
373 void * openinfo = NULL ;
374 union INFO * info = &RETVAL->info ;
376 /* Default to HASH */
377 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
378 RETVAL->type = DB_HASH ;
380 /* DGH - Next line added to avoid SEGV on existing hash DB */
383 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
384 RETVAL->in_memory = (name == NULL) ;
389 croak ("type parameter is not a reference") ;
391 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
392 if (svp && SvOK(*svp))
393 action = (HV*) SvRV(*svp) ;
395 croak("internal error") ;
397 if (sv_isa(sv, "DB_File::HASHINFO"))
401 croak("DB_File can only tie an associative array to a DB_HASH database") ;
403 RETVAL->type = DB_HASH ;
404 openinfo = (void*)info ;
406 svp = hv_fetch(action, "hash", 4, FALSE);
408 if (svp && SvOK(*svp))
410 info->hash.hash = hash_cb ;
411 RETVAL->hash = newSVsv(*svp) ;
414 info->hash.hash = NULL ;
416 svp = hv_fetch(action, "bsize", 5, FALSE);
417 info->hash.bsize = svp ? SvIV(*svp) : 0;
419 svp = hv_fetch(action, "ffactor", 7, FALSE);
420 info->hash.ffactor = svp ? SvIV(*svp) : 0;
422 svp = hv_fetch(action, "nelem", 5, FALSE);
423 info->hash.nelem = svp ? SvIV(*svp) : 0;
425 svp = hv_fetch(action, "cachesize", 9, FALSE);
426 info->hash.cachesize = svp ? SvIV(*svp) : 0;
428 svp = hv_fetch(action, "lorder", 6, FALSE);
429 info->hash.lorder = svp ? SvIV(*svp) : 0;
433 else if (sv_isa(sv, "DB_File::BTREEINFO"))
436 croak("DB_File can only tie an associative array to a DB_BTREE database");
438 RETVAL->type = DB_BTREE ;
439 openinfo = (void*)info ;
441 svp = hv_fetch(action, "compare", 7, FALSE);
442 if (svp && SvOK(*svp))
444 info->btree.compare = btree_compare ;
445 RETVAL->compare = newSVsv(*svp) ;
448 info->btree.compare = NULL ;
450 svp = hv_fetch(action, "prefix", 6, FALSE);
451 if (svp && SvOK(*svp))
453 info->btree.prefix = btree_prefix ;
454 RETVAL->prefix = newSVsv(*svp) ;
457 info->btree.prefix = NULL ;
459 svp = hv_fetch(action, "flags", 5, FALSE);
460 info->btree.flags = svp ? SvIV(*svp) : 0;
462 svp = hv_fetch(action, "cachesize", 9, FALSE);
463 info->btree.cachesize = svp ? SvIV(*svp) : 0;
465 svp = hv_fetch(action, "minkeypage", 10, FALSE);
466 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
468 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
469 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
471 svp = hv_fetch(action, "psize", 5, FALSE);
472 info->btree.psize = svp ? SvIV(*svp) : 0;
474 svp = hv_fetch(action, "lorder", 6, FALSE);
475 info->btree.lorder = svp ? SvIV(*svp) : 0;
480 else if (sv_isa(sv, "DB_File::RECNOINFO"))
483 croak("DB_File can only tie an array to a DB_RECNO database");
485 RETVAL->type = DB_RECNO ;
486 openinfo = (void *)info ;
488 svp = hv_fetch(action, "flags", 5, FALSE);
489 info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
491 svp = hv_fetch(action, "cachesize", 9, FALSE);
492 info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
494 svp = hv_fetch(action, "psize", 5, FALSE);
495 info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
497 svp = hv_fetch(action, "lorder", 6, FALSE);
498 info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
500 svp = hv_fetch(action, "reclen", 6, FALSE);
501 info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
503 svp = hv_fetch(action, "bval", 4, FALSE);
504 if (svp && SvOK(*svp))
507 info->recno.bval = (u_char)*SvPV(*svp, na) ;
509 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
513 if (info->recno.flags & R_FIXEDLEN)
514 info->recno.bval = (u_char) ' ' ;
516 info->recno.bval = (u_char) '\n' ;
519 svp = hv_fetch(action, "bfname", 6, FALSE);
520 if (svp && SvOK(*svp)) {
521 char * ptr = SvPV(*svp,na) ;
522 info->recno.bfname = (char*) (na ? ptr : NULL) ;
525 info->recno.bfname = NULL ;
530 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
534 /* OS2 Specific Code */
541 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
551 croak("DB_File::%s not implemented on this architecture", s);
565 if (strEQ(name, "BTREEMAGIC"))
571 if (strEQ(name, "BTREEVERSION"))
581 if (strEQ(name, "DB_LOCK"))
587 if (strEQ(name, "DB_SHMEM"))
593 if (strEQ(name, "DB_TXN"))
607 if (strEQ(name, "HASHMAGIC"))
613 if (strEQ(name, "HASHVERSION"))
629 if (strEQ(name, "MAX_PAGE_NUMBER"))
630 #ifdef MAX_PAGE_NUMBER
631 return (U32)MAX_PAGE_NUMBER;
635 if (strEQ(name, "MAX_PAGE_OFFSET"))
636 #ifdef MAX_PAGE_OFFSET
637 return MAX_PAGE_OFFSET;
641 if (strEQ(name, "MAX_REC_NUMBER"))
642 #ifdef MAX_REC_NUMBER
643 return (U32)MAX_REC_NUMBER;
657 if (strEQ(name, "RET_ERROR"))
663 if (strEQ(name, "RET_SPECIAL"))
669 if (strEQ(name, "RET_SUCCESS"))
675 if (strEQ(name, "R_CURSOR"))
681 if (strEQ(name, "R_DUP"))
687 if (strEQ(name, "R_FIRST"))
693 if (strEQ(name, "R_FIXEDLEN"))
699 if (strEQ(name, "R_IAFTER"))
705 if (strEQ(name, "R_IBEFORE"))
711 if (strEQ(name, "R_LAST"))
717 if (strEQ(name, "R_NEXT"))
723 if (strEQ(name, "R_NOKEY"))
729 if (strEQ(name, "R_NOOVERWRITE"))
731 return R_NOOVERWRITE;
735 if (strEQ(name, "R_PREV"))
741 if (strEQ(name, "R_RECNOSYNC"))
747 if (strEQ(name, "R_SETCURSOR"))
753 if (strEQ(name, "R_SNAPSHOT"))
777 if (strEQ(name, "__R_UNUSED"))
793 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
802 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
809 char * name = (char *) NULL ;
810 SV * sv = (SV *) NULL ;
812 if (items >= 3 && SvOK(ST(2)))
813 name = (char*) SvPV(ST(2), na) ;
818 RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
819 if (RETVAL->dbp == NULL)
832 SvREFCNT_dec(db->hash) ;
834 SvREFCNT_dec(db->compare) ;
836 SvREFCNT_dec(db->prefix) ;
841 db_DELETE(db, key, flags=0)
858 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
864 db_FETCH(db, key, flags=0)
873 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
874 ST(0) = sv_newmortal();
876 sv_setpvn(ST(0), value.data, value.size);
880 db_STORE(db, key, value, flags=0)
899 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
900 ST(0) = sv_newmortal();
903 if (db->type != DB_RECNO)
904 sv_setpvn(ST(0), key.data, key.size);
906 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
920 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
921 ST(0) = sv_newmortal();
924 if (db->type != DB_RECNO)
925 sv_setpvn(ST(0), key.data, key.size);
927 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
932 # These would be nice for RECNO
948 for (i = items-1 ; i > 0 ; --i)
950 value.data = SvPV(ST(i), na) ;
954 key.size = sizeof(int) ;
955 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
973 /* First get the final value */
974 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
975 ST(0) = sv_newmortal();
979 /* the call to del will trash value, so take a copy now */
980 sv_setpvn(ST(0), value.data, value.size);
981 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
983 sv_setsv(ST(0), &sv_undef);
997 /* get the first value */
998 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
999 ST(0) = sv_newmortal();
1003 /* the call to del will trash value, so take a copy now */
1004 sv_setpvn(ST(0), value.data, value.size);
1005 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
1007 sv_setsv (ST(0), &sv_undef) ;
1018 DBTKEY * keyptr = &key ;
1024 /* Set the Cursor to the Last element */
1025 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1030 for (i = items - 1 ; i > 0 ; --i)
1032 value.data = SvPV(ST(i), na) ;
1034 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1049 RETVAL = GetArrayLength(db->dbp) ;
1055 # Now provide an interface to the rest of the DB functionality
1059 db_del(db, key, flags=0)
1068 db_get(db, key, value, flags=0)
1079 db_put(db, key, value, flags=0)
1087 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1096 db_sync(db, flags=0)
1104 db_seq(db, key, value, flags)