3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
6 last modified 10th Nov 1996
9 All comments/suggestions/problems are welcome
13 0.2 - No longer bombs out if dbopen returns an error.
14 0.3 - Added some support for multiple btree compares
15 1.0 - Complete support for multiple callbacks added.
16 Fixed a problem with pushing a value onto an empty list.
17 1.01 - Fixed a SunOS core dump problem.
18 The return value from TIEHASH wasn't set to NULL when
19 dbopen returned an error.
20 1.02 - Use ALIAS to define TIEARRAY.
21 Removed some redundant commented code.
22 Merged OS2 code into the main distribution.
23 Allow negative subscripts with RECNO interface.
24 Changed the default flags to O_CREAT|O_RDWR
26 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by
27 Dave Hammen, hammen@gothamcity.jsc.nasa.gov
28 1.05 - Added logic to allow prefix & hash types to be specified via
45 #define DB_Prefix_t mDB_Prefix_t
52 #define DB_Hash_t mDB_Hash_t
70 typedef DB_File_type * DB_File ;
76 #define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
77 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
78 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
79 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
81 #define db_close(db) ((db->dbp)->close)(db->dbp)
82 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
83 #define db_fd(db) ((db->dbp)->fd)(db->dbp)
84 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
85 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
86 #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
87 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
90 #define OutputValue(arg, name) \
91 { if (RETVAL == 0) { \
92 sv_setpvn(arg, name.data, name.size) ; \
96 #define OutputKey(arg, name) \
99 if (db->type != DB_RECNO) { \
100 sv_setpvn(arg, name.data, name.size); \
103 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
107 /* Internal Global Data */
108 static recno_t Value ;
109 static DB_File CurrentDB ;
110 static recno_t zero = 0 ;
111 static DBTKEY empty = { &zero, sizeof(recno_t) } ;
115 btree_compare(key1, key2)
120 void * data1, * data2 ;
127 /* As newSVpv will assume that the data pointer is a null terminated C
128 string if the size parameter is 0, make sure that data points to an
129 empty string if the length is 0
141 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
142 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
145 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
150 croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ;
162 btree_prefix(key1, key2)
167 void * data1, * data2 ;
174 /* As newSVpv will assume that the data pointer is a null terminated C
175 string if the size parameter is 0, make sure that data points to an
176 empty string if the length is 0
188 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
189 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
192 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
197 croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ;
220 /* DGH - Next two lines added to fix corrupted stack problem */
226 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
229 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
234 croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ;
252 printf ("HASH Info\n") ;
253 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
254 printf (" bsize = %d\n", hash->bsize) ;
255 printf (" ffactor = %d\n", hash->ffactor) ;
256 printf (" nelem = %d\n", hash->nelem) ;
257 printf (" cachesize = %d\n", hash->cachesize) ;
258 printf (" lorder = %d\n", hash->lorder) ;
266 printf ("RECNO Info\n") ;
267 printf (" flags = %d\n", recno->flags) ;
268 printf (" cachesize = %d\n", recno->cachesize) ;
269 printf (" psize = %d\n", recno->psize) ;
270 printf (" lorder = %d\n", recno->lorder) ;
271 printf (" reclen = %d\n", recno->reclen) ;
272 printf (" bval = %d\n", recno->bval) ;
273 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
279 printf ("BTREE Info\n") ;
280 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
281 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
282 printf (" flags = %d\n", btree->flags) ;
283 printf (" cachesize = %d\n", btree->cachesize) ;
284 printf (" psize = %d\n", btree->psize) ;
285 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
286 printf (" minkeypage = %d\n", btree->minkeypage) ;
287 printf (" lorder = %d\n", btree->lorder) ;
292 #define PrintRecno(recno)
293 #define PrintHash(hash)
294 #define PrintBtree(btree)
307 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
309 RETVAL = *(I32 *)key.data ;
310 else if (RETVAL == 1) /* No key means empty file */
317 GetRecnoKey(db, value)
322 /* Get the length of the array */
323 I32 length = GetArrayLength(db->dbp) ;
325 /* check for attempt to write before start of array */
326 if (length + value + 1 <= 0)
327 croak("Modification of non-creatable array value attempted, subscript %d", value) ;
329 value = length + value + 1 ;
338 ParseOpenInfo(name, flags, mode, sv)
346 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
347 void * openinfo = NULL ;
348 union INFO * info = &RETVAL->info ;
350 /* Default to HASH */
351 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
352 RETVAL->type = DB_HASH ;
354 /* DGH - Next line added to avoid SEGV on existing hash DB */
360 croak ("type parameter is not a reference") ;
362 action = (HV*)SvRV(sv);
364 if (sv_isa(sv, "DB_File::HASHINFO"))
366 RETVAL->type = DB_HASH ;
367 openinfo = (void*)info ;
369 svp = hv_fetch(action, "hash", 4, FALSE);
371 if (svp && SvOK(*svp))
373 info->hash.hash = hash_cb ;
374 RETVAL->hash = newSVsv(*svp) ;
377 info->hash.hash = NULL ;
379 svp = hv_fetch(action, "bsize", 5, FALSE);
380 info->hash.bsize = svp ? SvIV(*svp) : 0;
382 svp = hv_fetch(action, "ffactor", 7, FALSE);
383 info->hash.ffactor = svp ? SvIV(*svp) : 0;
385 svp = hv_fetch(action, "nelem", 5, FALSE);
386 info->hash.nelem = svp ? SvIV(*svp) : 0;
388 svp = hv_fetch(action, "cachesize", 9, FALSE);
389 info->hash.cachesize = svp ? SvIV(*svp) : 0;
391 svp = hv_fetch(action, "lorder", 6, FALSE);
392 info->hash.lorder = svp ? SvIV(*svp) : 0;
396 else if (sv_isa(sv, "DB_File::BTREEINFO"))
398 RETVAL->type = DB_BTREE ;
399 openinfo = (void*)info ;
401 svp = hv_fetch(action, "compare", 7, FALSE);
402 if (svp && SvOK(*svp))
404 info->btree.compare = btree_compare ;
405 RETVAL->compare = newSVsv(*svp) ;
408 info->btree.compare = NULL ;
410 svp = hv_fetch(action, "prefix", 6, FALSE);
411 if (svp && SvOK(*svp))
413 info->btree.prefix = btree_prefix ;
414 RETVAL->prefix = newSVsv(*svp) ;
417 info->btree.prefix = NULL ;
419 svp = hv_fetch(action, "flags", 5, FALSE);
420 info->btree.flags = svp ? SvIV(*svp) : 0;
422 svp = hv_fetch(action, "cachesize", 9, FALSE);
423 info->btree.cachesize = svp ? SvIV(*svp) : 0;
425 svp = hv_fetch(action, "minkeypage", 10, FALSE);
426 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
428 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
429 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
431 svp = hv_fetch(action, "psize", 5, FALSE);
432 info->btree.psize = svp ? SvIV(*svp) : 0;
434 svp = hv_fetch(action, "lorder", 6, FALSE);
435 info->btree.lorder = svp ? SvIV(*svp) : 0;
440 else if (sv_isa(sv, "DB_File::RECNOINFO"))
442 RETVAL->type = DB_RECNO ;
443 openinfo = (void *)info ;
445 svp = hv_fetch(action, "flags", 5, FALSE);
446 info->recno.flags = (u_long) svp ? SvIV(*svp) : 0;
448 svp = hv_fetch(action, "cachesize", 9, FALSE);
449 info->recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
451 svp = hv_fetch(action, "psize", 5, FALSE);
452 info->recno.psize = (int) svp ? SvIV(*svp) : 0;
454 svp = hv_fetch(action, "lorder", 6, FALSE);
455 info->recno.lorder = (int) svp ? SvIV(*svp) : 0;
457 svp = hv_fetch(action, "reclen", 6, FALSE);
458 info->recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
460 svp = hv_fetch(action, "bval", 4, FALSE);
461 if (svp && SvOK(*svp))
464 info->recno.bval = (u_char)*SvPV(*svp, na) ;
466 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
470 if (info->recno.flags & R_FIXEDLEN)
471 info->recno.bval = (u_char) ' ' ;
473 info->recno.bval = (u_char) '\n' ;
476 svp = hv_fetch(action, "bfname", 6, FALSE);
478 char * ptr = SvPV(*svp,na) ;
479 info->recno.bfname = (char*) na ? ptr : 0 ;
485 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
489 /* OS2 Specific Code */
496 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
506 croak("DB_File::%s not implemented on this architecture", s);
520 if (strEQ(name, "BTREEMAGIC"))
526 if (strEQ(name, "BTREEVERSION"))
536 if (strEQ(name, "DB_LOCK"))
542 if (strEQ(name, "DB_SHMEM"))
548 if (strEQ(name, "DB_TXN"))
562 if (strEQ(name, "HASHMAGIC"))
568 if (strEQ(name, "HASHVERSION"))
584 if (strEQ(name, "MAX_PAGE_NUMBER"))
585 #ifdef MAX_PAGE_NUMBER
586 return (U32)MAX_PAGE_NUMBER;
590 if (strEQ(name, "MAX_PAGE_OFFSET"))
591 #ifdef MAX_PAGE_OFFSET
592 return MAX_PAGE_OFFSET;
596 if (strEQ(name, "MAX_REC_NUMBER"))
597 #ifdef MAX_REC_NUMBER
598 return (U32)MAX_REC_NUMBER;
612 if (strEQ(name, "RET_ERROR"))
618 if (strEQ(name, "RET_SPECIAL"))
624 if (strEQ(name, "RET_SUCCESS"))
630 if (strEQ(name, "R_CURSOR"))
636 if (strEQ(name, "R_DUP"))
642 if (strEQ(name, "R_FIRST"))
648 if (strEQ(name, "R_FIXEDLEN"))
654 if (strEQ(name, "R_IAFTER"))
660 if (strEQ(name, "R_IBEFORE"))
666 if (strEQ(name, "R_LAST"))
672 if (strEQ(name, "R_NEXT"))
678 if (strEQ(name, "R_NOKEY"))
684 if (strEQ(name, "R_NOOVERWRITE"))
686 return R_NOOVERWRITE;
690 if (strEQ(name, "R_PREV"))
696 if (strEQ(name, "R_RECNOSYNC"))
702 if (strEQ(name, "R_SETCURSOR"))
708 if (strEQ(name, "R_SNAPSHOT"))
732 if (strEQ(name, "__R_UNUSED"))
748 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
757 db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH)
763 char * name = (char *) NULL ;
764 SV * sv = (SV *) NULL ;
766 if (items >= 2 && SvOK(ST(1)))
767 name = (char*) SvPV(ST(1), na) ;
772 RETVAL = ParseOpenInfo(name, flags, mode, sv) ;
773 if (RETVAL->dbp == NULL)
786 SvREFCNT_dec(db->hash) ;
788 SvREFCNT_dec(db->compare) ;
790 SvREFCNT_dec(db->prefix) ;
795 db_DELETE(db, key, flags=0)
812 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
818 db_FETCH(db, key, flags=0)
827 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
828 ST(0) = sv_newmortal();
830 sv_setpvn(ST(0), value.data, value.size);
834 db_STORE(db, key, value, flags=0)
853 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
854 ST(0) = sv_newmortal();
857 if (Db->type != DB_RECNO)
858 sv_setpvn(ST(0), key.data, key.size);
860 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
874 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
875 ST(0) = sv_newmortal();
878 if (Db->type != DB_RECNO)
879 sv_setpvn(ST(0), key.data, key.size);
881 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
886 # These would be nice for RECNO
902 for (i = items-1 ; i > 0 ; --i)
904 value.data = SvPV(ST(i), na) ;
908 key.size = sizeof(int) ;
909 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
927 /* First get the final value */
928 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
929 ST(0) = sv_newmortal();
933 /* the call to del will trash value, so take a copy now */
934 sv_setpvn(ST(0), value.data, value.size);
935 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
937 sv_setsv(ST(0), &sv_undef);
951 /* get the first value */
952 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
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) ;
972 DBTKEY * keyptr = &key ;
978 /* Set the Cursor to the Last element */
979 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
984 for (i = items - 1 ; i > 0 ; --i)
986 value.data = SvPV(ST(i), na) ;
988 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1003 RETVAL = GetArrayLength(db->dbp) ;
1009 # Now provide an interface to the rest of the DB functionality
1013 db_del(db, key, flags=0)
1022 db_get(db, key, value, flags=0)
1033 db_put(db, key, value, flags=0)
1041 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1050 db_sync(db, flags=0)
1058 db_seq(db, key, value, flags)