3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess <pmqs@cpan.org>
6 last modified 31st October 2005
9 All comments/suggestions/problems are welcome
11 Copyright (c) 1995-2005 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.
110 1.808 - leak fixed in ParseOpenInfo
119 #define PERL_NO_GET_CONTEXT
128 /* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
129 DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
131 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
132 * shortly #included by the <db.h>) __attribute__ to the possibly
133 * already defined __attribute__, for example by GNUC or by Perl. */
135 /* #if DB_VERSION_MAJOR_CFG < 2 */
136 #ifndef DB_VERSION_MAJOR
137 # undef __attribute__
146 /* Wall starts with 5.7.x */
148 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
150 /* Since we dropped the gccish definition of __attribute__ we will want
151 * to redefine dNOOP, however (so that dTHX continues to work). Yes,
152 * all this means that we can't do attribute checking on the DB_File,
154 # ifndef DB_VERSION_MAJOR
157 # define dNOOP extern int Perl___notused
159 /* Ditto for dXSARGS. */
163 I32 ax = mark - PL_stack_base + 1; \
164 I32 items = sp - mark
168 /* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
170 # define dXSI32 dNOOP
172 #endif /* Perl >= 5.7 */
179 # define Trace(x) printf x
185 #define DBT_clear(x) Zero(&x, 1, DBT) ;
187 #ifdef DB_VERSION_MAJOR
189 #if DB_VERSION_MAJOR == 2
190 # define BERKELEY_DB_1_OR_2
193 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
194 # define AT_LEAST_DB_3_2
197 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3)
198 # define AT_LEAST_DB_3_3
201 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
202 # define AT_LEAST_DB_4_1
205 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 3)
206 # define AT_LEAST_DB_4_3
209 #ifdef AT_LEAST_DB_3_3
213 /* map version 2 features & constants onto their version 1 equivalent */
218 #define DB_Prefix_t size_t
223 #define DB_Hash_t u_int32_t
225 /* DBTYPE stays the same */
226 /* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
227 #if DB_VERSION_MAJOR == 2
228 typedef DB_INFO INFO ;
229 #else /* DB_VERSION_MAJOR > 2 */
230 # define DB_FIXEDLEN (0x8000)
231 #endif /* DB_VERSION_MAJOR == 2 */
233 /* version 2 has db_recno_t in place of recno_t */
234 typedef db_recno_t recno_t;
237 #define R_CURSOR DB_SET_RANGE
238 #define R_FIRST DB_FIRST
239 #define R_IAFTER DB_AFTER
240 #define R_IBEFORE DB_BEFORE
241 #define R_LAST DB_LAST
242 #define R_NEXT DB_NEXT
243 #define R_NOOVERWRITE DB_NOOVERWRITE
244 #define R_PREV DB_PREV
246 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
247 # define R_SETCURSOR 0x800000
249 # define R_SETCURSOR (-100)
252 #define R_RECNOSYNC 0
253 #define R_FIXEDLEN DB_FIXEDLEN
257 #define db_HA_hash h_hash
258 #define db_HA_ffactor h_ffactor
259 #define db_HA_nelem h_nelem
260 #define db_HA_bsize db_pagesize
261 #define db_HA_cachesize db_cachesize
262 #define db_HA_lorder db_lorder
264 #define db_BT_compare bt_compare
265 #define db_BT_prefix bt_prefix
266 #define db_BT_flags flags
267 #define db_BT_psize db_pagesize
268 #define db_BT_cachesize db_cachesize
269 #define db_BT_lorder db_lorder
270 #define db_BT_maxkeypage
271 #define db_BT_minkeypage
274 #define db_RE_reclen re_len
275 #define db_RE_flags flags
276 #define db_RE_bval re_pad
277 #define db_RE_bfname re_source
278 #define db_RE_psize db_pagesize
279 #define db_RE_cachesize db_cachesize
280 #define db_RE_lorder db_lorder
284 #define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
287 #define DBT_flags(x) x.flags = 0
288 #define DB_flags(x, v) x |= v
290 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
291 # define flagSet(flags, bitmask) ((flags) & (bitmask))
293 # define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask))
296 #else /* db version 1.x */
298 #define BERKELEY_DB_1
299 #define BERKELEY_DB_1_OR_2
312 # define DB_Prefix_t mDB_Prefix_t
319 # define DB_Hash_t mDB_Hash_t
322 #define db_HA_hash hash.hash
323 #define db_HA_ffactor hash.ffactor
324 #define db_HA_nelem hash.nelem
325 #define db_HA_bsize hash.bsize
326 #define db_HA_cachesize hash.cachesize
327 #define db_HA_lorder hash.lorder
329 #define db_BT_compare btree.compare
330 #define db_BT_prefix btree.prefix
331 #define db_BT_flags btree.flags
332 #define db_BT_psize btree.psize
333 #define db_BT_cachesize btree.cachesize
334 #define db_BT_lorder btree.lorder
335 #define db_BT_maxkeypage btree.maxkeypage
336 #define db_BT_minkeypage btree.minkeypage
338 #define db_RE_reclen recno.reclen
339 #define db_RE_flags recno.flags
340 #define db_RE_bval recno.bval
341 #define db_RE_bfname recno.bfname
342 #define db_RE_psize recno.psize
343 #define db_RE_cachesize recno.cachesize
344 #define db_RE_lorder recno.lorder
348 #define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
350 #define DB_flags(x, v)
351 #define flagSet(flags, bitmask) ((flags) & (bitmask))
353 #endif /* db version 1 */
357 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0)
358 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
359 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
361 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
362 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
364 #ifdef DB_VERSION_MAJOR
365 #define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\
366 (db->dbp->close)(db->dbp, 0) ))
367 #define db_close(db) ((db->dbp)->close)(db->dbp, 0)
368 #define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
369 ? ((db->cursor)->c_del)(db->cursor, 0) \
370 : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
372 #else /* ! DB_VERSION_MAJOR */
374 #define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp))
375 #define db_close(db) ((db->dbp)->close)(db->dbp)
376 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
377 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
379 #endif /* ! DB_VERSION_MAJOR */
382 #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
395 #ifdef BERKELEY_DB_1_OR_2
398 #ifdef DB_VERSION_MAJOR
401 SV * filter_fetch_key ;
402 SV * filter_store_key ;
403 SV * filter_fetch_value ;
404 SV * filter_store_value ;
409 typedef DB_File_type * DB_File ;
412 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
414 #define OutputValue(arg, name) \
415 { if (RETVAL == 0) { \
417 my_sv_setpvn(arg, name.data, name.size) ; \
421 DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
425 #define OutputKey(arg, name) \
429 if (db->type != DB_RECNO) { \
430 my_sv_setpvn(arg, name.data, name.size); \
433 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
437 DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
441 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
444 extern void __getBerkeleyDBInfo(void);
447 /* Internal Global Data */
449 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION
460 #define Value (MY_CXT.x_Value)
461 #define zero (MY_CXT.x_zero)
462 #define CurrentDB (MY_CXT.x_CurrentDB)
463 #define empty (MY_CXT.x_empty)
465 #define ERR_BUFF "DB_File::Error"
467 #ifdef DB_VERSION_MAJOR
471 db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
473 db_put(db, key, value, flags)
482 if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
486 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
487 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
489 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
493 memset(&l_key, 0, sizeof(l_key));
494 l_key.data = key.data;
495 l_key.size = key.size;
496 memset(&l_value, 0, sizeof(l_value));
497 l_value.data = value.data;
498 l_value.size = value.size;
500 if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
501 (void)temp_cursor->c_close(temp_cursor);
505 status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
506 (void)temp_cursor->c_close(temp_cursor);
512 if (flagSet(flags, R_CURSOR)) {
513 return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
516 if (flagSet(flags, R_SETCURSOR)) {
517 if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
519 return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
523 return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
527 #endif /* DB_VERSION_MAJOR */
537 #ifdef AT_LEAST_DB_3_2
540 btree_compare(DB * db, const DBT *key1, const DBT *key2)
542 btree_compare(db, key1, key2)
546 #endif /* CAN_PROTOTYPE */
548 #else /* Berkeley DB < 3.2 */
551 btree_compare(const DBT *key1, const DBT *key2)
553 btree_compare(key1, key2)
566 void * data1, * data2 ;
571 if (CurrentDB->in_compare) {
573 croak ("DB_File btree_compare: recursion detected\n") ;
576 data1 = (char *) key1->data ;
577 data2 = (char *) key2->data ;
580 /* As newSVpv will assume that the data pointer is a null terminated C
581 string if the size parameter is 0, make sure that data points to an
582 empty string if the length is 0
593 CurrentDB->in_compare = FALSE;
594 SAVEINT(CurrentDB->in_compare);
595 CurrentDB->in_compare = TRUE;
599 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
600 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
603 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
609 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
623 #ifdef AT_LEAST_DB_3_2
626 btree_prefix(DB * db, const DBT *key1, const DBT *key2)
628 btree_prefix(db, key1, key2)
634 #else /* Berkeley DB < 3.2 */
637 btree_prefix(const DBT *key1, const DBT *key2)
639 btree_prefix(key1, key2)
651 char * data1, * data2 ;
655 if (CurrentDB->in_prefix){
657 croak ("DB_File btree_prefix: recursion detected\n") ;
660 data1 = (char *) key1->data ;
661 data2 = (char *) key2->data ;
664 /* As newSVpv will assume that the data pointer is a null terminated C
665 string if the size parameter is 0, make sure that data points to an
666 empty string if the length is 0
677 CurrentDB->in_prefix = FALSE;
678 SAVEINT(CurrentDB->in_prefix);
679 CurrentDB->in_prefix = TRUE;
683 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
684 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
687 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
693 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
707 # define HASH_CB_SIZE_TYPE size_t
709 # define HASH_CB_SIZE_TYPE u_int32_t
713 #ifdef AT_LEAST_DB_3_2
716 hash_cb(DB * db, const void *data, u_int32_t size)
718 hash_cb(db, data, size)
721 HASH_CB_SIZE_TYPE size ;
724 #else /* Berkeley DB < 3.2 */
727 hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
731 HASH_CB_SIZE_TYPE size ;
744 if (CurrentDB->in_hash){
746 croak ("DB_File hash callback: recursion detected\n") ;
754 /* DGH - Next two lines added to fix corrupted stack problem */
758 CurrentDB->in_hash = FALSE;
759 SAVEINT(CurrentDB->in_hash);
760 CurrentDB->in_hash = TRUE;
765 XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
768 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
774 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
789 #ifdef AT_LEAST_DB_4_3
790 db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
792 db_errcall_cb(const char * db_errpfx, char * buffer)
798 SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
801 sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
803 sv_setpv(sv, buffer) ;
808 #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
812 PrintHash(INFO *hash)
818 printf ("HASH Info\n") ;
819 printf (" hash = %s\n",
820 (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
821 printf (" bsize = %d\n", hash->db_HA_bsize) ;
822 printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
823 printf (" nelem = %d\n", hash->db_HA_nelem) ;
824 printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
825 printf (" lorder = %d\n", hash->db_HA_lorder) ;
831 PrintRecno(INFO *recno)
837 printf ("RECNO Info\n") ;
838 printf (" flags = %d\n", recno->db_RE_flags) ;
839 printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
840 printf (" psize = %d\n", recno->db_RE_psize) ;
841 printf (" lorder = %d\n", recno->db_RE_lorder) ;
842 printf (" reclen = %lu\n", (unsigned long)recno->db_RE_reclen) ;
843 printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
844 printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
849 PrintBtree(INFO *btree)
855 printf ("BTREE Info\n") ;
856 printf (" compare = %s\n",
857 (btree->db_BT_compare ? "redefined" : "default")) ;
858 printf (" prefix = %s\n",
859 (btree->db_BT_prefix ? "redefined" : "default")) ;
860 printf (" flags = %d\n", btree->db_BT_flags) ;
861 printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
862 printf (" psize = %d\n", btree->db_BT_psize) ;
863 #ifndef DB_VERSION_MAJOR
864 printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
865 printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
867 printf (" lorder = %d\n", btree->db_BT_lorder) ;
872 #define PrintRecno(recno)
873 #define PrintHash(hash)
874 #define PrintBtree(btree)
881 GetArrayLength(pTHX_ DB_File db)
893 RETVAL = do_SEQ(db, key, value, R_LAST) ;
895 RETVAL = *(I32 *)key.data ;
896 else /* No key means empty file */
899 return ((I32)RETVAL) ;
904 GetRecnoKey(pTHX_ DB_File db, I32 value)
906 GetRecnoKey(db, value)
912 /* Get the length of the array */
913 I32 length = GetArrayLength(aTHX_ db) ;
915 /* check for attempt to write before start of array */
916 if (length + value + 1 <= 0) {
918 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
921 value = length + value + 1 ;
932 ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
934 ParseOpenInfo(isHASH, name, flags, mode, sv)
943 #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */
947 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
948 void * openinfo = NULL ;
949 INFO * info = &RETVAL->info ;
954 printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n",
955 name, flags, mode, sv == NULL) ;
957 Zero(RETVAL, 1, DB_File_type) ;
959 /* Default to HASH */
960 RETVAL->filtering = 0 ;
961 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
962 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
963 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
964 RETVAL->type = DB_HASH ;
966 /* DGH - Next line added to avoid SEGV on existing hash DB */
969 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
970 RETVAL->in_memory = (name == NULL) ;
975 croak ("type parameter is not a reference") ;
977 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
978 if (svp && SvOK(*svp))
979 action = (HV*) SvRV(*svp) ;
981 croak("internal error") ;
983 if (sv_isa(sv, "DB_File::HASHINFO"))
987 croak("DB_File can only tie an associative array to a DB_HASH database") ;
989 RETVAL->type = DB_HASH ;
990 openinfo = (void*)info ;
992 svp = hv_fetch(action, "hash", 4, FALSE);
994 if (svp && SvOK(*svp))
996 info->db_HA_hash = hash_cb ;
997 RETVAL->hash = newSVsv(*svp) ;
1000 info->db_HA_hash = NULL ;
1002 svp = hv_fetch(action, "ffactor", 7, FALSE);
1003 info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
1005 svp = hv_fetch(action, "nelem", 5, FALSE);
1006 info->db_HA_nelem = svp ? SvIV(*svp) : 0;
1008 svp = hv_fetch(action, "bsize", 5, FALSE);
1009 info->db_HA_bsize = svp ? SvIV(*svp) : 0;
1011 svp = hv_fetch(action, "cachesize", 9, FALSE);
1012 info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
1014 svp = hv_fetch(action, "lorder", 6, FALSE);
1015 info->db_HA_lorder = svp ? SvIV(*svp) : 0;
1019 else if (sv_isa(sv, "DB_File::BTREEINFO"))
1022 croak("DB_File can only tie an associative array to a DB_BTREE database");
1024 RETVAL->type = DB_BTREE ;
1025 openinfo = (void*)info ;
1027 svp = hv_fetch(action, "compare", 7, FALSE);
1028 if (svp && SvOK(*svp))
1030 info->db_BT_compare = btree_compare ;
1031 RETVAL->compare = newSVsv(*svp) ;
1034 info->db_BT_compare = NULL ;
1036 svp = hv_fetch(action, "prefix", 6, FALSE);
1037 if (svp && SvOK(*svp))
1039 info->db_BT_prefix = btree_prefix ;
1040 RETVAL->prefix = newSVsv(*svp) ;
1043 info->db_BT_prefix = NULL ;
1045 svp = hv_fetch(action, "flags", 5, FALSE);
1046 info->db_BT_flags = svp ? SvIV(*svp) : 0;
1048 svp = hv_fetch(action, "cachesize", 9, FALSE);
1049 info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
1051 #ifndef DB_VERSION_MAJOR
1052 svp = hv_fetch(action, "minkeypage", 10, FALSE);
1053 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
1055 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
1056 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
1059 svp = hv_fetch(action, "psize", 5, FALSE);
1060 info->db_BT_psize = svp ? SvIV(*svp) : 0;
1062 svp = hv_fetch(action, "lorder", 6, FALSE);
1063 info->db_BT_lorder = svp ? SvIV(*svp) : 0;
1068 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1071 croak("DB_File can only tie an array to a DB_RECNO database");
1073 RETVAL->type = DB_RECNO ;
1074 openinfo = (void *)info ;
1076 info->db_RE_flags = 0 ;
1078 svp = hv_fetch(action, "flags", 5, FALSE);
1079 info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
1081 svp = hv_fetch(action, "reclen", 6, FALSE);
1082 info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
1084 svp = hv_fetch(action, "cachesize", 9, FALSE);
1085 info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
1087 svp = hv_fetch(action, "psize", 5, FALSE);
1088 info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
1090 svp = hv_fetch(action, "lorder", 6, FALSE);
1091 info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
1093 #ifdef DB_VERSION_MAJOR
1094 info->re_source = name ;
1097 svp = hv_fetch(action, "bfname", 6, FALSE);
1098 if (svp && SvOK(*svp)) {
1099 char * ptr = SvPV(*svp,n_a) ;
1100 #ifdef DB_VERSION_MAJOR
1101 name = (char*) n_a ? ptr : NULL ;
1103 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
1107 #ifdef DB_VERSION_MAJOR
1110 info->db_RE_bfname = NULL ;
1113 svp = hv_fetch(action, "bval", 4, FALSE);
1114 #ifdef DB_VERSION_MAJOR
1115 if (svp && SvOK(*svp))
1119 value = (int)*SvPV(*svp, n_a) ;
1121 value = SvIV(*svp) ;
1123 if (info->flags & DB_FIXEDLEN) {
1124 info->re_pad = value ;
1125 info->flags |= DB_PAD ;
1128 info->re_delim = value ;
1129 info->flags |= DB_DELIMITER ;
1134 if (svp && SvOK(*svp))
1137 info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
1139 info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
1140 DB_flags(info->flags, DB_DELIMITER) ;
1145 if (info->db_RE_flags & R_FIXEDLEN)
1146 info->db_RE_bval = (u_char) ' ' ;
1148 info->db_RE_bval = (u_char) '\n' ;
1149 DB_flags(info->flags, DB_DELIMITER) ;
1154 info->flags |= DB_RENUMBER ;
1160 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1164 /* OS2 Specific Code */
1168 #endif /* __EMX__ */
1171 #ifdef DB_VERSION_MAJOR
1177 /* Map 1.x flags to 2.x flags */
1178 if ((flags & O_CREAT) == O_CREAT)
1179 Flags |= DB_CREATE ;
1182 if (flags == O_RDONLY)
1184 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1186 Flags |= DB_RDONLY ;
1189 if ((flags & O_TRUNC) == O_TRUNC)
1190 Flags |= DB_TRUNCATE ;
1193 status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
1195 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
1196 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
1198 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1203 RETVAL->dbp = NULL ;
1208 #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
1209 RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ;
1211 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
1212 #endif /* DB_LIBRARY_COMPATIBILITY_API */
1218 #else /* Berkeley DB Version > 2 */
1222 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
1228 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
1229 Zero(RETVAL, 1, DB_File_type) ;
1231 /* Default to HASH */
1232 RETVAL->filtering = 0 ;
1233 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
1234 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
1235 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
1236 RETVAL->type = DB_HASH ;
1238 /* DGH - Next line added to avoid SEGV on existing hash DB */
1241 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
1242 RETVAL->in_memory = (name == NULL) ;
1244 status = db_create(&RETVAL->dbp, NULL,0) ;
1245 /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
1247 RETVAL->dbp = NULL ;
1253 RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
1258 croak ("type parameter is not a reference") ;
1260 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
1261 if (svp && SvOK(*svp))
1262 action = (HV*) SvRV(*svp) ;
1264 croak("internal error") ;
1266 if (sv_isa(sv, "DB_File::HASHINFO"))
1270 croak("DB_File can only tie an associative array to a DB_HASH database") ;
1272 RETVAL->type = DB_HASH ;
1274 svp = hv_fetch(action, "hash", 4, FALSE);
1276 if (svp && SvOK(*svp))
1278 (void)dbp->set_h_hash(dbp, hash_cb) ;
1279 RETVAL->hash = newSVsv(*svp) ;
1282 svp = hv_fetch(action, "ffactor", 7, FALSE);
1284 (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ;
1286 svp = hv_fetch(action, "nelem", 5, FALSE);
1288 (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
1290 svp = hv_fetch(action, "bsize", 5, FALSE);
1292 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
1294 svp = hv_fetch(action, "cachesize", 9, FALSE);
1296 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1298 svp = hv_fetch(action, "lorder", 6, FALSE);
1300 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1304 else if (sv_isa(sv, "DB_File::BTREEINFO"))
1307 croak("DB_File can only tie an associative array to a DB_BTREE database");
1309 RETVAL->type = DB_BTREE ;
1311 svp = hv_fetch(action, "compare", 7, FALSE);
1312 if (svp && SvOK(*svp))
1314 (void)dbp->set_bt_compare(dbp, btree_compare) ;
1315 RETVAL->compare = newSVsv(*svp) ;
1318 svp = hv_fetch(action, "prefix", 6, FALSE);
1319 if (svp && SvOK(*svp))
1321 (void)dbp->set_bt_prefix(dbp, btree_prefix) ;
1322 RETVAL->prefix = newSVsv(*svp) ;
1325 svp = hv_fetch(action, "flags", 5, FALSE);
1327 (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ;
1329 svp = hv_fetch(action, "cachesize", 9, FALSE);
1331 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1333 svp = hv_fetch(action, "psize", 5, FALSE);
1335 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1337 svp = hv_fetch(action, "lorder", 6, FALSE);
1339 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1344 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1349 croak("DB_File can only tie an array to a DB_RECNO database");
1351 RETVAL->type = DB_RECNO ;
1353 svp = hv_fetch(action, "flags", 5, FALSE);
1355 int flags = SvIV(*svp) ;
1356 /* remove FIXDLEN, if present */
1357 if (flags & DB_FIXEDLEN) {
1359 flags &= ~DB_FIXEDLEN ;
1363 svp = hv_fetch(action, "cachesize", 9, FALSE);
1365 status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1368 svp = hv_fetch(action, "psize", 5, FALSE);
1370 status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1373 svp = hv_fetch(action, "lorder", 6, FALSE);
1375 status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1378 svp = hv_fetch(action, "bval", 4, FALSE);
1379 if (svp && SvOK(*svp))
1383 value = (int)*SvPV(*svp, n_a) ;
1385 value = (int)SvIV(*svp) ;
1388 status = dbp->set_re_pad(dbp, value) ;
1391 status = dbp->set_re_delim(dbp, value) ;
1397 svp = hv_fetch(action, "reclen", 6, FALSE);
1399 u_int32_t len = my_SvUV32(*svp) ;
1400 status = dbp->set_re_len(dbp, len) ;
1405 status = dbp->set_re_source(dbp, name) ;
1409 svp = hv_fetch(action, "bfname", 6, FALSE);
1410 if (svp && SvOK(*svp)) {
1411 char * ptr = SvPV(*svp,n_a) ;
1412 name = (char*) n_a ? ptr : NULL ;
1418 status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
1421 (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
1426 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1430 u_int32_t Flags = 0 ;
1433 /* Map 1.x flags to 3.x flags */
1434 if ((flags & O_CREAT) == O_CREAT)
1435 Flags |= DB_CREATE ;
1438 if (flags == O_RDONLY)
1440 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1442 Flags |= DB_RDONLY ;
1445 if ((flags & O_TRUNC) == O_TRUNC)
1446 Flags |= DB_TRUNCATE ;
1449 #ifdef AT_LEAST_DB_4_4
1450 /* need this for recno */
1451 if ((flags & O_TRUNC) == O_TRUNC)
1452 Flags |= DB_CREATE ;
1455 #ifdef AT_LEAST_DB_4_1
1456 status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type,
1459 status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type,
1462 /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
1466 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1468 /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
1472 RETVAL->dbp = NULL ;
1478 #endif /* Berkeley DB Version > 2 */
1480 } /* ParseOpenInfo */
1483 #include "constants.h"
1485 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
1487 INCLUDE: constants.xs
1495 SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
1498 __getBerkeleyDBInfo() ;
1501 empty.data = &zero ;
1502 empty.size = sizeof(recno_t) ;
1508 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1515 char * name = (char *) NULL ;
1516 SV * sv = (SV *) NULL ;
1519 if (items >= 3 && SvOK(ST(2)))
1520 name = (char*) SvPV(ST(2), n_a) ;
1525 RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1526 if (RETVAL->dbp == NULL) {
1541 Trace(("DESTROY %p\n", db));
1543 Trace(("DESTROY %p done\n", db));
1545 SvREFCNT_dec(db->hash) ;
1547 SvREFCNT_dec(db->compare) ;
1549 SvREFCNT_dec(db->prefix) ;
1550 if (db->filter_fetch_key)
1551 SvREFCNT_dec(db->filter_fetch_key) ;
1552 if (db->filter_store_key)
1553 SvREFCNT_dec(db->filter_store_key) ;
1554 if (db->filter_fetch_value)
1555 SvREFCNT_dec(db->filter_fetch_value) ;
1556 if (db->filter_store_value)
1557 SvREFCNT_dec(db->filter_store_value) ;
1559 #ifdef DB_VERSION_MAJOR
1566 db_DELETE(db, key, flags=0)
1588 RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1594 db_FETCH(db, key, flags=0)
1607 RETVAL = db_get(db, key, value, flags) ;
1608 ST(0) = sv_newmortal();
1609 OutputValue(ST(0), value)
1613 db_STORE(db, key, value, flags=0)
1638 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1639 ST(0) = sv_newmortal();
1640 OutputKey(ST(0), key) ;
1646 DBTKEY key = NO_INIT
1657 RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1658 ST(0) = sv_newmortal();
1659 OutputKey(ST(0), key) ;
1663 # These would be nice for RECNO
1683 #ifdef DB_VERSION_MAJOR
1684 /* get the first value */
1685 RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1690 for (i = items-1 ; i > 0 ; --i)
1692 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1693 value.data = SvPVbyte(ST(i), n_a) ;
1697 key.size = sizeof(int) ;
1698 #ifdef DB_VERSION_MAJOR
1699 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1701 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
1727 /* First get the final value */
1728 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1729 ST(0) = sv_newmortal();
1733 /* the call to del will trash value, so take a copy now */
1734 OutputValue(ST(0), value) ;
1735 RETVAL = db_del(db, key, R_CURSOR) ;
1737 sv_setsv(ST(0), &PL_sv_undef);
1757 /* get the first value */
1758 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1759 ST(0) = sv_newmortal();
1763 /* the call to del will trash value, so take a copy now */
1764 OutputValue(ST(0), value) ;
1765 RETVAL = db_del(db, key, R_CURSOR) ;
1767 sv_setsv (ST(0), &PL_sv_undef) ;
1790 /* Set the Cursor to the Last element */
1791 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1792 #ifndef DB_VERSION_MAJOR
1797 keyval = *(int*)key.data ;
1800 for (i = 1 ; i < items ; ++i)
1802 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1803 value.data = SvPVbyte(ST(i), n_a) ;
1806 key.data = &keyval ;
1807 key.size = sizeof(int) ;
1808 RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1822 ALIAS: FETCHSIZE = 1
1825 RETVAL = GetArrayLength(aTHX_ db) ;
1831 # Now provide an interface to the rest of the DB functionality
1835 db_del(db, key, flags=0)
1843 RETVAL = db_del(db, key, flags) ;
1844 #ifdef DB_VERSION_MAJOR
1847 else if (RETVAL == DB_NOTFOUND)
1855 db_get(db, key, value, flags=0)
1865 RETVAL = db_get(db, key, value, flags) ;
1866 #ifdef DB_VERSION_MAJOR
1869 else if (RETVAL == DB_NOTFOUND)
1877 db_put(db, key, value, flags=0)
1886 RETVAL = db_put(db, key, value, flags) ;
1887 #ifdef DB_VERSION_MAJOR
1890 else if (RETVAL == DB_KEYEXIST)
1895 key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1904 #ifdef DB_VERSION_MAJOR
1908 status = (db->in_memory
1910 : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1915 RETVAL = (db->in_memory
1917 : ((db->dbp)->fd)(db->dbp) ) ;
1923 db_sync(db, flags=0)
1930 RETVAL = db_sync(db, flags) ;
1931 #ifdef DB_VERSION_MAJOR
1940 db_seq(db, key, value, flags)
1950 RETVAL = db_seq(db, key, value, flags);
1951 #ifdef DB_VERSION_MAJOR
1954 else if (RETVAL == DB_NOTFOUND)
1963 filter_fetch_key(db, code)
1966 SV * RETVAL = &PL_sv_undef ;
1968 DBM_setFilter(db->filter_fetch_key, code) ;
1971 filter_store_key(db, code)
1974 SV * RETVAL = &PL_sv_undef ;
1976 DBM_setFilter(db->filter_store_key, code) ;
1979 filter_fetch_value(db, code)
1982 SV * RETVAL = &PL_sv_undef ;
1984 DBM_setFilter(db->filter_fetch_value, code) ;
1987 filter_store_value(db, code)
1990 SV * RETVAL = &PL_sv_undef ;
1992 DBM_setFilter(db->filter_store_value, code) ;