3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
6 last modified 6th Feb 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
56 #define DB_Prefix_t mDB_Prefix_t
63 #define DB_Hash_t mDB_Hash_t
82 typedef DB_File_type * DB_File ;
88 #define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
89 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
90 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
91 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
93 #define db_close(db) ((db->dbp)->close)(db->dbp)
94 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
95 #define db_fd(db) (db->in_memory \
97 : ((db->dbp)->fd)(db->dbp) )
98 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
99 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
100 #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
101 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
104 #define OutputValue(arg, name) \
105 { if (RETVAL == 0) { \
106 sv_setpvn(arg, name.data, name.size) ; \
110 #define OutputKey(arg, name) \
113 if (db->type != DB_RECNO) { \
114 sv_setpvn(arg, name.data, name.size); \
117 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
121 /* Internal Global Data */
122 static recno_t Value ;
123 static DB_File CurrentDB ;
124 static recno_t zero = 0 ;
125 static DBTKEY empty = { &zero, sizeof(recno_t) } ;
129 btree_compare(key1, key2)
134 void * data1, * data2 ;
141 /* As newSVpv will assume that the data pointer is a null terminated C
142 string if the size parameter is 0, make sure that data points to an
143 empty string if the length is 0
155 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
156 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
159 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
164 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
176 btree_prefix(key1, key2)
181 void * data1, * data2 ;
188 /* As newSVpv will assume that the data pointer is a null terminated C
189 string if the size parameter is 0, make sure that data points to an
190 empty string if the length is 0
202 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
203 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
206 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
211 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
234 /* DGH - Next two lines added to fix corrupted stack problem */
240 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
243 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
248 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
266 printf ("HASH Info\n") ;
267 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
268 printf (" bsize = %d\n", hash->bsize) ;
269 printf (" ffactor = %d\n", hash->ffactor) ;
270 printf (" nelem = %d\n", hash->nelem) ;
271 printf (" cachesize = %d\n", hash->cachesize) ;
272 printf (" lorder = %d\n", hash->lorder) ;
280 printf ("RECNO Info\n") ;
281 printf (" flags = %d\n", recno->flags) ;
282 printf (" cachesize = %d\n", recno->cachesize) ;
283 printf (" psize = %d\n", recno->psize) ;
284 printf (" lorder = %d\n", recno->lorder) ;
285 printf (" reclen = %d\n", recno->reclen) ;
286 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
287 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
294 printf ("BTREE Info\n") ;
295 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
296 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
297 printf (" flags = %d\n", btree->flags) ;
298 printf (" cachesize = %d\n", btree->cachesize) ;
299 printf (" psize = %d\n", btree->psize) ;
300 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
301 printf (" minkeypage = %d\n", btree->minkeypage) ;
302 printf (" lorder = %d\n", btree->lorder) ;
307 #define PrintRecno(recno)
308 #define PrintHash(hash)
309 #define PrintBtree(btree)
322 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
324 RETVAL = *(I32 *)key.data ;
325 else if (RETVAL == 1) /* No key means empty file */
328 return ((I32)RETVAL) ;
332 GetRecnoKey(db, value)
337 /* Get the length of the array */
338 I32 length = GetArrayLength(db->dbp) ;
340 /* check for attempt to write before start of array */
341 if (length + value + 1 <= 0)
342 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
344 value = length + value + 1 ;
353 ParseOpenInfo(name, flags, mode, sv)
361 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
362 void * openinfo = NULL ;
363 union INFO * info = &RETVAL->info ;
365 /* Default to HASH */
366 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
367 RETVAL->type = DB_HASH ;
369 /* DGH - Next line added to avoid SEGV on existing hash DB */
372 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
373 RETVAL->in_memory = (name == NULL) ;
378 croak ("type parameter is not a reference") ;
380 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
381 if (svp && SvOK(*svp))
382 action = (HV*) SvRV(*svp) ;
384 croak("internal error") ;
386 if (sv_isa(sv, "DB_File::HASHINFO"))
388 RETVAL->type = DB_HASH ;
389 openinfo = (void*)info ;
391 svp = hv_fetch(action, "hash", 4, FALSE);
393 if (svp && SvOK(*svp))
395 info->hash.hash = hash_cb ;
396 RETVAL->hash = newSVsv(*svp) ;
399 info->hash.hash = NULL ;
401 svp = hv_fetch(action, "bsize", 5, FALSE);
402 info->hash.bsize = svp ? SvIV(*svp) : 0;
404 svp = hv_fetch(action, "ffactor", 7, FALSE);
405 info->hash.ffactor = svp ? SvIV(*svp) : 0;
407 svp = hv_fetch(action, "nelem", 5, FALSE);
408 info->hash.nelem = svp ? SvIV(*svp) : 0;
410 svp = hv_fetch(action, "cachesize", 9, FALSE);
411 info->hash.cachesize = svp ? SvIV(*svp) : 0;
413 svp = hv_fetch(action, "lorder", 6, FALSE);
414 info->hash.lorder = svp ? SvIV(*svp) : 0;
418 else if (sv_isa(sv, "DB_File::BTREEINFO"))
420 RETVAL->type = DB_BTREE ;
421 openinfo = (void*)info ;
423 svp = hv_fetch(action, "compare", 7, FALSE);
424 if (svp && SvOK(*svp))
426 info->btree.compare = btree_compare ;
427 RETVAL->compare = newSVsv(*svp) ;
430 info->btree.compare = NULL ;
432 svp = hv_fetch(action, "prefix", 6, FALSE);
433 if (svp && SvOK(*svp))
435 info->btree.prefix = btree_prefix ;
436 RETVAL->prefix = newSVsv(*svp) ;
439 info->btree.prefix = NULL ;
441 svp = hv_fetch(action, "flags", 5, FALSE);
442 info->btree.flags = svp ? SvIV(*svp) : 0;
444 svp = hv_fetch(action, "cachesize", 9, FALSE);
445 info->btree.cachesize = svp ? SvIV(*svp) : 0;
447 svp = hv_fetch(action, "minkeypage", 10, FALSE);
448 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
450 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
451 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
453 svp = hv_fetch(action, "psize", 5, FALSE);
454 info->btree.psize = svp ? SvIV(*svp) : 0;
456 svp = hv_fetch(action, "lorder", 6, FALSE);
457 info->btree.lorder = svp ? SvIV(*svp) : 0;
462 else if (sv_isa(sv, "DB_File::RECNOINFO"))
464 RETVAL->type = DB_RECNO ;
465 openinfo = (void *)info ;
467 svp = hv_fetch(action, "flags", 5, FALSE);
468 info->recno.flags = (u_long) svp ? SvIV(*svp) : 0;
470 svp = hv_fetch(action, "cachesize", 9, FALSE);
471 info->recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
473 svp = hv_fetch(action, "psize", 5, FALSE);
474 info->recno.psize = (int) svp ? SvIV(*svp) : 0;
476 svp = hv_fetch(action, "lorder", 6, FALSE);
477 info->recno.lorder = (int) svp ? SvIV(*svp) : 0;
479 svp = hv_fetch(action, "reclen", 6, FALSE);
480 info->recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
482 svp = hv_fetch(action, "bval", 4, FALSE);
483 if (svp && SvOK(*svp))
486 info->recno.bval = (u_char)*SvPV(*svp, na) ;
488 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
492 if (info->recno.flags & R_FIXEDLEN)
493 info->recno.bval = (u_char) ' ' ;
495 info->recno.bval = (u_char) '\n' ;
498 svp = hv_fetch(action, "bfname", 6, FALSE);
499 if (svp && SvOK(*svp)) {
500 char * ptr = SvPV(*svp,na) ;
501 info->recno.bfname = (char*) na ? ptr : NULL ;
504 info->recno.bfname = NULL ;
509 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
513 /* OS2 Specific Code */
520 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
530 croak("DB_File::%s not implemented on this architecture", s);
544 if (strEQ(name, "BTREEMAGIC"))
550 if (strEQ(name, "BTREEVERSION"))
560 if (strEQ(name, "DB_LOCK"))
566 if (strEQ(name, "DB_SHMEM"))
572 if (strEQ(name, "DB_TXN"))
586 if (strEQ(name, "HASHMAGIC"))
592 if (strEQ(name, "HASHVERSION"))
608 if (strEQ(name, "MAX_PAGE_NUMBER"))
609 #ifdef MAX_PAGE_NUMBER
610 return (U32)MAX_PAGE_NUMBER;
614 if (strEQ(name, "MAX_PAGE_OFFSET"))
615 #ifdef MAX_PAGE_OFFSET
616 return MAX_PAGE_OFFSET;
620 if (strEQ(name, "MAX_REC_NUMBER"))
621 #ifdef MAX_REC_NUMBER
622 return (U32)MAX_REC_NUMBER;
636 if (strEQ(name, "RET_ERROR"))
642 if (strEQ(name, "RET_SPECIAL"))
648 if (strEQ(name, "RET_SUCCESS"))
654 if (strEQ(name, "R_CURSOR"))
660 if (strEQ(name, "R_DUP"))
666 if (strEQ(name, "R_FIRST"))
672 if (strEQ(name, "R_FIXEDLEN"))
678 if (strEQ(name, "R_IAFTER"))
684 if (strEQ(name, "R_IBEFORE"))
690 if (strEQ(name, "R_LAST"))
696 if (strEQ(name, "R_NEXT"))
702 if (strEQ(name, "R_NOKEY"))
708 if (strEQ(name, "R_NOOVERWRITE"))
710 return R_NOOVERWRITE;
714 if (strEQ(name, "R_PREV"))
720 if (strEQ(name, "R_RECNOSYNC"))
726 if (strEQ(name, "R_SETCURSOR"))
732 if (strEQ(name, "R_SNAPSHOT"))
756 if (strEQ(name, "__R_UNUSED"))
772 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
781 db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
787 char * name = (char *) NULL ;
788 SV * sv = (SV *) NULL ;
790 if (items >= 2 && SvOK(ST(1)))
791 name = (char*) SvPV(ST(1), na) ;
796 RETVAL = ParseOpenInfo(name, flags, mode, sv) ;
797 if (RETVAL->dbp == NULL)
810 SvREFCNT_dec(db->hash) ;
812 SvREFCNT_dec(db->compare) ;
814 SvREFCNT_dec(db->prefix) ;
819 db_DELETE(db, key, flags=0)
836 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
842 db_FETCH(db, key, flags=0)
851 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
852 ST(0) = sv_newmortal();
854 sv_setpvn(ST(0), value.data, value.size);
858 db_STORE(db, key, value, flags=0)
877 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
878 ST(0) = sv_newmortal();
881 if (Db->type != DB_RECNO)
882 sv_setpvn(ST(0), key.data, key.size);
884 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
898 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
899 ST(0) = sv_newmortal();
902 if (Db->type != DB_RECNO)
903 sv_setpvn(ST(0), key.data, key.size);
905 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
910 # These would be nice for RECNO
926 for (i = items-1 ; i > 0 ; --i)
928 value.data = SvPV(ST(i), na) ;
932 key.size = sizeof(int) ;
933 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
951 /* First get the final value */
952 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
953 ST(0) = sv_newmortal();
957 /* the call to del will trash value, so take a copy now */
958 sv_setpvn(ST(0), value.data, value.size);
959 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
961 sv_setsv(ST(0), &sv_undef);
975 /* get the first value */
976 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
977 ST(0) = sv_newmortal();
981 /* the call to del will trash value, so take a copy now */
982 sv_setpvn(ST(0), value.data, value.size);
983 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
985 sv_setsv (ST(0), &sv_undef) ;
996 DBTKEY * keyptr = &key ;
1002 /* Set the Cursor to the Last element */
1003 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1008 for (i = items - 1 ; i > 0 ; --i)
1010 value.data = SvPV(ST(i), na) ;
1012 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1027 RETVAL = GetArrayLength(db->dbp) ;
1033 # Now provide an interface to the rest of the DB functionality
1037 db_del(db, key, flags=0)
1046 db_get(db, key, value, flags=0)
1057 db_put(db, key, value, flags=0)
1065 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1074 db_sync(db, flags=0)
1082 db_seq(db, key, value, flags)