3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
6 last modified 12th Mar 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
57 #define DB_Prefix_t mDB_Prefix_t
64 #define DB_Hash_t mDB_Hash_t
83 typedef DB_File_type * DB_File ;
89 #define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
90 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
91 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
92 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
94 #define db_close(db) ((db->dbp)->close)(db->dbp)
95 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
96 #define db_fd(db) (db->in_memory \
98 : ((db->dbp)->fd)(db->dbp) )
99 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
100 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
101 #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
102 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
105 #define OutputValue(arg, name) \
106 { if (RETVAL == 0) { \
107 sv_setpvn(arg, name.data, name.size) ; \
111 #define OutputKey(arg, name) \
114 if (db->type != DB_RECNO) { \
115 sv_setpvn(arg, name.data, name.size); \
118 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
122 /* Internal Global Data */
123 static recno_t Value ;
124 static DB_File CurrentDB ;
125 static recno_t zero = 0 ;
126 static DBTKEY empty = { &zero, sizeof(recno_t) } ;
130 btree_compare(key1, key2)
135 void * data1, * data2 ;
142 /* As newSVpv will assume that the data pointer is a null terminated C
143 string if the size parameter is 0, make sure that data points to an
144 empty string if the length is 0
156 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
157 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
160 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
165 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
177 btree_prefix(key1, key2)
182 void * data1, * data2 ;
189 /* As newSVpv will assume that the data pointer is a null terminated C
190 string if the size parameter is 0, make sure that data points to an
191 empty string if the length is 0
203 PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
204 PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
207 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
212 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
235 /* DGH - Next two lines added to fix corrupted stack problem */
241 XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
244 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
249 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
267 printf ("HASH Info\n") ;
268 printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
269 printf (" bsize = %d\n", hash->bsize) ;
270 printf (" ffactor = %d\n", hash->ffactor) ;
271 printf (" nelem = %d\n", hash->nelem) ;
272 printf (" cachesize = %d\n", hash->cachesize) ;
273 printf (" lorder = %d\n", hash->lorder) ;
281 printf ("RECNO Info\n") ;
282 printf (" flags = %d\n", recno->flags) ;
283 printf (" cachesize = %d\n", recno->cachesize) ;
284 printf (" psize = %d\n", recno->psize) ;
285 printf (" lorder = %d\n", recno->lorder) ;
286 printf (" reclen = %d\n", recno->reclen) ;
287 printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
288 printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
295 printf ("BTREE Info\n") ;
296 printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
297 printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
298 printf (" flags = %d\n", btree->flags) ;
299 printf (" cachesize = %d\n", btree->cachesize) ;
300 printf (" psize = %d\n", btree->psize) ;
301 printf (" maxkeypage = %d\n", btree->maxkeypage) ;
302 printf (" minkeypage = %d\n", btree->minkeypage) ;
303 printf (" lorder = %d\n", btree->lorder) ;
308 #define PrintRecno(recno)
309 #define PrintHash(hash)
310 #define PrintBtree(btree)
323 RETVAL = (db->seq)(db, &key, &value, R_LAST) ;
325 RETVAL = *(I32 *)key.data ;
326 else if (RETVAL == 1) /* No key means empty file */
329 return ((I32)RETVAL) ;
333 GetRecnoKey(db, value)
338 /* Get the length of the array */
339 I32 length = GetArrayLength(db->dbp) ;
341 /* check for attempt to write before start of array */
342 if (length + value + 1 <= 0)
343 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
345 value = length + value + 1 ;
354 ParseOpenInfo(name, flags, mode, sv)
362 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
363 void * openinfo = NULL ;
364 union INFO * info = &RETVAL->info ;
366 /* Default to HASH */
367 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
368 RETVAL->type = DB_HASH ;
370 /* DGH - Next line added to avoid SEGV on existing hash DB */
373 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
374 RETVAL->in_memory = (name == NULL) ;
379 croak ("type parameter is not a reference") ;
381 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
382 if (svp && SvOK(*svp))
383 action = (HV*) SvRV(*svp) ;
385 croak("internal error") ;
387 if (sv_isa(sv, "DB_File::HASHINFO"))
389 RETVAL->type = DB_HASH ;
390 openinfo = (void*)info ;
392 svp = hv_fetch(action, "hash", 4, FALSE);
394 if (svp && SvOK(*svp))
396 info->hash.hash = hash_cb ;
397 RETVAL->hash = newSVsv(*svp) ;
400 info->hash.hash = NULL ;
402 svp = hv_fetch(action, "bsize", 5, FALSE);
403 info->hash.bsize = svp ? SvIV(*svp) : 0;
405 svp = hv_fetch(action, "ffactor", 7, FALSE);
406 info->hash.ffactor = svp ? SvIV(*svp) : 0;
408 svp = hv_fetch(action, "nelem", 5, FALSE);
409 info->hash.nelem = svp ? SvIV(*svp) : 0;
411 svp = hv_fetch(action, "cachesize", 9, FALSE);
412 info->hash.cachesize = svp ? SvIV(*svp) : 0;
414 svp = hv_fetch(action, "lorder", 6, FALSE);
415 info->hash.lorder = svp ? SvIV(*svp) : 0;
419 else if (sv_isa(sv, "DB_File::BTREEINFO"))
421 RETVAL->type = DB_BTREE ;
422 openinfo = (void*)info ;
424 svp = hv_fetch(action, "compare", 7, FALSE);
425 if (svp && SvOK(*svp))
427 info->btree.compare = btree_compare ;
428 RETVAL->compare = newSVsv(*svp) ;
431 info->btree.compare = NULL ;
433 svp = hv_fetch(action, "prefix", 6, FALSE);
434 if (svp && SvOK(*svp))
436 info->btree.prefix = btree_prefix ;
437 RETVAL->prefix = newSVsv(*svp) ;
440 info->btree.prefix = NULL ;
442 svp = hv_fetch(action, "flags", 5, FALSE);
443 info->btree.flags = svp ? SvIV(*svp) : 0;
445 svp = hv_fetch(action, "cachesize", 9, FALSE);
446 info->btree.cachesize = svp ? SvIV(*svp) : 0;
448 svp = hv_fetch(action, "minkeypage", 10, FALSE);
449 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
451 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
452 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
454 svp = hv_fetch(action, "psize", 5, FALSE);
455 info->btree.psize = svp ? SvIV(*svp) : 0;
457 svp = hv_fetch(action, "lorder", 6, FALSE);
458 info->btree.lorder = svp ? SvIV(*svp) : 0;
463 else if (sv_isa(sv, "DB_File::RECNOINFO"))
465 RETVAL->type = DB_RECNO ;
466 openinfo = (void *)info ;
468 svp = hv_fetch(action, "flags", 5, FALSE);
469 info->recno.flags = (u_long) svp ? SvIV(*svp) : 0;
471 svp = hv_fetch(action, "cachesize", 9, FALSE);
472 info->recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
474 svp = hv_fetch(action, "psize", 5, FALSE);
475 info->recno.psize = (int) svp ? SvIV(*svp) : 0;
477 svp = hv_fetch(action, "lorder", 6, FALSE);
478 info->recno.lorder = (int) svp ? SvIV(*svp) : 0;
480 svp = hv_fetch(action, "reclen", 6, FALSE);
481 info->recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
483 svp = hv_fetch(action, "bval", 4, FALSE);
484 if (svp && SvOK(*svp))
487 info->recno.bval = (u_char)*SvPV(*svp, na) ;
489 info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
493 if (info->recno.flags & R_FIXEDLEN)
494 info->recno.bval = (u_char) ' ' ;
496 info->recno.bval = (u_char) '\n' ;
499 svp = hv_fetch(action, "bfname", 6, FALSE);
500 if (svp && SvOK(*svp)) {
501 char * ptr = SvPV(*svp,na) ;
502 info->recno.bfname = (char*) na ? ptr : NULL ;
505 info->recno.bfname = NULL ;
510 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
514 /* OS2 Specific Code */
521 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
531 croak("DB_File::%s not implemented on this architecture", s);
545 if (strEQ(name, "BTREEMAGIC"))
551 if (strEQ(name, "BTREEVERSION"))
561 if (strEQ(name, "DB_LOCK"))
567 if (strEQ(name, "DB_SHMEM"))
573 if (strEQ(name, "DB_TXN"))
587 if (strEQ(name, "HASHMAGIC"))
593 if (strEQ(name, "HASHVERSION"))
609 if (strEQ(name, "MAX_PAGE_NUMBER"))
610 #ifdef MAX_PAGE_NUMBER
611 return (U32)MAX_PAGE_NUMBER;
615 if (strEQ(name, "MAX_PAGE_OFFSET"))
616 #ifdef MAX_PAGE_OFFSET
617 return MAX_PAGE_OFFSET;
621 if (strEQ(name, "MAX_REC_NUMBER"))
622 #ifdef MAX_REC_NUMBER
623 return (U32)MAX_REC_NUMBER;
637 if (strEQ(name, "RET_ERROR"))
643 if (strEQ(name, "RET_SPECIAL"))
649 if (strEQ(name, "RET_SUCCESS"))
655 if (strEQ(name, "R_CURSOR"))
661 if (strEQ(name, "R_DUP"))
667 if (strEQ(name, "R_FIRST"))
673 if (strEQ(name, "R_FIXEDLEN"))
679 if (strEQ(name, "R_IAFTER"))
685 if (strEQ(name, "R_IBEFORE"))
691 if (strEQ(name, "R_LAST"))
697 if (strEQ(name, "R_NEXT"))
703 if (strEQ(name, "R_NOKEY"))
709 if (strEQ(name, "R_NOOVERWRITE"))
711 return R_NOOVERWRITE;
715 if (strEQ(name, "R_PREV"))
721 if (strEQ(name, "R_RECNOSYNC"))
727 if (strEQ(name, "R_SETCURSOR"))
733 if (strEQ(name, "R_SNAPSHOT"))
757 if (strEQ(name, "__R_UNUSED"))
773 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
782 db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
788 char * name = (char *) NULL ;
789 SV * sv = (SV *) NULL ;
791 if (items >= 2 && SvOK(ST(1)))
792 name = (char*) SvPV(ST(1), na) ;
797 RETVAL = ParseOpenInfo(name, flags, mode, sv) ;
798 if (RETVAL->dbp == NULL)
811 SvREFCNT_dec(db->hash) ;
813 SvREFCNT_dec(db->compare) ;
815 SvREFCNT_dec(db->prefix) ;
820 db_DELETE(db, key, flags=0)
837 RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
843 db_FETCH(db, key, flags=0)
852 RETVAL = ((db->dbp)->get)(db->dbp, &key, &value, flags) ;
853 ST(0) = sv_newmortal();
855 sv_setpvn(ST(0), value.data, value.size);
859 db_STORE(db, key, value, flags=0)
878 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
879 ST(0) = sv_newmortal();
882 if (Db->type != DB_RECNO)
883 sv_setpvn(ST(0), key.data, key.size);
885 sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
899 RETVAL = (Db->seq)(Db, &key, &value, R_NEXT) ;
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);
911 # These would be nice for RECNO
927 for (i = items-1 ; i > 0 ; --i)
929 value.data = SvPV(ST(i), na) ;
933 key.size = sizeof(int) ;
934 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
952 /* First get the final value */
953 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
954 ST(0) = sv_newmortal();
958 /* the call to del will trash value, so take a copy now */
959 sv_setpvn(ST(0), value.data, value.size);
960 RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
962 sv_setsv(ST(0), &sv_undef);
976 /* get the first value */
977 RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
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) ;
997 DBTKEY * keyptr = &key ;
1003 /* Set the Cursor to the Last element */
1004 RETVAL = (Db->seq)(Db, &key, &value, R_LAST) ;
1009 for (i = items - 1 ; i > 0 ; --i)
1011 value.data = SvPV(ST(i), na) ;
1013 RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
1028 RETVAL = GetArrayLength(db->dbp) ;
1034 # Now provide an interface to the rest of the DB functionality
1038 db_del(db, key, flags=0)
1047 db_get(db, key, value, flags=0)
1058 db_put(db, key, value, flags=0)
1066 key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
1075 db_sync(db, flags=0)
1083 db_seq(db, key, value, flags)