3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess <Paul.Marquess@btinternet.com>
6 last modified 22nd October 2002
9 All comments/suggestions/problems are welcome
11 Copyright (c) 1995-2002 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.50 - Make work with both DB 1.x or DB 2.x
46 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
47 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
48 undefined value" warning with db_get and db_seq.
49 1.53 - Added DB_RENUMBER to flags for recno.
50 1.54 - Fixed bug in the fd method
51 1.55 - Fix for AIX from Jarkko Hietaniemi
52 1.56 - No change to DB_File.xs
53 1.57 - added the #undef op to allow building with Threads support.
54 1.58 - Fixed a problem with the use of sv_setpvn. When the
55 size is specified as 0, it does a strlen on the data.
56 This was ok for DB 1.x, but isn't for DB 2.x.
57 1.59 - No change to DB_File.xs
58 1.60 - Some code tidy up
59 1.61 - added flagSet macro for DB 2.5.x
60 fixed typo in O_RDONLY test.
61 1.62 - No change to DB_File.xs
62 1.63 - Fix to alllow DB 2.6.x to build.
63 1.64 - Tidied up the 1.x to 2.x flags mapping code.
64 Added a patch from Mark Kettenis <kettenis@wins.uva.nl>
65 to fix a flag mapping problem with O_RDONLY on the Hurd
66 1.65 - Fixed a bug in the PUSH logic.
67 Added BOOT check that using 2.3.4 or greater
68 1.66 - Added DBM filter code
69 1.67 - Backed off the use of newSVpvn.
70 Fixed DBM Filter code for Perl 5.004.
71 Fixed a small memory leak in the filter code.
72 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE
73 merged in the 5.005_58 changes
74 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly.
75 Fixed the R_SETCURSOR bug introduced in 1.68
76 Added a new Perl variable $DB_File::db_ver
77 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with
78 GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons.
79 Added a BOOT check to test for equivalent versions of db.h &
81 1.71 - Support for Berkeley DB version 3.
82 Support for Berkeley DB 2/3's backward compatability mode.
84 1.72 - No change to DB_File.xs
85 1.73 - No change to DB_File.xs
86 1.74 - A call to open needed parenthesised to stop it clashing
88 Added Perl core patches 7703 & 7801.
89 1.75 - Fixed Perl core patch 7703.
90 Added suppport to allow DB_File to be built with
91 Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb
93 1.76 - No change to DB_File.xs
94 1.77 - Tidied up a few types used in calling newSVpvn.
95 1.78 - Core patch 10335, 10372, 10534, 10549, 11051 included.
96 1.79 - NEXTKEY ignores the input key.
98 1.800 - Moved backward compatability code into ppport.h.
99 Use the new constants code.
100 1.801 - No change to DB_File.xs
101 1.802 - No change to DB_File.xs
102 1.803 - FETCH, STORE & DELETE don't map the flags parameter
103 into the equivalent Berkeley DB function anymore.
105 1.805 - recursion detection added to the callbacks
106 Support for 4.1.X added.
107 Filter code can now cope with read-only $_
108 1.806 - recursion detection beefed up.
112 #define PERL_NO_GET_CONTEXT
121 /* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
122 DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
124 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
125 * shortly #included by the <db.h>) __attribute__ to the possibly
126 * already defined __attribute__, for example by GNUC or by Perl. */
128 /* #if DB_VERSION_MAJOR_CFG < 2 */
129 #ifndef DB_VERSION_MAJOR
130 # undef __attribute__
139 /* Wall starts with 5.7.x */
141 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
143 /* Since we dropped the gccish definition of __attribute__ we will want
144 * to redefine dNOOP, however (so that dTHX continues to work). Yes,
145 * all this means that we can't do attribute checking on the DB_File,
147 # ifndef DB_VERSION_MAJOR
150 # define dNOOP extern int Perl___notused
152 /* Ditto for dXSARGS. */
156 I32 ax = mark - PL_stack_base + 1; \
157 I32 items = sp - mark
161 /* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
163 # define dXSI32 dNOOP
165 #endif /* Perl >= 5.7 */
172 # define Trace(x) printf x
178 #define DBT_clear(x) Zero(&x, 1, DBT) ;
180 #ifdef DB_VERSION_MAJOR
182 #if DB_VERSION_MAJOR == 2
183 # define BERKELEY_DB_1_OR_2
186 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
187 # define AT_LEAST_DB_3_2
190 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
191 # define AT_LEAST_DB_4_1
194 /* map version 2 features & constants onto their version 1 equivalent */
199 #define DB_Prefix_t size_t
204 #define DB_Hash_t u_int32_t
206 /* DBTYPE stays the same */
207 /* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
208 #if DB_VERSION_MAJOR == 2
209 typedef DB_INFO INFO ;
210 #else /* DB_VERSION_MAJOR > 2 */
211 # define DB_FIXEDLEN (0x8000)
212 #endif /* DB_VERSION_MAJOR == 2 */
214 /* version 2 has db_recno_t in place of recno_t */
215 typedef db_recno_t recno_t;
218 #define R_CURSOR DB_SET_RANGE
219 #define R_FIRST DB_FIRST
220 #define R_IAFTER DB_AFTER
221 #define R_IBEFORE DB_BEFORE
222 #define R_LAST DB_LAST
223 #define R_NEXT DB_NEXT
224 #define R_NOOVERWRITE DB_NOOVERWRITE
225 #define R_PREV DB_PREV
227 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
228 # define R_SETCURSOR 0x800000
230 # define R_SETCURSOR (-100)
233 #define R_RECNOSYNC 0
234 #define R_FIXEDLEN DB_FIXEDLEN
238 #define db_HA_hash h_hash
239 #define db_HA_ffactor h_ffactor
240 #define db_HA_nelem h_nelem
241 #define db_HA_bsize db_pagesize
242 #define db_HA_cachesize db_cachesize
243 #define db_HA_lorder db_lorder
245 #define db_BT_compare bt_compare
246 #define db_BT_prefix bt_prefix
247 #define db_BT_flags flags
248 #define db_BT_psize db_pagesize
249 #define db_BT_cachesize db_cachesize
250 #define db_BT_lorder db_lorder
251 #define db_BT_maxkeypage
252 #define db_BT_minkeypage
255 #define db_RE_reclen re_len
256 #define db_RE_flags flags
257 #define db_RE_bval re_pad
258 #define db_RE_bfname re_source
259 #define db_RE_psize db_pagesize
260 #define db_RE_cachesize db_cachesize
261 #define db_RE_lorder db_lorder
265 #define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
268 #define DBT_flags(x) x.flags = 0
269 #define DB_flags(x, v) x |= v
271 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
272 # define flagSet(flags, bitmask) ((flags) & (bitmask))
274 # define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask))
277 #else /* db version 1.x */
279 #define BERKELEY_DB_1
280 #define BERKELEY_DB_1_OR_2
293 # define DB_Prefix_t mDB_Prefix_t
300 # define DB_Hash_t mDB_Hash_t
303 #define db_HA_hash hash.hash
304 #define db_HA_ffactor hash.ffactor
305 #define db_HA_nelem hash.nelem
306 #define db_HA_bsize hash.bsize
307 #define db_HA_cachesize hash.cachesize
308 #define db_HA_lorder hash.lorder
310 #define db_BT_compare btree.compare
311 #define db_BT_prefix btree.prefix
312 #define db_BT_flags btree.flags
313 #define db_BT_psize btree.psize
314 #define db_BT_cachesize btree.cachesize
315 #define db_BT_lorder btree.lorder
316 #define db_BT_maxkeypage btree.maxkeypage
317 #define db_BT_minkeypage btree.minkeypage
319 #define db_RE_reclen recno.reclen
320 #define db_RE_flags recno.flags
321 #define db_RE_bval recno.bval
322 #define db_RE_bfname recno.bfname
323 #define db_RE_psize recno.psize
324 #define db_RE_cachesize recno.cachesize
325 #define db_RE_lorder recno.lorder
329 #define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
331 #define DB_flags(x, v)
332 #define flagSet(flags, bitmask) ((flags) & (bitmask))
334 #endif /* db version 1 */
338 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0)
339 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
340 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
342 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
343 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
345 #ifdef DB_VERSION_MAJOR
346 #define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\
347 (db->dbp->close)(db->dbp, 0) ))
348 #define db_close(db) ((db->dbp)->close)(db->dbp, 0)
349 #define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
350 ? ((db->cursor)->c_del)(db->cursor, 0) \
351 : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
353 #else /* ! DB_VERSION_MAJOR */
355 #define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp))
356 #define db_close(db) ((db->dbp)->close)(db->dbp)
357 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
358 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
360 #endif /* ! DB_VERSION_MAJOR */
363 #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
376 #ifdef BERKELEY_DB_1_OR_2
379 #ifdef DB_VERSION_MAJOR
382 SV * filter_fetch_key ;
383 SV * filter_store_key ;
384 SV * filter_fetch_value ;
385 SV * filter_store_value ;
390 typedef DB_File_type * DB_File ;
393 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
395 #define OutputValue(arg, name) \
396 { if (RETVAL == 0) { \
397 my_sv_setpvn(arg, name.data, name.size) ; \
400 DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
404 #define OutputKey(arg, name) \
407 if (db->type != DB_RECNO) { \
408 my_sv_setpvn(arg, name.data, name.size); \
411 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
414 DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
418 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
421 extern void __getBerkeleyDBInfo(void);
424 /* Internal Global Data */
426 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION
437 #define Value (MY_CXT.x_Value)
438 #define zero (MY_CXT.x_zero)
439 #define CurrentDB (MY_CXT.x_CurrentDB)
440 #define empty (MY_CXT.x_empty)
442 #define ERR_BUFF "DB_File::Error"
444 #ifdef DB_VERSION_MAJOR
448 db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
450 db_put(db, key, value, flags)
459 if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
463 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
464 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
466 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
470 memset(&l_key, 0, sizeof(l_key));
471 l_key.data = key.data;
472 l_key.size = key.size;
473 memset(&l_value, 0, sizeof(l_value));
474 l_value.data = value.data;
475 l_value.size = value.size;
477 if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
478 (void)temp_cursor->c_close(temp_cursor);
482 status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
483 (void)temp_cursor->c_close(temp_cursor);
489 if (flagSet(flags, R_CURSOR)) {
490 return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
493 if (flagSet(flags, R_SETCURSOR)) {
494 if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
496 return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
500 return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
504 #endif /* DB_VERSION_MAJOR */
514 #ifdef AT_LEAST_DB_3_2
517 btree_compare(DB * db, const DBT *key1, const DBT *key2)
519 btree_compare(db, key1, key2)
523 #endif /* CAN_PROTOTYPE */
525 #else /* Berkeley DB < 3.2 */
528 btree_compare(const DBT *key1, const DBT *key2)
530 btree_compare(key1, key2)
543 void * data1, * data2 ;
548 if (CurrentDB->in_compare) {
550 croak ("DB_File btree_compare: recursion detected\n") ;
553 data1 = (char *) key1->data ;
554 data2 = (char *) key2->data ;
557 /* As newSVpv will assume that the data pointer is a null terminated C
558 string if the size parameter is 0, make sure that data points to an
559 empty string if the length is 0
570 CurrentDB->in_compare = FALSE;
571 SAVEINT(CurrentDB->in_compare);
572 CurrentDB->in_compare = TRUE;
576 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
577 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
580 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
586 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
600 #ifdef AT_LEAST_DB_3_2
603 btree_prefix(DB * db, const DBT *key1, const DBT *key2)
605 btree_prefix(db, key1, key2)
611 #else /* Berkeley DB < 3.2 */
614 btree_prefix(const DBT *key1, const DBT *key2)
616 btree_prefix(key1, key2)
628 char * data1, * data2 ;
632 if (CurrentDB->in_prefix){
634 croak ("DB_File btree_prefix: recursion detected\n") ;
637 data1 = (char *) key1->data ;
638 data2 = (char *) key2->data ;
641 /* As newSVpv will assume that the data pointer is a null terminated C
642 string if the size parameter is 0, make sure that data points to an
643 empty string if the length is 0
654 CurrentDB->in_prefix = FALSE;
655 SAVEINT(CurrentDB->in_prefix);
656 CurrentDB->in_prefix = TRUE;
660 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
661 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
664 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
670 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
684 # define HASH_CB_SIZE_TYPE size_t
686 # define HASH_CB_SIZE_TYPE u_int32_t
690 #ifdef AT_LEAST_DB_3_2
693 hash_cb(DB * db, const void *data, u_int32_t size)
695 hash_cb(db, data, size)
698 HASH_CB_SIZE_TYPE size ;
701 #else /* Berkeley DB < 3.2 */
704 hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
708 HASH_CB_SIZE_TYPE size ;
721 if (CurrentDB->in_hash){
723 croak ("DB_File hash callback: recursion detected\n") ;
731 /* DGH - Next two lines added to fix corrupted stack problem */
735 CurrentDB->in_hash = FALSE;
736 SAVEINT(CurrentDB->in_hash);
737 CurrentDB->in_hash = TRUE;
742 XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
745 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
751 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
766 db_errcall_cb(const char * db_errpfx, char * buffer)
768 db_errcall_cb(db_errpfx, buffer)
769 const char * db_errpfx;
776 SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
779 sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
781 sv_setpv(sv, buffer) ;
786 #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
790 PrintHash(INFO *hash)
796 printf ("HASH Info\n") ;
797 printf (" hash = %s\n",
798 (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
799 printf (" bsize = %d\n", hash->db_HA_bsize) ;
800 printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
801 printf (" nelem = %d\n", hash->db_HA_nelem) ;
802 printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
803 printf (" lorder = %d\n", hash->db_HA_lorder) ;
809 PrintRecno(INFO *recno)
815 printf ("RECNO Info\n") ;
816 printf (" flags = %d\n", recno->db_RE_flags) ;
817 printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
818 printf (" psize = %d\n", recno->db_RE_psize) ;
819 printf (" lorder = %d\n", recno->db_RE_lorder) ;
820 printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ;
821 printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
822 printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
827 PrintBtree(INFO *btree)
833 printf ("BTREE Info\n") ;
834 printf (" compare = %s\n",
835 (btree->db_BT_compare ? "redefined" : "default")) ;
836 printf (" prefix = %s\n",
837 (btree->db_BT_prefix ? "redefined" : "default")) ;
838 printf (" flags = %d\n", btree->db_BT_flags) ;
839 printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
840 printf (" psize = %d\n", btree->db_BT_psize) ;
841 #ifndef DB_VERSION_MAJOR
842 printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
843 printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
845 printf (" lorder = %d\n", btree->db_BT_lorder) ;
850 #define PrintRecno(recno)
851 #define PrintHash(hash)
852 #define PrintBtree(btree)
859 GetArrayLength(pTHX_ DB_File db)
871 RETVAL = do_SEQ(db, key, value, R_LAST) ;
873 RETVAL = *(I32 *)key.data ;
874 else /* No key means empty file */
877 return ((I32)RETVAL) ;
882 GetRecnoKey(pTHX_ DB_File db, I32 value)
884 GetRecnoKey(db, value)
890 /* Get the length of the array */
891 I32 length = GetArrayLength(aTHX_ db) ;
893 /* check for attempt to write before start of array */
894 if (length + value + 1 <= 0) {
896 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
899 value = length + value + 1 ;
910 ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
912 ParseOpenInfo(isHASH, name, flags, mode, sv)
921 #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */
925 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
926 void * openinfo = NULL ;
927 INFO * info = &RETVAL->info ;
931 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
932 Zero(RETVAL, 1, DB_File_type) ;
934 /* Default to HASH */
935 RETVAL->filtering = 0 ;
936 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
937 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
938 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
939 RETVAL->type = DB_HASH ;
941 /* DGH - Next line added to avoid SEGV on existing hash DB */
944 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
945 RETVAL->in_memory = (name == NULL) ;
950 croak ("type parameter is not a reference") ;
952 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
953 if (svp && SvOK(*svp))
954 action = (HV*) SvRV(*svp) ;
956 croak("internal error") ;
958 if (sv_isa(sv, "DB_File::HASHINFO"))
962 croak("DB_File can only tie an associative array to a DB_HASH database") ;
964 RETVAL->type = DB_HASH ;
965 openinfo = (void*)info ;
967 svp = hv_fetch(action, "hash", 4, FALSE);
969 if (svp && SvOK(*svp))
971 info->db_HA_hash = hash_cb ;
972 RETVAL->hash = newSVsv(*svp) ;
975 info->db_HA_hash = NULL ;
977 svp = hv_fetch(action, "ffactor", 7, FALSE);
978 info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
980 svp = hv_fetch(action, "nelem", 5, FALSE);
981 info->db_HA_nelem = svp ? SvIV(*svp) : 0;
983 svp = hv_fetch(action, "bsize", 5, FALSE);
984 info->db_HA_bsize = svp ? SvIV(*svp) : 0;
986 svp = hv_fetch(action, "cachesize", 9, FALSE);
987 info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
989 svp = hv_fetch(action, "lorder", 6, FALSE);
990 info->db_HA_lorder = svp ? SvIV(*svp) : 0;
994 else if (sv_isa(sv, "DB_File::BTREEINFO"))
997 croak("DB_File can only tie an associative array to a DB_BTREE database");
999 RETVAL->type = DB_BTREE ;
1000 openinfo = (void*)info ;
1002 svp = hv_fetch(action, "compare", 7, FALSE);
1003 if (svp && SvOK(*svp))
1005 info->db_BT_compare = btree_compare ;
1006 RETVAL->compare = newSVsv(*svp) ;
1009 info->db_BT_compare = NULL ;
1011 svp = hv_fetch(action, "prefix", 6, FALSE);
1012 if (svp && SvOK(*svp))
1014 info->db_BT_prefix = btree_prefix ;
1015 RETVAL->prefix = newSVsv(*svp) ;
1018 info->db_BT_prefix = NULL ;
1020 svp = hv_fetch(action, "flags", 5, FALSE);
1021 info->db_BT_flags = svp ? SvIV(*svp) : 0;
1023 svp = hv_fetch(action, "cachesize", 9, FALSE);
1024 info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
1026 #ifndef DB_VERSION_MAJOR
1027 svp = hv_fetch(action, "minkeypage", 10, FALSE);
1028 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
1030 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
1031 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
1034 svp = hv_fetch(action, "psize", 5, FALSE);
1035 info->db_BT_psize = svp ? SvIV(*svp) : 0;
1037 svp = hv_fetch(action, "lorder", 6, FALSE);
1038 info->db_BT_lorder = svp ? SvIV(*svp) : 0;
1043 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1046 croak("DB_File can only tie an array to a DB_RECNO database");
1048 RETVAL->type = DB_RECNO ;
1049 openinfo = (void *)info ;
1051 info->db_RE_flags = 0 ;
1053 svp = hv_fetch(action, "flags", 5, FALSE);
1054 info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
1056 svp = hv_fetch(action, "reclen", 6, FALSE);
1057 info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
1059 svp = hv_fetch(action, "cachesize", 9, FALSE);
1060 info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
1062 svp = hv_fetch(action, "psize", 5, FALSE);
1063 info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
1065 svp = hv_fetch(action, "lorder", 6, FALSE);
1066 info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
1068 #ifdef DB_VERSION_MAJOR
1069 info->re_source = name ;
1072 svp = hv_fetch(action, "bfname", 6, FALSE);
1073 if (svp && SvOK(*svp)) {
1074 char * ptr = SvPV(*svp,n_a) ;
1075 #ifdef DB_VERSION_MAJOR
1076 name = (char*) n_a ? ptr : NULL ;
1078 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
1082 #ifdef DB_VERSION_MAJOR
1085 info->db_RE_bfname = NULL ;
1088 svp = hv_fetch(action, "bval", 4, FALSE);
1089 #ifdef DB_VERSION_MAJOR
1090 if (svp && SvOK(*svp))
1094 value = (int)*SvPV(*svp, n_a) ;
1096 value = SvIV(*svp) ;
1098 if (info->flags & DB_FIXEDLEN) {
1099 info->re_pad = value ;
1100 info->flags |= DB_PAD ;
1103 info->re_delim = value ;
1104 info->flags |= DB_DELIMITER ;
1109 if (svp && SvOK(*svp))
1112 info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
1114 info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
1115 DB_flags(info->flags, DB_DELIMITER) ;
1120 if (info->db_RE_flags & R_FIXEDLEN)
1121 info->db_RE_bval = (u_char) ' ' ;
1123 info->db_RE_bval = (u_char) '\n' ;
1124 DB_flags(info->flags, DB_DELIMITER) ;
1129 info->flags |= DB_RENUMBER ;
1135 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1139 /* OS2 Specific Code */
1143 #endif /* __EMX__ */
1146 #ifdef DB_VERSION_MAJOR
1152 /* Map 1.x flags to 2.x flags */
1153 if ((flags & O_CREAT) == O_CREAT)
1154 Flags |= DB_CREATE ;
1157 if (flags == O_RDONLY)
1159 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1161 Flags |= DB_RDONLY ;
1164 if ((flags & O_TRUNC) == O_TRUNC)
1165 Flags |= DB_TRUNCATE ;
1168 status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
1170 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
1171 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
1173 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1178 RETVAL->dbp = NULL ;
1183 #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
1184 RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ;
1186 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
1187 #endif /* DB_LIBRARY_COMPATIBILITY_API */
1193 #else /* Berkeley DB Version > 2 */
1197 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
1203 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
1204 Zero(RETVAL, 1, DB_File_type) ;
1206 /* Default to HASH */
1207 RETVAL->filtering = 0 ;
1208 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
1209 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
1210 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
1211 RETVAL->type = DB_HASH ;
1213 /* DGH - Next line added to avoid SEGV on existing hash DB */
1216 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
1217 RETVAL->in_memory = (name == NULL) ;
1219 status = db_create(&RETVAL->dbp, NULL,0) ;
1220 /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
1222 RETVAL->dbp = NULL ;
1230 croak ("type parameter is not a reference") ;
1232 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
1233 if (svp && SvOK(*svp))
1234 action = (HV*) SvRV(*svp) ;
1236 croak("internal error") ;
1238 if (sv_isa(sv, "DB_File::HASHINFO"))
1242 croak("DB_File can only tie an associative array to a DB_HASH database") ;
1244 RETVAL->type = DB_HASH ;
1246 svp = hv_fetch(action, "hash", 4, FALSE);
1248 if (svp && SvOK(*svp))
1250 (void)dbp->set_h_hash(dbp, hash_cb) ;
1251 RETVAL->hash = newSVsv(*svp) ;
1254 svp = hv_fetch(action, "ffactor", 7, FALSE);
1256 (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ;
1258 svp = hv_fetch(action, "nelem", 5, FALSE);
1260 (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
1262 svp = hv_fetch(action, "bsize", 5, FALSE);
1264 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
1266 svp = hv_fetch(action, "cachesize", 9, FALSE);
1268 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1270 svp = hv_fetch(action, "lorder", 6, FALSE);
1272 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1276 else if (sv_isa(sv, "DB_File::BTREEINFO"))
1279 croak("DB_File can only tie an associative array to a DB_BTREE database");
1281 RETVAL->type = DB_BTREE ;
1283 svp = hv_fetch(action, "compare", 7, FALSE);
1284 if (svp && SvOK(*svp))
1286 (void)dbp->set_bt_compare(dbp, btree_compare) ;
1287 RETVAL->compare = newSVsv(*svp) ;
1290 svp = hv_fetch(action, "prefix", 6, FALSE);
1291 if (svp && SvOK(*svp))
1293 (void)dbp->set_bt_prefix(dbp, btree_prefix) ;
1294 RETVAL->prefix = newSVsv(*svp) ;
1297 svp = hv_fetch(action, "flags", 5, FALSE);
1299 (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ;
1301 svp = hv_fetch(action, "cachesize", 9, FALSE);
1303 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1305 svp = hv_fetch(action, "psize", 5, FALSE);
1307 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1309 svp = hv_fetch(action, "lorder", 6, FALSE);
1311 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1316 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1321 croak("DB_File can only tie an array to a DB_RECNO database");
1323 RETVAL->type = DB_RECNO ;
1325 svp = hv_fetch(action, "flags", 5, FALSE);
1327 int flags = SvIV(*svp) ;
1328 /* remove FIXDLEN, if present */
1329 if (flags & DB_FIXEDLEN) {
1331 flags &= ~DB_FIXEDLEN ;
1335 svp = hv_fetch(action, "cachesize", 9, FALSE);
1337 status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1340 svp = hv_fetch(action, "psize", 5, FALSE);
1342 status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1345 svp = hv_fetch(action, "lorder", 6, FALSE);
1347 status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1350 svp = hv_fetch(action, "bval", 4, FALSE);
1351 if (svp && SvOK(*svp))
1355 value = (int)*SvPV(*svp, n_a) ;
1357 value = (int)SvIV(*svp) ;
1360 status = dbp->set_re_pad(dbp, value) ;
1363 status = dbp->set_re_delim(dbp, value) ;
1369 svp = hv_fetch(action, "reclen", 6, FALSE);
1371 u_int32_t len = my_SvUV32(*svp) ;
1372 status = dbp->set_re_len(dbp, len) ;
1377 status = dbp->set_re_source(dbp, name) ;
1381 svp = hv_fetch(action, "bfname", 6, FALSE);
1382 if (svp && SvOK(*svp)) {
1383 char * ptr = SvPV(*svp,n_a) ;
1384 name = (char*) n_a ? ptr : NULL ;
1390 status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
1393 (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
1398 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1402 u_int32_t Flags = 0 ;
1405 /* Map 1.x flags to 3.x flags */
1406 if ((flags & O_CREAT) == O_CREAT)
1407 Flags |= DB_CREATE ;
1410 if (flags == O_RDONLY)
1412 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1414 Flags |= DB_RDONLY ;
1417 if ((flags & O_TRUNC) == O_TRUNC)
1418 Flags |= DB_TRUNCATE ;
1421 #ifdef AT_LEAST_DB_4_1
1422 status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type,
1425 status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type,
1428 /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
1431 /* RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;*/
1433 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1435 /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
1439 RETVAL->dbp = NULL ;
1445 #endif /* Berkeley DB Version > 2 */
1447 } /* ParseOpenInfo */
1450 #include "constants.h"
1452 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
1454 INCLUDE: constants.xs
1461 /* SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; */
1463 __getBerkeleyDBInfo() ;
1466 empty.data = &zero ;
1467 empty.size = sizeof(recno_t) ;
1473 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1480 char * name = (char *) NULL ;
1481 SV * sv = (SV *) NULL ;
1484 if (items >= 3 && SvOK(ST(2)))
1485 name = (char*) SvPV(ST(2), n_a) ;
1490 RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1491 if (RETVAL->dbp == NULL)
1504 Trace(("DESTROY %p\n", db));
1506 Trace(("DESTROY %p done\n", db));
1508 SvREFCNT_dec(db->hash) ;
1510 SvREFCNT_dec(db->compare) ;
1512 SvREFCNT_dec(db->prefix) ;
1513 if (db->filter_fetch_key)
1514 SvREFCNT_dec(db->filter_fetch_key) ;
1515 if (db->filter_store_key)
1516 SvREFCNT_dec(db->filter_store_key) ;
1517 if (db->filter_fetch_value)
1518 SvREFCNT_dec(db->filter_fetch_value) ;
1519 if (db->filter_store_value)
1520 SvREFCNT_dec(db->filter_store_value) ;
1522 #ifdef DB_VERSION_MAJOR
1529 db_DELETE(db, key, flags=0)
1551 RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1557 db_FETCH(db, key, flags=0)
1570 RETVAL = db_get(db, key, value, flags) ;
1571 ST(0) = sv_newmortal();
1572 OutputValue(ST(0), value)
1576 db_STORE(db, key, value, flags=0)
1601 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1602 ST(0) = sv_newmortal();
1603 OutputKey(ST(0), key) ;
1609 DBTKEY key = NO_INIT
1620 RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1621 ST(0) = sv_newmortal();
1622 OutputKey(ST(0), key) ;
1626 # These would be nice for RECNO
1646 #ifdef DB_VERSION_MAJOR
1647 /* get the first value */
1648 RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1653 for (i = items-1 ; i > 0 ; --i)
1655 value.data = SvPV(ST(i), n_a) ;
1659 key.size = sizeof(int) ;
1660 #ifdef DB_VERSION_MAJOR
1661 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1663 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
1689 /* First get the final value */
1690 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1691 ST(0) = sv_newmortal();
1695 /* the call to del will trash value, so take a copy now */
1696 OutputValue(ST(0), value) ;
1697 RETVAL = db_del(db, key, R_CURSOR) ;
1699 sv_setsv(ST(0), &PL_sv_undef);
1719 /* get the first value */
1720 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1721 ST(0) = sv_newmortal();
1725 /* the call to del will trash value, so take a copy now */
1726 OutputValue(ST(0), value) ;
1727 RETVAL = db_del(db, key, R_CURSOR) ;
1729 sv_setsv (ST(0), &PL_sv_undef) ;
1752 /* Set the Cursor to the Last element */
1753 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1754 #ifndef DB_VERSION_MAJOR
1759 keyval = *(int*)key.data ;
1762 for (i = 1 ; i < items ; ++i)
1764 value.data = SvPV(ST(i), n_a) ;
1767 key.data = &keyval ;
1768 key.size = sizeof(int) ;
1769 RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1783 ALIAS: FETCHSIZE = 1
1786 RETVAL = GetArrayLength(aTHX_ db) ;
1792 # Now provide an interface to the rest of the DB functionality
1796 db_del(db, key, flags=0)
1804 RETVAL = db_del(db, key, flags) ;
1805 #ifdef DB_VERSION_MAJOR
1808 else if (RETVAL == DB_NOTFOUND)
1816 db_get(db, key, value, flags=0)
1826 RETVAL = db_get(db, key, value, flags) ;
1827 #ifdef DB_VERSION_MAJOR
1830 else if (RETVAL == DB_NOTFOUND)
1838 db_put(db, key, value, flags=0)
1847 RETVAL = db_put(db, key, value, flags) ;
1848 #ifdef DB_VERSION_MAJOR
1851 else if (RETVAL == DB_KEYEXIST)
1856 key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1865 #ifdef DB_VERSION_MAJOR
1869 status = (db->in_memory
1871 : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1876 RETVAL = (db->in_memory
1878 : ((db->dbp)->fd)(db->dbp) ) ;
1884 db_sync(db, flags=0)
1891 RETVAL = db_sync(db, flags) ;
1892 #ifdef DB_VERSION_MAJOR
1901 db_seq(db, key, value, flags)
1911 RETVAL = db_seq(db, key, value, flags);
1912 #ifdef DB_VERSION_MAJOR
1915 else if (RETVAL == DB_NOTFOUND)
1924 filter_fetch_key(db, code)
1927 SV * RETVAL = &PL_sv_undef ;
1929 DBM_setFilter(db->filter_fetch_key, code) ;
1932 filter_store_key(db, code)
1935 SV * RETVAL = &PL_sv_undef ;
1937 DBM_setFilter(db->filter_store_key, code) ;
1940 filter_fetch_value(db, code)
1943 SV * RETVAL = &PL_sv_undef ;
1945 DBM_setFilter(db->filter_fetch_value, code) ;
1948 filter_store_value(db, code)
1951 SV * RETVAL = &PL_sv_undef ;
1953 DBM_setFilter(db->filter_store_value, code) ;