3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
6 last modified 31st May 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 - Minor additions to DB_File.xs to support multithreaded perl.
61 #define DB_Prefix_t mDB_Prefix_t
68 #define DB_Hash_t mDB_Hash_t
87 typedef DB_File_type * DB_File ;
93 #define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
94 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
95 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
96 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
98 #define db_close(db) ((db->dbp)->close)(db->dbp)
99 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
100 #define db_fd(db) (db->in_memory \
102 : ((db->dbp)->fd)(db->dbp) )
103 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
104 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
105 #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
106 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
109 #define OutputValue(arg, name) \
110 { if (RETVAL == 0) { \
111 sv_setpvn(arg, name.data, name.size) ; \
115 #define OutputKey(arg, name) \
118 if (db->type != DB_RECNO) { \
119 sv_setpvn(arg, name.data, name.size); \
122 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
126 /* Internal Global Data */
127 static recno_t Value ;
128 static DB_File CurrentDB ;
129 static recno_t zero = 0 ;
130 static DBTKEY empty = { &zero, sizeof(recno_t) } ;
134 btree_compare(key1, key2)
140 void * data1, * data2 ;
147 /* As newSVpv will assume that the data pointer is a null terminated C
148 string if the size parameter is 0, make sure that data points to an
149 empty string if the length is 0
161 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
162 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
165 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
170 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
182 btree_prefix(key1, key2)
188 void * data1, * data2 ;
195 /* As newSVpv will assume that the data pointer is a null terminated C
196 string if the size parameter is 0, make sure that data points to an
197 empty string if the length is 0
209 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
210 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
213 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
218 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
242 /* DGH - Next two lines added to fix corrupted stack problem */
248 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
251 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
256 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
274 printf ("HASH Info\n") ;
275 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
276 printf (" bsize = %d\n", hash->bsize) ;
277 printf (" ffactor = %d\n", hash->ffactor) ;
278 printf (" nelem = %d\n", hash->nelem) ;
279 printf (" cachesize = %d\n", hash->cachesize) ;
280 printf (" lorder = %d\n", hash->lorder) ;
288 printf ("RECNO Info\n") ;
289 printf (" flags = %d\n", recno->flags) ;
290 printf (" cachesize = %d\n", recno->cachesize) ;
291 printf (" psize = %d\n", recno->psize) ;
292 printf (" lorder = %d\n", recno->lorder) ;
293 printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
294 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
295 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
302 printf ("BTREE Info\n") ;
303 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
304 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
305 printf (" flags = %d\n", btree->flags) ;
306 printf (" cachesize = %d\n", btree->cachesize) ;
307 printf (" psize = %d\n", btree->psize) ;
308 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
309 printf (" minkeypage = %d\n", btree->minkeypage) ;
310 printf (" lorder = %d\n", btree->lorder) ;
315 #define PrintRecno(recno)
316 #define PrintHash(hash)
317 #define PrintBtree(btree)
330 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
332 RETVAL = *(I32 *)key.data ;
333 else if (RETVAL == 1) /* No key means empty file */
336 return ((I32)RETVAL) ;
340 GetRecnoKey(db, value)
345 /* Get the length of the array */
346 I32 length = GetArrayLength(db->dbp) ;
348 /* check for attempt to write before start of array */
349 if (length + value + 1 <= 0)
350 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
352 value = length + value + 1 ;
361 ParseOpenInfo(isHASH, name, flags, mode, sv)
370 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
371 void * openinfo = NULL ;
372 union INFO * info = &RETVAL->info ;
374 /* Default to HASH */
375 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
376 RETVAL->type = DB_HASH ;
378 /* DGH - Next line added to avoid SEGV on existing hash DB */
381 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
382 RETVAL->in_memory = (name == NULL) ;
387 croak ("type parameter is not a reference") ;
389 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
390 if (svp && SvOK(*svp))
391 action = (HV*) SvRV(*svp) ;
393 croak("internal error") ;
395 if (sv_isa(sv, "DB_File::HASHINFO"))
399 croak("DB_File can only tie an associative array to a DB_HASH database") ;
401 RETVAL->type = DB_HASH ;
402 openinfo = (void*)info ;
404 svp = hv_fetch(action, "hash", 4, FALSE);
406 if (svp && SvOK(*svp))
408 info->hash.hash = hash_cb ;
409 RETVAL->hash = newSVsv(*svp) ;
412 info->hash.hash = NULL ;
414 svp = hv_fetch(action, "bsize", 5, FALSE);
415 info->hash.bsize = svp ? SvIV(*svp) : 0;
417 svp = hv_fetch(action, "ffactor", 7, FALSE);
418 info->hash.ffactor = svp ? SvIV(*svp) : 0;
420 svp = hv_fetch(action, "nelem", 5, FALSE);
421 info->hash.nelem = svp ? SvIV(*svp) : 0;
423 svp = hv_fetch(action, "cachesize", 9, FALSE);
424 info->hash.cachesize = svp ? SvIV(*svp) : 0;
426 svp = hv_fetch(action, "lorder", 6, FALSE);
427 info->hash.lorder = svp ? SvIV(*svp) : 0;
431 else if (sv_isa(sv, "DB_File::BTREEINFO"))
434 croak("DB_File can only tie an associative array to a DB_BTREE database");
436 RETVAL->type = DB_BTREE ;
437 openinfo = (void*)info ;
439 svp = hv_fetch(action, "compare", 7, FALSE);
440 if (svp && SvOK(*svp))
442 info->btree.compare = btree_compare ;
443 RETVAL->compare = newSVsv(*svp) ;
446 info->btree.compare = NULL ;
448 svp = hv_fetch(action, "prefix", 6, FALSE);
449 if (svp && SvOK(*svp))
451 info->btree.prefix = btree_prefix ;
452 RETVAL->prefix = newSVsv(*svp) ;
455 info->btree.prefix = NULL ;
457 svp = hv_fetch(action, "flags", 5, FALSE);
458 info->btree.flags = svp ? SvIV(*svp) : 0;
460 svp = hv_fetch(action, "cachesize", 9, FALSE);
461 info->btree.cachesize = svp ? SvIV(*svp) : 0;
463 svp = hv_fetch(action, "minkeypage", 10, FALSE);
464 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
466 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
467 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
469 svp = hv_fetch(action, "psize", 5, FALSE);
470 info->btree.psize = svp ? SvIV(*svp) : 0;
472 svp = hv_fetch(action, "lorder", 6, FALSE);
473 info->btree.lorder = svp ? SvIV(*svp) : 0;
478 else if (sv_isa(sv, "DB_File::RECNOINFO"))
481 croak("DB_File can only tie an array to a DB_RECNO database");
483 RETVAL->type = DB_RECNO ;
484 openinfo = (void *)info ;
486 svp = hv_fetch(action, "flags", 5, FALSE);
487 info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
489 svp = hv_fetch(action, "cachesize", 9, FALSE);
490 info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
492 svp = hv_fetch(action, "psize", 5, FALSE);
493 info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
495 svp = hv_fetch(action, "lorder", 6, FALSE);
496 info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
498 svp = hv_fetch(action, "reclen", 6, FALSE);
499 info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
501 svp = hv_fetch(action, "bval", 4, FALSE);
502 if (svp && SvOK(*svp))
505 info->recno.bval = (u_char)*SvPV(*svp, na) ;
507 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
511 if (info->recno.flags & R_FIXEDLEN)
512 info->recno.bval = (u_char) ' ' ;
514 info->recno.bval = (u_char) '\n' ;
517 svp = hv_fetch(action, "bfname", 6, FALSE);
518 if (svp && SvOK(*svp)) {
519 char * ptr = SvPV(*svp,na) ;
520 info->recno.bfname = (char*) (na ? ptr : NULL) ;
523 info->recno.bfname = NULL ;
528 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
532 /* OS2 Specific Code */
539 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
549 croak("DB_File::%s not implemented on this architecture", s);
563 if (strEQ(name, "BTREEMAGIC"))
569 if (strEQ(name, "BTREEVERSION"))
579 if (strEQ(name, "DB_LOCK"))
585 if (strEQ(name, "DB_SHMEM"))
591 if (strEQ(name, "DB_TXN"))
605 if (strEQ(name, "HASHMAGIC"))
611 if (strEQ(name, "HASHVERSION"))
627 if (strEQ(name, "MAX_PAGE_NUMBER"))
628 #ifdef MAX_PAGE_NUMBER
629 return (U32)MAX_PAGE_NUMBER;
633 if (strEQ(name, "MAX_PAGE_OFFSET"))
634 #ifdef MAX_PAGE_OFFSET
635 return MAX_PAGE_OFFSET;
639 if (strEQ(name, "MAX_REC_NUMBER"))
640 #ifdef MAX_REC_NUMBER
641 return (U32)MAX_REC_NUMBER;
655 if (strEQ(name, "RET_ERROR"))
661 if (strEQ(name, "RET_SPECIAL"))
667 if (strEQ(name, "RET_SUCCESS"))
673 if (strEQ(name, "R_CURSOR"))
679 if (strEQ(name, "R_DUP"))
685 if (strEQ(name, "R_FIRST"))
691 if (strEQ(name, "R_FIXEDLEN"))
697 if (strEQ(name, "R_IAFTER"))
703 if (strEQ(name, "R_IBEFORE"))
709 if (strEQ(name, "R_LAST"))
715 if (strEQ(name, "R_NEXT"))
721 if (strEQ(name, "R_NOKEY"))
727 if (strEQ(name, "R_NOOVERWRITE"))
729 return R_NOOVERWRITE;
733 if (strEQ(name, "R_PREV"))
739 if (strEQ(name, "R_RECNOSYNC"))
745 if (strEQ(name, "R_SETCURSOR"))
751 if (strEQ(name, "R_SNAPSHOT"))
775 if (strEQ(name, "__R_UNUSED"))
791 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
800 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
807 char * name = (char *) NULL ;
808 SV * sv = (SV *) NULL ;
810 if (items >= 3 && SvOK(ST(2)))
811 name = (char*) SvPV(ST(2), na) ;
816 RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
817 if (RETVAL->dbp == NULL)
830 SvREFCNT_dec(db->hash) ;
832 SvREFCNT_dec(db->compare) ;
834 SvREFCNT_dec(db->prefix) ;
839 db_DELETE(db, key, flags=0)
856 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
862 db_FETCH(db, key, flags=0)
871 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
872 ST(0) = sv_newmortal();
874 sv_setpvn(ST(0), value.data, value.size);
878 db_STORE(db, key, value, flags=0)
897 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
898 ST(0) = sv_newmortal();
901 if (db->type != DB_RECNO)
902 sv_setpvn(ST(0), key.data, key.size);
904 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
918 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
919 ST(0) = sv_newmortal();
922 if (db->type != DB_RECNO)
923 sv_setpvn(ST(0), key.data, key.size);
925 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
930 # These would be nice for RECNO
946 for (i = items-1 ; i > 0 ; --i)
948 value.data = SvPV(ST(i), na) ;
952 key.size = sizeof(int) ;
953 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
971 /* First get the final value */
972 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
973 ST(0) = sv_newmortal();
977 /* the call to del will trash value, so take a copy now */
978 sv_setpvn(ST(0), value.data, value.size);
979 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
981 sv_setsv(ST(0), &sv_undef);
995 /* get the first value */
996 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
997 ST(0) = sv_newmortal();
1001 /* the call to del will trash value, so take a copy now */
1002 sv_setpvn(ST(0), value.data, value.size);
1003 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
1005 sv_setsv (ST(0), &sv_undef) ;
1016 DBTKEY * keyptr = &key ;
1022 /* Set the Cursor to the Last element */
1023 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1028 for (i = items - 1 ; i > 0 ; --i)
1030 value.data = SvPV(ST(i), na) ;
1032 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1047 RETVAL = GetArrayLength(db->dbp) ;
1053 # Now provide an interface to the rest of the DB functionality
1057 db_del(db, key, flags=0)
1066 db_get(db, key, value, flags=0)
1077 db_put(db, key, value, flags=0)
1085 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1094 db_sync(db, flags=0)
1102 db_seq(db, key, value, flags)