3 DB_File.xs -- Perl 5 interface to Berkeley DB
5 written by Paul Marquess <pmqs@cpan.org>
6 last modified 12th March 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
117 #define PERL_NO_GET_CONTEXT
126 /* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
127 DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
129 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
130 * shortly #included by the <db.h>) __attribute__ to the possibly
131 * already defined __attribute__, for example by GNUC or by Perl. */
133 /* #if DB_VERSION_MAJOR_CFG < 2 */
134 #ifndef DB_VERSION_MAJOR
135 # undef __attribute__
144 /* Wall starts with 5.7.x */
146 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
148 /* Since we dropped the gccish definition of __attribute__ we will want
149 * to redefine dNOOP, however (so that dTHX continues to work). Yes,
150 * all this means that we can't do attribute checking on the DB_File,
152 # ifndef DB_VERSION_MAJOR
155 # define dNOOP extern int Perl___notused
157 /* Ditto for dXSARGS. */
161 I32 ax = mark - PL_stack_base + 1; \
162 I32 items = sp - mark
166 /* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
168 # define dXSI32 dNOOP
170 #endif /* Perl >= 5.7 */
177 # define Trace(x) printf x
183 #define DBT_clear(x) Zero(&x, 1, DBT) ;
185 #ifdef DB_VERSION_MAJOR
187 #if DB_VERSION_MAJOR == 2
188 # define BERKELEY_DB_1_OR_2
191 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
192 # define AT_LEAST_DB_3_2
195 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
196 # define AT_LEAST_DB_4_1
199 /* map version 2 features & constants onto their version 1 equivalent */
204 #define DB_Prefix_t size_t
209 #define DB_Hash_t u_int32_t
211 /* DBTYPE stays the same */
212 /* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
213 #if DB_VERSION_MAJOR == 2
214 typedef DB_INFO INFO ;
215 #else /* DB_VERSION_MAJOR > 2 */
216 # define DB_FIXEDLEN (0x8000)
217 #endif /* DB_VERSION_MAJOR == 2 */
219 /* version 2 has db_recno_t in place of recno_t */
220 typedef db_recno_t recno_t;
223 #define R_CURSOR DB_SET_RANGE
224 #define R_FIRST DB_FIRST
225 #define R_IAFTER DB_AFTER
226 #define R_IBEFORE DB_BEFORE
227 #define R_LAST DB_LAST
228 #define R_NEXT DB_NEXT
229 #define R_NOOVERWRITE DB_NOOVERWRITE
230 #define R_PREV DB_PREV
232 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
233 # define R_SETCURSOR 0x800000
235 # define R_SETCURSOR (-100)
238 #define R_RECNOSYNC 0
239 #define R_FIXEDLEN DB_FIXEDLEN
243 #define db_HA_hash h_hash
244 #define db_HA_ffactor h_ffactor
245 #define db_HA_nelem h_nelem
246 #define db_HA_bsize db_pagesize
247 #define db_HA_cachesize db_cachesize
248 #define db_HA_lorder db_lorder
250 #define db_BT_compare bt_compare
251 #define db_BT_prefix bt_prefix
252 #define db_BT_flags flags
253 #define db_BT_psize db_pagesize
254 #define db_BT_cachesize db_cachesize
255 #define db_BT_lorder db_lorder
256 #define db_BT_maxkeypage
257 #define db_BT_minkeypage
260 #define db_RE_reclen re_len
261 #define db_RE_flags flags
262 #define db_RE_bval re_pad
263 #define db_RE_bfname re_source
264 #define db_RE_psize db_pagesize
265 #define db_RE_cachesize db_cachesize
266 #define db_RE_lorder db_lorder
270 #define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
273 #define DBT_flags(x) x.flags = 0
274 #define DB_flags(x, v) x |= v
276 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
277 # define flagSet(flags, bitmask) ((flags) & (bitmask))
279 # define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask))
282 #else /* db version 1.x */
284 #define BERKELEY_DB_1
285 #define BERKELEY_DB_1_OR_2
298 # define DB_Prefix_t mDB_Prefix_t
305 # define DB_Hash_t mDB_Hash_t
308 #define db_HA_hash hash.hash
309 #define db_HA_ffactor hash.ffactor
310 #define db_HA_nelem hash.nelem
311 #define db_HA_bsize hash.bsize
312 #define db_HA_cachesize hash.cachesize
313 #define db_HA_lorder hash.lorder
315 #define db_BT_compare btree.compare
316 #define db_BT_prefix btree.prefix
317 #define db_BT_flags btree.flags
318 #define db_BT_psize btree.psize
319 #define db_BT_cachesize btree.cachesize
320 #define db_BT_lorder btree.lorder
321 #define db_BT_maxkeypage btree.maxkeypage
322 #define db_BT_minkeypage btree.minkeypage
324 #define db_RE_reclen recno.reclen
325 #define db_RE_flags recno.flags
326 #define db_RE_bval recno.bval
327 #define db_RE_bfname recno.bfname
328 #define db_RE_psize recno.psize
329 #define db_RE_cachesize recno.cachesize
330 #define db_RE_lorder recno.lorder
334 #define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
336 #define DB_flags(x, v)
337 #define flagSet(flags, bitmask) ((flags) & (bitmask))
339 #endif /* db version 1 */
343 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0)
344 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
345 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
347 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
348 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
350 #ifdef DB_VERSION_MAJOR
351 #define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\
352 (db->dbp->close)(db->dbp, 0) ))
353 #define db_close(db) ((db->dbp)->close)(db->dbp, 0)
354 #define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
355 ? ((db->cursor)->c_del)(db->cursor, 0) \
356 : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
358 #else /* ! DB_VERSION_MAJOR */
360 #define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp))
361 #define db_close(db) ((db->dbp)->close)(db->dbp)
362 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
363 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
365 #endif /* ! DB_VERSION_MAJOR */
368 #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
381 #ifdef BERKELEY_DB_1_OR_2
384 #ifdef DB_VERSION_MAJOR
387 SV * filter_fetch_key ;
388 SV * filter_store_key ;
389 SV * filter_fetch_value ;
390 SV * filter_store_value ;
395 typedef DB_File_type * DB_File ;
398 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
400 #define OutputValue(arg, name) \
401 { if (RETVAL == 0) { \
403 my_sv_setpvn(arg, name.data, name.size) ; \
407 DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
411 #define OutputKey(arg, name) \
415 if (db->type != DB_RECNO) { \
416 my_sv_setpvn(arg, name.data, name.size); \
419 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
423 DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
427 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
430 extern void __getBerkeleyDBInfo(void);
433 /* Internal Global Data */
435 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION
446 #define Value (MY_CXT.x_Value)
447 #define zero (MY_CXT.x_zero)
448 #define CurrentDB (MY_CXT.x_CurrentDB)
449 #define empty (MY_CXT.x_empty)
451 #define ERR_BUFF "DB_File::Error"
453 #ifdef DB_VERSION_MAJOR
457 db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
459 db_put(db, key, value, flags)
468 if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
472 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
473 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
475 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
479 memset(&l_key, 0, sizeof(l_key));
480 l_key.data = key.data;
481 l_key.size = key.size;
482 memset(&l_value, 0, sizeof(l_value));
483 l_value.data = value.data;
484 l_value.size = value.size;
486 if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
487 (void)temp_cursor->c_close(temp_cursor);
491 status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
492 (void)temp_cursor->c_close(temp_cursor);
498 if (flagSet(flags, R_CURSOR)) {
499 return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
502 if (flagSet(flags, R_SETCURSOR)) {
503 if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
505 return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
509 return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
513 #endif /* DB_VERSION_MAJOR */
523 #ifdef AT_LEAST_DB_3_2
526 btree_compare(DB * db, const DBT *key1, const DBT *key2)
528 btree_compare(db, key1, key2)
532 #endif /* CAN_PROTOTYPE */
534 #else /* Berkeley DB < 3.2 */
537 btree_compare(const DBT *key1, const DBT *key2)
539 btree_compare(key1, key2)
552 void * data1, * data2 ;
557 if (CurrentDB->in_compare) {
559 croak ("DB_File btree_compare: recursion detected\n") ;
562 data1 = (char *) key1->data ;
563 data2 = (char *) key2->data ;
566 /* As newSVpv will assume that the data pointer is a null terminated C
567 string if the size parameter is 0, make sure that data points to an
568 empty string if the length is 0
579 CurrentDB->in_compare = FALSE;
580 SAVEINT(CurrentDB->in_compare);
581 CurrentDB->in_compare = TRUE;
585 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
586 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
589 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
595 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
609 #ifdef AT_LEAST_DB_3_2
612 btree_prefix(DB * db, const DBT *key1, const DBT *key2)
614 btree_prefix(db, key1, key2)
620 #else /* Berkeley DB < 3.2 */
623 btree_prefix(const DBT *key1, const DBT *key2)
625 btree_prefix(key1, key2)
637 char * data1, * data2 ;
641 if (CurrentDB->in_prefix){
643 croak ("DB_File btree_prefix: recursion detected\n") ;
646 data1 = (char *) key1->data ;
647 data2 = (char *) key2->data ;
650 /* As newSVpv will assume that the data pointer is a null terminated C
651 string if the size parameter is 0, make sure that data points to an
652 empty string if the length is 0
663 CurrentDB->in_prefix = FALSE;
664 SAVEINT(CurrentDB->in_prefix);
665 CurrentDB->in_prefix = TRUE;
669 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
670 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
673 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
679 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
693 # define HASH_CB_SIZE_TYPE size_t
695 # define HASH_CB_SIZE_TYPE u_int32_t
699 #ifdef AT_LEAST_DB_3_2
702 hash_cb(DB * db, const void *data, u_int32_t size)
704 hash_cb(db, data, size)
707 HASH_CB_SIZE_TYPE size ;
710 #else /* Berkeley DB < 3.2 */
713 hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
717 HASH_CB_SIZE_TYPE size ;
730 if (CurrentDB->in_hash){
732 croak ("DB_File hash callback: recursion detected\n") ;
740 /* DGH - Next two lines added to fix corrupted stack problem */
744 CurrentDB->in_hash = FALSE;
745 SAVEINT(CurrentDB->in_hash);
746 CurrentDB->in_hash = TRUE;
751 XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
754 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
760 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
775 db_errcall_cb(const char * db_errpfx, char * buffer)
777 db_errcall_cb(db_errpfx, buffer)
778 const char * db_errpfx;
785 SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
788 sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
790 sv_setpv(sv, buffer) ;
795 #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
799 PrintHash(INFO *hash)
805 printf ("HASH Info\n") ;
806 printf (" hash = %s\n",
807 (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
808 printf (" bsize = %d\n", hash->db_HA_bsize) ;
809 printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
810 printf (" nelem = %d\n", hash->db_HA_nelem) ;
811 printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
812 printf (" lorder = %d\n", hash->db_HA_lorder) ;
818 PrintRecno(INFO *recno)
824 printf ("RECNO Info\n") ;
825 printf (" flags = %d\n", recno->db_RE_flags) ;
826 printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
827 printf (" psize = %d\n", recno->db_RE_psize) ;
828 printf (" lorder = %d\n", recno->db_RE_lorder) ;
829 printf (" reclen = %lu\n", (unsigned long)recno->db_RE_reclen) ;
830 printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
831 printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
836 PrintBtree(INFO *btree)
842 printf ("BTREE Info\n") ;
843 printf (" compare = %s\n",
844 (btree->db_BT_compare ? "redefined" : "default")) ;
845 printf (" prefix = %s\n",
846 (btree->db_BT_prefix ? "redefined" : "default")) ;
847 printf (" flags = %d\n", btree->db_BT_flags) ;
848 printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
849 printf (" psize = %d\n", btree->db_BT_psize) ;
850 #ifndef DB_VERSION_MAJOR
851 printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
852 printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
854 printf (" lorder = %d\n", btree->db_BT_lorder) ;
859 #define PrintRecno(recno)
860 #define PrintHash(hash)
861 #define PrintBtree(btree)
868 GetArrayLength(pTHX_ DB_File db)
880 RETVAL = do_SEQ(db, key, value, R_LAST) ;
882 RETVAL = *(I32 *)key.data ;
883 else /* No key means empty file */
886 return ((I32)RETVAL) ;
891 GetRecnoKey(pTHX_ DB_File db, I32 value)
893 GetRecnoKey(db, value)
899 /* Get the length of the array */
900 I32 length = GetArrayLength(aTHX_ db) ;
902 /* check for attempt to write before start of array */
903 if (length + value + 1 <= 0) {
905 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
908 value = length + value + 1 ;
919 ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
921 ParseOpenInfo(isHASH, name, flags, mode, sv)
930 #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */
934 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
935 void * openinfo = NULL ;
936 INFO * info = &RETVAL->info ;
941 printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n",
942 name, flags, mode, sv == NULL) ;
944 Zero(RETVAL, 1, DB_File_type) ;
946 /* Default to HASH */
947 RETVAL->filtering = 0 ;
948 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
949 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
950 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
951 RETVAL->type = DB_HASH ;
953 /* DGH - Next line added to avoid SEGV on existing hash DB */
956 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
957 RETVAL->in_memory = (name == NULL) ;
962 croak ("type parameter is not a reference") ;
964 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
965 if (svp && SvOK(*svp))
966 action = (HV*) SvRV(*svp) ;
968 croak("internal error") ;
970 if (sv_isa(sv, "DB_File::HASHINFO"))
974 croak("DB_File can only tie an associative array to a DB_HASH database") ;
976 RETVAL->type = DB_HASH ;
977 openinfo = (void*)info ;
979 svp = hv_fetch(action, "hash", 4, FALSE);
981 if (svp && SvOK(*svp))
983 info->db_HA_hash = hash_cb ;
984 RETVAL->hash = newSVsv(*svp) ;
987 info->db_HA_hash = NULL ;
989 svp = hv_fetch(action, "ffactor", 7, FALSE);
990 info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
992 svp = hv_fetch(action, "nelem", 5, FALSE);
993 info->db_HA_nelem = svp ? SvIV(*svp) : 0;
995 svp = hv_fetch(action, "bsize", 5, FALSE);
996 info->db_HA_bsize = svp ? SvIV(*svp) : 0;
998 svp = hv_fetch(action, "cachesize", 9, FALSE);
999 info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
1001 svp = hv_fetch(action, "lorder", 6, FALSE);
1002 info->db_HA_lorder = svp ? SvIV(*svp) : 0;
1006 else if (sv_isa(sv, "DB_File::BTREEINFO"))
1009 croak("DB_File can only tie an associative array to a DB_BTREE database");
1011 RETVAL->type = DB_BTREE ;
1012 openinfo = (void*)info ;
1014 svp = hv_fetch(action, "compare", 7, FALSE);
1015 if (svp && SvOK(*svp))
1017 info->db_BT_compare = btree_compare ;
1018 RETVAL->compare = newSVsv(*svp) ;
1021 info->db_BT_compare = NULL ;
1023 svp = hv_fetch(action, "prefix", 6, FALSE);
1024 if (svp && SvOK(*svp))
1026 info->db_BT_prefix = btree_prefix ;
1027 RETVAL->prefix = newSVsv(*svp) ;
1030 info->db_BT_prefix = NULL ;
1032 svp = hv_fetch(action, "flags", 5, FALSE);
1033 info->db_BT_flags = svp ? SvIV(*svp) : 0;
1035 svp = hv_fetch(action, "cachesize", 9, FALSE);
1036 info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
1038 #ifndef DB_VERSION_MAJOR
1039 svp = hv_fetch(action, "minkeypage", 10, FALSE);
1040 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
1042 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
1043 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
1046 svp = hv_fetch(action, "psize", 5, FALSE);
1047 info->db_BT_psize = svp ? SvIV(*svp) : 0;
1049 svp = hv_fetch(action, "lorder", 6, FALSE);
1050 info->db_BT_lorder = svp ? SvIV(*svp) : 0;
1055 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1058 croak("DB_File can only tie an array to a DB_RECNO database");
1060 RETVAL->type = DB_RECNO ;
1061 openinfo = (void *)info ;
1063 info->db_RE_flags = 0 ;
1065 svp = hv_fetch(action, "flags", 5, FALSE);
1066 info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
1068 svp = hv_fetch(action, "reclen", 6, FALSE);
1069 info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
1071 svp = hv_fetch(action, "cachesize", 9, FALSE);
1072 info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
1074 svp = hv_fetch(action, "psize", 5, FALSE);
1075 info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
1077 svp = hv_fetch(action, "lorder", 6, FALSE);
1078 info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
1080 #ifdef DB_VERSION_MAJOR
1081 info->re_source = name ;
1084 svp = hv_fetch(action, "bfname", 6, FALSE);
1085 if (svp && SvOK(*svp)) {
1086 char * ptr = SvPV(*svp,n_a) ;
1087 #ifdef DB_VERSION_MAJOR
1088 name = (char*) n_a ? ptr : NULL ;
1090 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
1094 #ifdef DB_VERSION_MAJOR
1097 info->db_RE_bfname = NULL ;
1100 svp = hv_fetch(action, "bval", 4, FALSE);
1101 #ifdef DB_VERSION_MAJOR
1102 if (svp && SvOK(*svp))
1106 value = (int)*SvPV(*svp, n_a) ;
1108 value = SvIV(*svp) ;
1110 if (info->flags & DB_FIXEDLEN) {
1111 info->re_pad = value ;
1112 info->flags |= DB_PAD ;
1115 info->re_delim = value ;
1116 info->flags |= DB_DELIMITER ;
1121 if (svp && SvOK(*svp))
1124 info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
1126 info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
1127 DB_flags(info->flags, DB_DELIMITER) ;
1132 if (info->db_RE_flags & R_FIXEDLEN)
1133 info->db_RE_bval = (u_char) ' ' ;
1135 info->db_RE_bval = (u_char) '\n' ;
1136 DB_flags(info->flags, DB_DELIMITER) ;
1141 info->flags |= DB_RENUMBER ;
1147 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1151 /* OS2 Specific Code */
1155 #endif /* __EMX__ */
1158 #ifdef DB_VERSION_MAJOR
1164 /* Map 1.x flags to 2.x flags */
1165 if ((flags & O_CREAT) == O_CREAT)
1166 Flags |= DB_CREATE ;
1169 if (flags == O_RDONLY)
1171 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1173 Flags |= DB_RDONLY ;
1176 if ((flags & O_TRUNC) == O_TRUNC)
1177 Flags |= DB_TRUNCATE ;
1180 status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
1182 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
1183 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
1185 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1190 RETVAL->dbp = NULL ;
1195 #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
1196 RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ;
1198 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
1199 #endif /* DB_LIBRARY_COMPATIBILITY_API */
1205 #else /* Berkeley DB Version > 2 */
1209 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
1215 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
1216 Zero(RETVAL, 1, DB_File_type) ;
1218 /* Default to HASH */
1219 RETVAL->filtering = 0 ;
1220 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
1221 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
1222 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
1223 RETVAL->type = DB_HASH ;
1225 /* DGH - Next line added to avoid SEGV on existing hash DB */
1228 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
1229 RETVAL->in_memory = (name == NULL) ;
1231 status = db_create(&RETVAL->dbp, NULL,0) ;
1232 /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
1234 RETVAL->dbp = NULL ;
1242 croak ("type parameter is not a reference") ;
1244 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
1245 if (svp && SvOK(*svp))
1246 action = (HV*) SvRV(*svp) ;
1248 croak("internal error") ;
1250 if (sv_isa(sv, "DB_File::HASHINFO"))
1254 croak("DB_File can only tie an associative array to a DB_HASH database") ;
1256 RETVAL->type = DB_HASH ;
1258 svp = hv_fetch(action, "hash", 4, FALSE);
1260 if (svp && SvOK(*svp))
1262 (void)dbp->set_h_hash(dbp, hash_cb) ;
1263 RETVAL->hash = newSVsv(*svp) ;
1266 svp = hv_fetch(action, "ffactor", 7, FALSE);
1268 (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ;
1270 svp = hv_fetch(action, "nelem", 5, FALSE);
1272 (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
1274 svp = hv_fetch(action, "bsize", 5, FALSE);
1276 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
1278 svp = hv_fetch(action, "cachesize", 9, FALSE);
1280 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1282 svp = hv_fetch(action, "lorder", 6, FALSE);
1284 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1288 else if (sv_isa(sv, "DB_File::BTREEINFO"))
1291 croak("DB_File can only tie an associative array to a DB_BTREE database");
1293 RETVAL->type = DB_BTREE ;
1295 svp = hv_fetch(action, "compare", 7, FALSE);
1296 if (svp && SvOK(*svp))
1298 (void)dbp->set_bt_compare(dbp, btree_compare) ;
1299 RETVAL->compare = newSVsv(*svp) ;
1302 svp = hv_fetch(action, "prefix", 6, FALSE);
1303 if (svp && SvOK(*svp))
1305 (void)dbp->set_bt_prefix(dbp, btree_prefix) ;
1306 RETVAL->prefix = newSVsv(*svp) ;
1309 svp = hv_fetch(action, "flags", 5, FALSE);
1311 (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ;
1313 svp = hv_fetch(action, "cachesize", 9, FALSE);
1315 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1317 svp = hv_fetch(action, "psize", 5, FALSE);
1319 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1321 svp = hv_fetch(action, "lorder", 6, FALSE);
1323 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1328 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1333 croak("DB_File can only tie an array to a DB_RECNO database");
1335 RETVAL->type = DB_RECNO ;
1337 svp = hv_fetch(action, "flags", 5, FALSE);
1339 int flags = SvIV(*svp) ;
1340 /* remove FIXDLEN, if present */
1341 if (flags & DB_FIXEDLEN) {
1343 flags &= ~DB_FIXEDLEN ;
1347 svp = hv_fetch(action, "cachesize", 9, FALSE);
1349 status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1352 svp = hv_fetch(action, "psize", 5, FALSE);
1354 status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1357 svp = hv_fetch(action, "lorder", 6, FALSE);
1359 status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1362 svp = hv_fetch(action, "bval", 4, FALSE);
1363 if (svp && SvOK(*svp))
1367 value = (int)*SvPV(*svp, n_a) ;
1369 value = (int)SvIV(*svp) ;
1372 status = dbp->set_re_pad(dbp, value) ;
1375 status = dbp->set_re_delim(dbp, value) ;
1381 svp = hv_fetch(action, "reclen", 6, FALSE);
1383 u_int32_t len = my_SvUV32(*svp) ;
1384 status = dbp->set_re_len(dbp, len) ;
1389 status = dbp->set_re_source(dbp, name) ;
1393 svp = hv_fetch(action, "bfname", 6, FALSE);
1394 if (svp && SvOK(*svp)) {
1395 char * ptr = SvPV(*svp,n_a) ;
1396 name = (char*) n_a ? ptr : NULL ;
1402 status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
1405 (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
1410 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1414 u_int32_t Flags = 0 ;
1417 /* Map 1.x flags to 3.x flags */
1418 if ((flags & O_CREAT) == O_CREAT)
1419 Flags |= DB_CREATE ;
1422 if (flags == O_RDONLY)
1424 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1426 Flags |= DB_RDONLY ;
1429 if ((flags & O_TRUNC) == O_TRUNC)
1430 Flags |= DB_TRUNCATE ;
1433 #ifdef AT_LEAST_DB_4_1
1434 status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type,
1437 status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type,
1440 /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
1443 /* RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;*/
1445 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1447 /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
1451 RETVAL->dbp = NULL ;
1457 #endif /* Berkeley DB Version > 2 */
1459 } /* ParseOpenInfo */
1462 #include "constants.h"
1464 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
1466 INCLUDE: constants.xs
1473 /* SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; */
1475 __getBerkeleyDBInfo() ;
1478 empty.data = &zero ;
1479 empty.size = sizeof(recno_t) ;
1485 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1492 char * name = (char *) NULL ;
1493 SV * sv = (SV *) NULL ;
1496 if (items >= 3 && SvOK(ST(2)))
1497 name = (char*) SvPV(ST(2), n_a) ;
1502 RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1503 if (RETVAL->dbp == NULL) {
1518 Trace(("DESTROY %p\n", db));
1520 Trace(("DESTROY %p done\n", db));
1522 SvREFCNT_dec(db->hash) ;
1524 SvREFCNT_dec(db->compare) ;
1526 SvREFCNT_dec(db->prefix) ;
1527 if (db->filter_fetch_key)
1528 SvREFCNT_dec(db->filter_fetch_key) ;
1529 if (db->filter_store_key)
1530 SvREFCNT_dec(db->filter_store_key) ;
1531 if (db->filter_fetch_value)
1532 SvREFCNT_dec(db->filter_fetch_value) ;
1533 if (db->filter_store_value)
1534 SvREFCNT_dec(db->filter_store_value) ;
1536 #ifdef DB_VERSION_MAJOR
1543 db_DELETE(db, key, flags=0)
1565 RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1571 db_FETCH(db, key, flags=0)
1584 RETVAL = db_get(db, key, value, flags) ;
1585 ST(0) = sv_newmortal();
1586 OutputValue(ST(0), value)
1590 db_STORE(db, key, value, flags=0)
1615 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1616 ST(0) = sv_newmortal();
1617 OutputKey(ST(0), key) ;
1623 DBTKEY key = NO_INIT
1634 RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1635 ST(0) = sv_newmortal();
1636 OutputKey(ST(0), key) ;
1640 # These would be nice for RECNO
1660 #ifdef DB_VERSION_MAJOR
1661 /* get the first value */
1662 RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1667 for (i = items-1 ; i > 0 ; --i)
1669 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1670 value.data = SvPVbyte(ST(i), n_a) ;
1674 key.size = sizeof(int) ;
1675 #ifdef DB_VERSION_MAJOR
1676 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1678 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
1704 /* First get the final value */
1705 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1706 ST(0) = sv_newmortal();
1710 /* the call to del will trash value, so take a copy now */
1711 OutputValue(ST(0), value) ;
1712 RETVAL = db_del(db, key, R_CURSOR) ;
1714 sv_setsv(ST(0), &PL_sv_undef);
1734 /* get the first value */
1735 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1736 ST(0) = sv_newmortal();
1740 /* the call to del will trash value, so take a copy now */
1741 OutputValue(ST(0), value) ;
1742 RETVAL = db_del(db, key, R_CURSOR) ;
1744 sv_setsv (ST(0), &PL_sv_undef) ;
1767 /* Set the Cursor to the Last element */
1768 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1769 #ifndef DB_VERSION_MAJOR
1774 keyval = *(int*)key.data ;
1777 for (i = 1 ; i < items ; ++i)
1779 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1780 value.data = SvPVbyte(ST(i), n_a) ;
1783 key.data = &keyval ;
1784 key.size = sizeof(int) ;
1785 RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1799 ALIAS: FETCHSIZE = 1
1802 RETVAL = GetArrayLength(aTHX_ db) ;
1808 # Now provide an interface to the rest of the DB functionality
1812 db_del(db, key, flags=0)
1820 RETVAL = db_del(db, key, flags) ;
1821 #ifdef DB_VERSION_MAJOR
1824 else if (RETVAL == DB_NOTFOUND)
1832 db_get(db, key, value, flags=0)
1842 RETVAL = db_get(db, key, value, flags) ;
1843 #ifdef DB_VERSION_MAJOR
1846 else if (RETVAL == DB_NOTFOUND)
1854 db_put(db, key, value, flags=0)
1863 RETVAL = db_put(db, key, value, flags) ;
1864 #ifdef DB_VERSION_MAJOR
1867 else if (RETVAL == DB_KEYEXIST)
1872 key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1881 #ifdef DB_VERSION_MAJOR
1885 status = (db->in_memory
1887 : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1892 RETVAL = (db->in_memory
1894 : ((db->dbp)->fd)(db->dbp) ) ;
1900 db_sync(db, flags=0)
1907 RETVAL = db_sync(db, flags) ;
1908 #ifdef DB_VERSION_MAJOR
1917 db_seq(db, key, value, flags)
1927 RETVAL = db_seq(db, key, value, flags);
1928 #ifdef DB_VERSION_MAJOR
1931 else if (RETVAL == DB_NOTFOUND)
1940 filter_fetch_key(db, code)
1943 SV * RETVAL = &PL_sv_undef ;
1945 DBM_setFilter(db->filter_fetch_key, code) ;
1948 filter_store_key(db, code)
1951 SV * RETVAL = &PL_sv_undef ;
1953 DBM_setFilter(db->filter_store_key, code) ;
1956 filter_fetch_value(db, code)
1959 SV * RETVAL = &PL_sv_undef ;
1961 DBM_setFilter(db->filter_fetch_value, code) ;
1964 filter_store_value(db, code)
1967 SV * RETVAL = &PL_sv_undef ;
1969 DBM_setFilter(db->filter_store_value, code) ;