1 /*
2
3 DB_File.xs -- Perl 5 interface to Berkeley DB
4
5 written by Paul Marquess <pmqs@cpan.org>
6 last modified 11th November 2005
7 version 1.814
8
9 All comments/suggestions/problems are welcome
10
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.
14
15 Changes:
16 0.1 - Initial Release
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
29 1.03 - Added EXISTS
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
33 Makefile.PL
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 &
80 libdb.a/so.
81 1.71 - Support for Berkeley DB version 3.
82 Support for Berkeley DB 2/3's backward compatability mode.
83 Rewrote push
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
87 with a win32 macro.
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
92 needed to be changed.
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.
97 Added lots of casts
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.
104 1.804 - no change.
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.
109 1.807 - no change
110 1.808 - leak fixed in ParseOpenInfo
111 1.809 - no change
112 1.810 - no change
113 1.811 - no change
114 1.812 - no change
115 1.813 - no change
116 1.814 - no change
117
118 */
119
120 #define PERL_NO_GET_CONTEXT
121 #include "EXTERN.h"
122 #include "perl.h"
123 #include "XSUB.h"
124
125 #ifdef _NOT_CORE
126 # include "ppport.h"
127 #endif
128
129 /* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
130 DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
131
132 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
133 * shortly #included by the <db.h>) __attribute__ to the possibly
134 * already defined __attribute__, for example by GNUC or by Perl. */
135
136 /* #if DB_VERSION_MAJOR_CFG < 2 */
137 #ifndef DB_VERSION_MAJOR
138 # undef __attribute__
139 #endif
140
141 #ifdef COMPAT185
142 # include <db_185.h>
143 #else
144 # include <db.h>
145 #endif
146
147 /* Wall starts with 5.7.x */
148
149 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
150
151 /* Since we dropped the gccish definition of __attribute__ we will want
152 * to redefine dNOOP, however (so that dTHX continues to work). Yes,
153 * all this means that we can't do attribute checking on the DB_File,
154 * boo, hiss. */
155 # ifndef DB_VERSION_MAJOR
156
157 # undef dNOOP
158 # define dNOOP extern int Perl___notused
159
160 /* Ditto for dXSARGS. */
161 # undef dXSARGS
162 # define dXSARGS \
163 dSP; dMARK; \
164 I32 ax = mark - PL_stack_base + 1; \
165 I32 items = sp - mark
166
167 # endif
168
169 /* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
170 # undef dXSI32
171 # define dXSI32 dNOOP
172
173 #endif /* Perl >= 5.7 */
174
175 #include <fcntl.h>
176
177 /* #define TRACE */
178
179 #ifdef TRACE
180 # define Trace(x) printf x
181 #else
182 # define Trace(x)
183 #endif
184
185
186 #define DBT_clear(x) Zero(&x, 1, DBT) ;
187
188 #ifdef DB_VERSION_MAJOR
189
190 #if DB_VERSION_MAJOR == 2
191 # define BERKELEY_DB_1_OR_2
192 #endif
193
194 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
195 # define AT_LEAST_DB_3_2
196 #endif
197
198 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3)
199 # define AT_LEAST_DB_3_3
200 #endif
201
202 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
203 # define AT_LEAST_DB_4_1
204 #endif
205
206 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 3)
207 # define AT_LEAST_DB_4_3
208 #endif
209
210 #ifdef AT_LEAST_DB_3_3
211 # define WANT_ERROR
212 #endif
213
214 /* map version 2 features & constants onto their version 1 equivalent */
215
216 #ifdef DB_Prefix_t
217 # undef DB_Prefix_t
218 #endif
219 #define DB_Prefix_t size_t
220
221 #ifdef DB_Hash_t
222 # undef DB_Hash_t
223 #endif
224 #define DB_Hash_t u_int32_t
225
226 /* DBTYPE stays the same */
227 /* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
228 #if DB_VERSION_MAJOR == 2
229 typedef DB_INFO INFO ;
230 #else /* DB_VERSION_MAJOR > 2 */
231 # define DB_FIXEDLEN (0x8000)
232 #endif /* DB_VERSION_MAJOR == 2 */
233
234 /* version 2 has db_recno_t in place of recno_t */
235 typedef db_recno_t recno_t;
236
237
238 #define R_CURSOR DB_SET_RANGE
239 #define R_FIRST DB_FIRST
240 #define R_IAFTER DB_AFTER
241 #define R_IBEFORE DB_BEFORE
242 #define R_LAST DB_LAST
243 #define R_NEXT DB_NEXT
244 #define R_NOOVERWRITE DB_NOOVERWRITE
245 #define R_PREV DB_PREV
246
247 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
248 # define R_SETCURSOR 0x800000
249 #else
250 # define R_SETCURSOR (-100)
251 #endif
252
253 #define R_RECNOSYNC 0
254 #define R_FIXEDLEN DB_FIXEDLEN
255 #define R_DUP DB_DUP
256
257
258 #define db_HA_hash h_hash
259 #define db_HA_ffactor h_ffactor
260 #define db_HA_nelem h_nelem
261 #define db_HA_bsize db_pagesize
262 #define db_HA_cachesize db_cachesize
263 #define db_HA_lorder db_lorder
264
265 #define db_BT_compare bt_compare
266 #define db_BT_prefix bt_prefix
267 #define db_BT_flags flags
268 #define db_BT_psize db_pagesize
269 #define db_BT_cachesize db_cachesize
270 #define db_BT_lorder db_lorder
271 #define db_BT_maxkeypage
272 #define db_BT_minkeypage
273
274
275 #define db_RE_reclen re_len
276 #define db_RE_flags flags
277 #define db_RE_bval re_pad
278 #define db_RE_bfname re_source
279 #define db_RE_psize db_pagesize
280 #define db_RE_cachesize db_cachesize
281 #define db_RE_lorder db_lorder
282
283 #define TXN NULL,
284
285 #define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
286
287
288 #define DBT_flags(x) x.flags = 0
289 #define DB_flags(x, v) x |= v
290
291 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
292 # define flagSet(flags, bitmask) ((flags) & (bitmask))
293 #else
294 # define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask))
295 #endif
296
297 #else /* db version 1.x */
298
299 #define BERKELEY_DB_1
300 #define BERKELEY_DB_1_OR_2
301
302 typedef union INFO {
303 HASHINFO hash ;
304 RECNOINFO recno ;
305 BTREEINFO btree ;
306 } INFO ;
307
308
309 #ifdef mDB_Prefix_t
310 # ifdef DB_Prefix_t
311 # undef DB_Prefix_t
312 # endif
313 # define DB_Prefix_t mDB_Prefix_t
314 #endif
315
316 #ifdef mDB_Hash_t
317 # ifdef DB_Hash_t
318 # undef DB_Hash_t
319 # endif
320 # define DB_Hash_t mDB_Hash_t
321 #endif
322
323 #define db_HA_hash hash.hash
324 #define db_HA_ffactor hash.ffactor
325 #define db_HA_nelem hash.nelem
326 #define db_HA_bsize hash.bsize
327 #define db_HA_cachesize hash.cachesize
328 #define db_HA_lorder hash.lorder
329
330 #define db_BT_compare btree.compare
331 #define db_BT_prefix btree.prefix
332 #define db_BT_flags btree.flags
333 #define db_BT_psize btree.psize
334 #define db_BT_cachesize btree.cachesize
335 #define db_BT_lorder btree.lorder
336 #define db_BT_maxkeypage btree.maxkeypage
337 #define db_BT_minkeypage btree.minkeypage
338
339 #define db_RE_reclen recno.reclen
340 #define db_RE_flags recno.flags
341 #define db_RE_bval recno.bval
342 #define db_RE_bfname recno.bfname
343 #define db_RE_psize recno.psize
344 #define db_RE_cachesize recno.cachesize
345 #define db_RE_lorder recno.lorder
346
347 #define TXN
348
349 #define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
350 #define DBT_flags(x)
351 #define DB_flags(x, v)
352 #define flagSet(flags, bitmask) ((flags) & (bitmask))
353
354 #endif /* db version 1 */
355
356
357
358 #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0)
359 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
360 #define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
361
362 #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
363 #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
364
365 #ifdef DB_VERSION_MAJOR
366 #define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\
367 (db->dbp->close)(db->dbp, 0) ))
368 #define db_close(db) ((db->dbp)->close)(db->dbp, 0)
369 #define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
370 ? ((db->cursor)->c_del)(db->cursor, 0) \
371 : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
372
373 #else /* ! DB_VERSION_MAJOR */
374
375 #define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp))
376 #define db_close(db) ((db->dbp)->close)(db->dbp)
377 #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
378 #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
379
380 #endif /* ! DB_VERSION_MAJOR */
381
382
383 #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
384
385 typedef struct {
386 DBTYPE type ;
387 DB * dbp ;
388 SV * compare ;
389 bool in_compare ;
390 SV * prefix ;
391 bool in_prefix ;
392 SV * hash ;
393 bool in_hash ;
394 bool aborted ;
395 int in_memory ;
396 #ifdef BERKELEY_DB_1_OR_2
397 INFO info ;
398 #endif
399 #ifdef DB_VERSION_MAJOR
400 DBC * cursor ;
401 #endif
402 SV * filter_fetch_key ;
403 SV * filter_store_key ;
404 SV * filter_fetch_value ;
405 SV * filter_store_value ;
406 int filtering ;
407
408 } DB_File_type;
409
410 typedef DB_File_type * DB_File ;
411 typedef DBT DBTKEY ;
412
413 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
414
415 #define OutputValue(arg, name) \
416 { if (RETVAL == 0) { \
417 SvGETMAGIC(arg) ; \
418 my_sv_setpvn(arg, name.data, name.size) ; \
419 TAINT; \
420 SvTAINTED_on(arg); \
421 SvUTF8_off(arg); \
422 DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
423 } \
424 }
425
426 #define OutputKey(arg, name) \
427 { if (RETVAL == 0) \
428 { \
429 SvGETMAGIC(arg) ; \
430 if (db->type != DB_RECNO) { \
431 my_sv_setpvn(arg, name.data, name.size); \
432 } \
433 else \
434 sv_setiv(arg, (I32)*(I32*)name.data - 1); \
435 TAINT; \
436 SvTAINTED_on(arg); \
437 SvUTF8_off(arg); \
438 DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
439 } \
440 }
441
442 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
443
444 #ifdef CAN_PROTOTYPE
445 extern void __getBerkeleyDBInfo(void);
446 #endif
447
448 /* Internal Global Data */
449
450 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION
451
452 typedef struct {
453 recno_t x_Value;
454 recno_t x_zero;
455 DB_File x_CurrentDB;
456 DBTKEY x_empty;
457 } my_cxt_t;
458
459 START_MY_CXT
460
461 #define Value (MY_CXT.x_Value)
462 #define zero (MY_CXT.x_zero)
463 #define CurrentDB (MY_CXT.x_CurrentDB)
464 #define empty (MY_CXT.x_empty)
465
466 #define ERR_BUFF "DB_File::Error"
467
468 #ifdef DB_VERSION_MAJOR
469
470 static int
471 #ifdef CAN_PROTOTYPE
db_put(DB_File db,DBTKEY key,DBT value,u_int flags)472 db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
473 #else
474 db_put(db, key, value, flags)
475 DB_File db ;
476 DBTKEY key ;
477 DBT value ;
478 u_int flags ;
479 #endif
480 {
481 int status ;
482
483 if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
484 DBC * temp_cursor ;
485 DBT l_key, l_value;
486
487 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
488 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
489 #else
490 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
491 #endif
492 return (-1) ;
493
494 memset(&l_key, 0, sizeof(l_key));
495 l_key.data = key.data;
496 l_key.size = key.size;
497 memset(&l_value, 0, sizeof(l_value));
498 l_value.data = value.data;
499 l_value.size = value.size;
500
501 if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
502 (void)temp_cursor->c_close(temp_cursor);
503 return (-1);
504 }
505
506 status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
507 (void)temp_cursor->c_close(temp_cursor);
508
509 return (status) ;
510 }
511
512
513 if (flagSet(flags, R_CURSOR)) {
514 return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
515 }
516
517 if (flagSet(flags, R_SETCURSOR)) {
518 if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
519 return -1 ;
520 return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
521
522 }
523
524 return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
525
526 }
527
528 #endif /* DB_VERSION_MAJOR */
529
530 static void
tidyUp(DB_File db)531 tidyUp(DB_File db)
532 {
533 db->aborted = TRUE ;
534 }
535
536
537 static int
538 #ifdef AT_LEAST_DB_3_2
539
540 #ifdef CAN_PROTOTYPE
btree_compare(DB * db,const DBT * key1,const DBT * key2)541 btree_compare(DB * db, const DBT *key1, const DBT *key2)
542 #else
543 btree_compare(db, key1, key2)
544 DB * db ;
545 const DBT * key1 ;
546 const DBT * key2 ;
547 #endif /* CAN_PROTOTYPE */
548
549 #else /* Berkeley DB < 3.2 */
550
551 #ifdef CAN_PROTOTYPE
552 btree_compare(const DBT *key1, const DBT *key2)
553 #else
554 btree_compare(key1, key2)
555 const DBT * key1 ;
556 const DBT * key2 ;
557 #endif
558
559 #endif
560
561 {
562 #ifdef dTHX
563 dTHX;
564 #endif
565 dSP ;
566 dMY_CXT ;
567 void * data1, * data2 ;
568 int retval ;
569 int count ;
570
571
572 if (CurrentDB->in_compare) {
573 tidyUp(CurrentDB);
574 croak ("DB_File btree_compare: recursion detected\n") ;
575 }
576
577 data1 = (char *) key1->data ;
578 data2 = (char *) key2->data ;
579
580 #ifndef newSVpvn
581 /* As newSVpv will assume that the data pointer is a null terminated C
582 string if the size parameter is 0, make sure that data points to an
583 empty string if the length is 0
584 */
585 if (key1->size == 0)
586 data1 = "" ;
587 if (key2->size == 0)
588 data2 = "" ;
589 #endif
590
591 ENTER ;
592 SAVETMPS;
593 SAVESPTR(CurrentDB);
594 CurrentDB->in_compare = FALSE;
595 SAVEINT(CurrentDB->in_compare);
596 CurrentDB->in_compare = TRUE;
597
598 PUSHMARK(SP) ;
599 EXTEND(SP,2) ;
600 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
601 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
602 PUTBACK ;
603
604 count = perl_call_sv(CurrentDB->compare, G_SCALAR);
605
606 SPAGAIN ;
607
608 if (count != 1){
609 tidyUp(CurrentDB);
610 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
611 }
612
613 retval = POPi ;
614
615 PUTBACK ;
616 FREETMPS ;
617 LEAVE ;
618
619 return (retval) ;
620
621 }
622
623 static DB_Prefix_t
624 #ifdef AT_LEAST_DB_3_2
625
626 #ifdef CAN_PROTOTYPE
btree_prefix(DB * db,const DBT * key1,const DBT * key2)627 btree_prefix(DB * db, const DBT *key1, const DBT *key2)
628 #else
629 btree_prefix(db, key1, key2)
630 Db * db ;
631 const DBT * key1 ;
632 const DBT * key2 ;
633 #endif
634
635 #else /* Berkeley DB < 3.2 */
636
637 #ifdef CAN_PROTOTYPE
638 btree_prefix(const DBT *key1, const DBT *key2)
639 #else
640 btree_prefix(key1, key2)
641 const DBT * key1 ;
642 const DBT * key2 ;
643 #endif
644
645 #endif
646 {
647 #ifdef dTHX
648 dTHX;
649 #endif
650 dSP ;
651 dMY_CXT ;
652 char * data1, * data2 ;
653 int retval ;
654 int count ;
655
656 if (CurrentDB->in_prefix){
657 tidyUp(CurrentDB);
658 croak ("DB_File btree_prefix: recursion detected\n") ;
659 }
660
661 data1 = (char *) key1->data ;
662 data2 = (char *) key2->data ;
663
664 #ifndef newSVpvn
665 /* As newSVpv will assume that the data pointer is a null terminated C
666 string if the size parameter is 0, make sure that data points to an
667 empty string if the length is 0
668 */
669 if (key1->size == 0)
670 data1 = "" ;
671 if (key2->size == 0)
672 data2 = "" ;
673 #endif
674
675 ENTER ;
676 SAVETMPS;
677 SAVESPTR(CurrentDB);
678 CurrentDB->in_prefix = FALSE;
679 SAVEINT(CurrentDB->in_prefix);
680 CurrentDB->in_prefix = TRUE;
681
682 PUSHMARK(SP) ;
683 EXTEND(SP,2) ;
684 PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
685 PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
686 PUTBACK ;
687
688 count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
689
690 SPAGAIN ;
691
692 if (count != 1){
693 tidyUp(CurrentDB);
694 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
695 }
696
697 retval = POPi ;
698
699 PUTBACK ;
700 FREETMPS ;
701 LEAVE ;
702
703 return (retval) ;
704 }
705
706
707 #ifdef BERKELEY_DB_1
708 # define HASH_CB_SIZE_TYPE size_t
709 #else
710 # define HASH_CB_SIZE_TYPE u_int32_t
711 #endif
712
713 static DB_Hash_t
714 #ifdef AT_LEAST_DB_3_2
715
716 #ifdef CAN_PROTOTYPE
hash_cb(DB * db,const void * data,u_int32_t size)717 hash_cb(DB * db, const void *data, u_int32_t size)
718 #else
719 hash_cb(db, data, size)
720 DB * db ;
721 const void * data ;
722 HASH_CB_SIZE_TYPE size ;
723 #endif
724
725 #else /* Berkeley DB < 3.2 */
726
727 #ifdef CAN_PROTOTYPE
728 hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
729 #else
730 hash_cb(data, size)
731 const void * data ;
732 HASH_CB_SIZE_TYPE size ;
733 #endif
734
735 #endif
736 {
737 #ifdef dTHX
738 dTHX;
739 #endif
740 dSP ;
741 dMY_CXT;
742 int retval = 0;
743 int count ;
744
745 if (CurrentDB->in_hash){
746 tidyUp(CurrentDB);
747 croak ("DB_File hash callback: recursion detected\n") ;
748 }
749
750 #ifndef newSVpvn
751 if (size == 0)
752 data = "" ;
753 #endif
754
755 /* DGH - Next two lines added to fix corrupted stack problem */
756 ENTER ;
757 SAVETMPS;
758 SAVESPTR(CurrentDB);
759 CurrentDB->in_hash = FALSE;
760 SAVEINT(CurrentDB->in_hash);
761 CurrentDB->in_hash = TRUE;
762
763 PUSHMARK(SP) ;
764
765
766 XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
767 PUTBACK ;
768
769 count = perl_call_sv(CurrentDB->hash, G_SCALAR);
770
771 SPAGAIN ;
772
773 if (count != 1){
774 tidyUp(CurrentDB);
775 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
776 }
777
778 retval = POPi ;
779
780 PUTBACK ;
781 FREETMPS ;
782 LEAVE ;
783
784 return (retval) ;
785 }
786
787 #ifdef WANT_ERROR
788
789 static void
790 #ifdef AT_LEAST_DB_4_3
db_errcall_cb(const DB_ENV * dbenv,const char * db_errpfx,const char * buffer)791 db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
792 #else
793 db_errcall_cb(const char * db_errpfx, char * buffer)
794 #endif
795 {
796 #ifdef dTHX
797 dTHX;
798 #endif
799 SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
800 if (sv) {
801 if (db_errpfx)
802 sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
803 else
804 sv_setpv(sv, buffer) ;
805 }
806 }
807 #endif
808
809 #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
810
811 static void
812 #ifdef CAN_PROTOTYPE
PrintHash(INFO * hash)813 PrintHash(INFO *hash)
814 #else
815 PrintHash(hash)
816 INFO * hash ;
817 #endif
818 {
819 printf ("HASH Info\n") ;
820 printf (" hash = %s\n",
821 (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
822 printf (" bsize = %d\n", hash->db_HA_bsize) ;
823 printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
824 printf (" nelem = %d\n", hash->db_HA_nelem) ;
825 printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
826 printf (" lorder = %d\n", hash->db_HA_lorder) ;
827
828 }
829
830 static void
831 #ifdef CAN_PROTOTYPE
PrintRecno(INFO * recno)832 PrintRecno(INFO *recno)
833 #else
834 PrintRecno(recno)
835 INFO * recno ;
836 #endif
837 {
838 printf ("RECNO Info\n") ;
839 printf (" flags = %d\n", recno->db_RE_flags) ;
840 printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
841 printf (" psize = %d\n", recno->db_RE_psize) ;
842 printf (" lorder = %d\n", recno->db_RE_lorder) ;
843 printf (" reclen = %lu\n", (unsigned long)recno->db_RE_reclen) ;
844 printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
845 printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
846 }
847
848 static void
849 #ifdef CAN_PROTOTYPE
PrintBtree(INFO * btree)850 PrintBtree(INFO *btree)
851 #else
852 PrintBtree(btree)
853 INFO * btree ;
854 #endif
855 {
856 printf ("BTREE Info\n") ;
857 printf (" compare = %s\n",
858 (btree->db_BT_compare ? "redefined" : "default")) ;
859 printf (" prefix = %s\n",
860 (btree->db_BT_prefix ? "redefined" : "default")) ;
861 printf (" flags = %d\n", btree->db_BT_flags) ;
862 printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
863 printf (" psize = %d\n", btree->db_BT_psize) ;
864 #ifndef DB_VERSION_MAJOR
865 printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
866 printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
867 #endif
868 printf (" lorder = %d\n", btree->db_BT_lorder) ;
869 }
870
871 #else
872
873 #define PrintRecno(recno)
874 #define PrintHash(hash)
875 #define PrintBtree(btree)
876
877 #endif /* TRACE */
878
879
880 static I32
881 #ifdef CAN_PROTOTYPE
GetArrayLength(pTHX_ DB_File db)882 GetArrayLength(pTHX_ DB_File db)
883 #else
884 GetArrayLength(db)
885 DB_File db ;
886 #endif
887 {
888 DBT key ;
889 DBT value ;
890 int RETVAL ;
891
892 DBT_clear(key) ;
893 DBT_clear(value) ;
894 RETVAL = do_SEQ(db, key, value, R_LAST) ;
895 if (RETVAL == 0)
896 RETVAL = *(I32 *)key.data ;
897 else /* No key means empty file */
898 RETVAL = 0 ;
899
900 return ((I32)RETVAL) ;
901 }
902
903 static recno_t
904 #ifdef CAN_PROTOTYPE
GetRecnoKey(pTHX_ DB_File db,I32 value)905 GetRecnoKey(pTHX_ DB_File db, I32 value)
906 #else
907 GetRecnoKey(db, value)
908 DB_File db ;
909 I32 value ;
910 #endif
911 {
912 if (value < 0) {
913 /* Get the length of the array */
914 I32 length = GetArrayLength(aTHX_ db) ;
915
916 /* check for attempt to write before start of array */
917 if (length + value + 1 <= 0) {
918 tidyUp(db);
919 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
920 }
921
922 value = length + value + 1 ;
923 }
924 else
925 ++ value ;
926
927 return value ;
928 }
929
930
931 static DB_File
932 #ifdef CAN_PROTOTYPE
ParseOpenInfo(pTHX_ int isHASH,char * name,int flags,int mode,SV * sv)933 ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
934 #else
935 ParseOpenInfo(isHASH, name, flags, mode, sv)
936 int isHASH ;
937 char * name ;
938 int flags ;
939 int mode ;
940 SV * sv ;
941 #endif
942 {
943
944 #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */
945
946 SV ** svp;
947 HV * action ;
948 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
949 void * openinfo = NULL ;
950 INFO * info = &RETVAL->info ;
951 STRLEN n_a;
952 dMY_CXT;
953
954 #ifdef TRACE
955 printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n",
956 name, flags, mode, sv == NULL) ;
957 #endif
958 Zero(RETVAL, 1, DB_File_type) ;
959
960 /* Default to HASH */
961 RETVAL->filtering = 0 ;
962 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
963 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
964 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
965 RETVAL->type = DB_HASH ;
966
967 /* DGH - Next line added to avoid SEGV on existing hash DB */
968 CurrentDB = RETVAL;
969
970 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
971 RETVAL->in_memory = (name == NULL) ;
972
973 if (sv)
974 {
975 if (! SvROK(sv) )
976 croak ("type parameter is not a reference") ;
977
978 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
979 if (svp && SvOK(*svp))
980 action = (HV*) SvRV(*svp) ;
981 else
982 croak("internal error") ;
983
984 if (sv_isa(sv, "DB_File::HASHINFO"))
985 {
986
987 if (!isHASH)
988 croak("DB_File can only tie an associative array to a DB_HASH database") ;
989
990 RETVAL->type = DB_HASH ;
991 openinfo = (void*)info ;
992
993 svp = hv_fetch(action, "hash", 4, FALSE);
994
995 if (svp && SvOK(*svp))
996 {
997 info->db_HA_hash = hash_cb ;
998 RETVAL->hash = newSVsv(*svp) ;
999 }
1000 else
1001 info->db_HA_hash = NULL ;
1002
1003 svp = hv_fetch(action, "ffactor", 7, FALSE);
1004 info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
1005
1006 svp = hv_fetch(action, "nelem", 5, FALSE);
1007 info->db_HA_nelem = svp ? SvIV(*svp) : 0;
1008
1009 svp = hv_fetch(action, "bsize", 5, FALSE);
1010 info->db_HA_bsize = svp ? SvIV(*svp) : 0;
1011
1012 svp = hv_fetch(action, "cachesize", 9, FALSE);
1013 info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
1014
1015 svp = hv_fetch(action, "lorder", 6, FALSE);
1016 info->db_HA_lorder = svp ? SvIV(*svp) : 0;
1017
1018 PrintHash(info) ;
1019 }
1020 else if (sv_isa(sv, "DB_File::BTREEINFO"))
1021 {
1022 if (!isHASH)
1023 croak("DB_File can only tie an associative array to a DB_BTREE database");
1024
1025 RETVAL->type = DB_BTREE ;
1026 openinfo = (void*)info ;
1027
1028 svp = hv_fetch(action, "compare", 7, FALSE);
1029 if (svp && SvOK(*svp))
1030 {
1031 info->db_BT_compare = btree_compare ;
1032 RETVAL->compare = newSVsv(*svp) ;
1033 }
1034 else
1035 info->db_BT_compare = NULL ;
1036
1037 svp = hv_fetch(action, "prefix", 6, FALSE);
1038 if (svp && SvOK(*svp))
1039 {
1040 info->db_BT_prefix = btree_prefix ;
1041 RETVAL->prefix = newSVsv(*svp) ;
1042 }
1043 else
1044 info->db_BT_prefix = NULL ;
1045
1046 svp = hv_fetch(action, "flags", 5, FALSE);
1047 info->db_BT_flags = svp ? SvIV(*svp) : 0;
1048
1049 svp = hv_fetch(action, "cachesize", 9, FALSE);
1050 info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
1051
1052 #ifndef DB_VERSION_MAJOR
1053 svp = hv_fetch(action, "minkeypage", 10, FALSE);
1054 info->btree.minkeypage = svp ? SvIV(*svp) : 0;
1055
1056 svp = hv_fetch(action, "maxkeypage", 10, FALSE);
1057 info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
1058 #endif
1059
1060 svp = hv_fetch(action, "psize", 5, FALSE);
1061 info->db_BT_psize = svp ? SvIV(*svp) : 0;
1062
1063 svp = hv_fetch(action, "lorder", 6, FALSE);
1064 info->db_BT_lorder = svp ? SvIV(*svp) : 0;
1065
1066 PrintBtree(info) ;
1067
1068 }
1069 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1070 {
1071 if (isHASH)
1072 croak("DB_File can only tie an array to a DB_RECNO database");
1073
1074 RETVAL->type = DB_RECNO ;
1075 openinfo = (void *)info ;
1076
1077 info->db_RE_flags = 0 ;
1078
1079 svp = hv_fetch(action, "flags", 5, FALSE);
1080 info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
1081
1082 svp = hv_fetch(action, "reclen", 6, FALSE);
1083 info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
1084
1085 svp = hv_fetch(action, "cachesize", 9, FALSE);
1086 info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
1087
1088 svp = hv_fetch(action, "psize", 5, FALSE);
1089 info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
1090
1091 svp = hv_fetch(action, "lorder", 6, FALSE);
1092 info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
1093
1094 #ifdef DB_VERSION_MAJOR
1095 info->re_source = name ;
1096 name = NULL ;
1097 #endif
1098 svp = hv_fetch(action, "bfname", 6, FALSE);
1099 if (svp && SvOK(*svp)) {
1100 char * ptr = SvPV(*svp,n_a) ;
1101 #ifdef DB_VERSION_MAJOR
1102 name = (char*) n_a ? ptr : NULL ;
1103 #else
1104 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
1105 #endif
1106 }
1107 else
1108 #ifdef DB_VERSION_MAJOR
1109 name = NULL ;
1110 #else
1111 info->db_RE_bfname = NULL ;
1112 #endif
1113
1114 svp = hv_fetch(action, "bval", 4, FALSE);
1115 #ifdef DB_VERSION_MAJOR
1116 if (svp && SvOK(*svp))
1117 {
1118 int value ;
1119 if (SvPOK(*svp))
1120 value = (int)*SvPV(*svp, n_a) ;
1121 else
1122 value = SvIV(*svp) ;
1123
1124 if (info->flags & DB_FIXEDLEN) {
1125 info->re_pad = value ;
1126 info->flags |= DB_PAD ;
1127 }
1128 else {
1129 info->re_delim = value ;
1130 info->flags |= DB_DELIMITER ;
1131 }
1132
1133 }
1134 #else
1135 if (svp && SvOK(*svp))
1136 {
1137 if (SvPOK(*svp))
1138 info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
1139 else
1140 info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
1141 DB_flags(info->flags, DB_DELIMITER) ;
1142
1143 }
1144 else
1145 {
1146 if (info->db_RE_flags & R_FIXEDLEN)
1147 info->db_RE_bval = (u_char) ' ' ;
1148 else
1149 info->db_RE_bval = (u_char) '\n' ;
1150 DB_flags(info->flags, DB_DELIMITER) ;
1151 }
1152 #endif
1153
1154 #ifdef DB_RENUMBER
1155 info->flags |= DB_RENUMBER ;
1156 #endif
1157
1158 PrintRecno(info) ;
1159 }
1160 else
1161 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1162 }
1163
1164
1165 /* OS2 Specific Code */
1166 #ifdef OS2
1167 #ifdef __EMX__
1168 flags |= O_BINARY;
1169 #endif /* __EMX__ */
1170 #endif /* OS2 */
1171
1172 #ifdef DB_VERSION_MAJOR
1173
1174 {
1175 int Flags = 0 ;
1176 int status ;
1177
1178 /* Map 1.x flags to 2.x flags */
1179 if ((flags & O_CREAT) == O_CREAT)
1180 Flags |= DB_CREATE ;
1181
1182 #if O_RDONLY == 0
1183 if (flags == O_RDONLY)
1184 #else
1185 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1186 #endif
1187 Flags |= DB_RDONLY ;
1188
1189 #ifdef O_TRUNC
1190 if ((flags & O_TRUNC) == O_TRUNC)
1191 Flags |= DB_TRUNCATE ;
1192 #endif
1193
1194 status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
1195 if (status == 0)
1196 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
1197 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
1198 #else
1199 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1200 0) ;
1201 #endif
1202
1203 if (status)
1204 RETVAL->dbp = NULL ;
1205
1206 }
1207 #else
1208
1209 #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
1210 RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ;
1211 #else
1212 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
1213 #endif /* DB_LIBRARY_COMPATIBILITY_API */
1214
1215 #endif
1216
1217 return (RETVAL) ;
1218
1219 #else /* Berkeley DB Version > 2 */
1220
1221 SV ** svp;
1222 HV * action ;
1223 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
1224 DB * dbp ;
1225 STRLEN n_a;
1226 int status ;
1227 dMY_CXT;
1228
1229 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
1230 Zero(RETVAL, 1, DB_File_type) ;
1231
1232 /* Default to HASH */
1233 RETVAL->filtering = 0 ;
1234 RETVAL->filter_fetch_key = RETVAL->filter_store_key =
1235 RETVAL->filter_fetch_value = RETVAL->filter_store_value =
1236 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
1237 RETVAL->type = DB_HASH ;
1238
1239 /* DGH - Next line added to avoid SEGV on existing hash DB */
1240 CurrentDB = RETVAL;
1241
1242 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
1243 RETVAL->in_memory = (name == NULL) ;
1244
1245 status = db_create(&RETVAL->dbp, NULL,0) ;
1246 /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
1247 if (status) {
1248 RETVAL->dbp = NULL ;
1249 return (RETVAL) ;
1250 }
1251 dbp = RETVAL->dbp ;
1252
1253 #ifdef WANT_ERROR
1254 RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
1255 #endif
1256 if (sv)
1257 {
1258 if (! SvROK(sv) )
1259 croak ("type parameter is not a reference") ;
1260
1261 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
1262 if (svp && SvOK(*svp))
1263 action = (HV*) SvRV(*svp) ;
1264 else
1265 croak("internal error") ;
1266
1267 if (sv_isa(sv, "DB_File::HASHINFO"))
1268 {
1269
1270 if (!isHASH)
1271 croak("DB_File can only tie an associative array to a DB_HASH database") ;
1272
1273 RETVAL->type = DB_HASH ;
1274
1275 svp = hv_fetch(action, "hash", 4, FALSE);
1276
1277 if (svp && SvOK(*svp))
1278 {
1279 (void)dbp->set_h_hash(dbp, hash_cb) ;
1280 RETVAL->hash = newSVsv(*svp) ;
1281 }
1282
1283 svp = hv_fetch(action, "ffactor", 7, FALSE);
1284 if (svp)
1285 (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ;
1286
1287 svp = hv_fetch(action, "nelem", 5, FALSE);
1288 if (svp)
1289 (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
1290
1291 svp = hv_fetch(action, "bsize", 5, FALSE);
1292 if (svp)
1293 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
1294
1295 svp = hv_fetch(action, "cachesize", 9, FALSE);
1296 if (svp)
1297 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1298
1299 svp = hv_fetch(action, "lorder", 6, FALSE);
1300 if (svp)
1301 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1302
1303 PrintHash(info) ;
1304 }
1305 else if (sv_isa(sv, "DB_File::BTREEINFO"))
1306 {
1307 if (!isHASH)
1308 croak("DB_File can only tie an associative array to a DB_BTREE database");
1309
1310 RETVAL->type = DB_BTREE ;
1311
1312 svp = hv_fetch(action, "compare", 7, FALSE);
1313 if (svp && SvOK(*svp))
1314 {
1315 (void)dbp->set_bt_compare(dbp, btree_compare) ;
1316 RETVAL->compare = newSVsv(*svp) ;
1317 }
1318
1319 svp = hv_fetch(action, "prefix", 6, FALSE);
1320 if (svp && SvOK(*svp))
1321 {
1322 (void)dbp->set_bt_prefix(dbp, btree_prefix) ;
1323 RETVAL->prefix = newSVsv(*svp) ;
1324 }
1325
1326 svp = hv_fetch(action, "flags", 5, FALSE);
1327 if (svp)
1328 (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ;
1329
1330 svp = hv_fetch(action, "cachesize", 9, FALSE);
1331 if (svp)
1332 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1333
1334 svp = hv_fetch(action, "psize", 5, FALSE);
1335 if (svp)
1336 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1337
1338 svp = hv_fetch(action, "lorder", 6, FALSE);
1339 if (svp)
1340 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1341
1342 PrintBtree(info) ;
1343
1344 }
1345 else if (sv_isa(sv, "DB_File::RECNOINFO"))
1346 {
1347 int fixed = FALSE ;
1348
1349 if (isHASH)
1350 croak("DB_File can only tie an array to a DB_RECNO database");
1351
1352 RETVAL->type = DB_RECNO ;
1353
1354 svp = hv_fetch(action, "flags", 5, FALSE);
1355 if (svp) {
1356 int flags = SvIV(*svp) ;
1357 /* remove FIXDLEN, if present */
1358 if (flags & DB_FIXEDLEN) {
1359 fixed = TRUE ;
1360 flags &= ~DB_FIXEDLEN ;
1361 }
1362 }
1363
1364 svp = hv_fetch(action, "cachesize", 9, FALSE);
1365 if (svp) {
1366 status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1367 }
1368
1369 svp = hv_fetch(action, "psize", 5, FALSE);
1370 if (svp) {
1371 status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1372 }
1373
1374 svp = hv_fetch(action, "lorder", 6, FALSE);
1375 if (svp) {
1376 status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1377 }
1378
1379 svp = hv_fetch(action, "bval", 4, FALSE);
1380 if (svp && SvOK(*svp))
1381 {
1382 int value ;
1383 if (SvPOK(*svp))
1384 value = (int)*SvPV(*svp, n_a) ;
1385 else
1386 value = (int)SvIV(*svp) ;
1387
1388 if (fixed) {
1389 status = dbp->set_re_pad(dbp, value) ;
1390 }
1391 else {
1392 status = dbp->set_re_delim(dbp, value) ;
1393 }
1394
1395 }
1396
1397 if (fixed) {
1398 svp = hv_fetch(action, "reclen", 6, FALSE);
1399 if (svp) {
1400 u_int32_t len = my_SvUV32(*svp) ;
1401 status = dbp->set_re_len(dbp, len) ;
1402 }
1403 }
1404
1405 if (name != NULL) {
1406 status = dbp->set_re_source(dbp, name) ;
1407 name = NULL ;
1408 }
1409
1410 svp = hv_fetch(action, "bfname", 6, FALSE);
1411 if (svp && SvOK(*svp)) {
1412 char * ptr = SvPV(*svp,n_a) ;
1413 name = (char*) n_a ? ptr : NULL ;
1414 }
1415 else
1416 name = NULL ;
1417
1418
1419 status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
1420
1421 if (flags){
1422 (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
1423 }
1424 PrintRecno(info) ;
1425 }
1426 else
1427 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1428 }
1429
1430 {
1431 u_int32_t Flags = 0 ;
1432 int status ;
1433
1434 /* Map 1.x flags to 3.x flags */
1435 if ((flags & O_CREAT) == O_CREAT)
1436 Flags |= DB_CREATE ;
1437
1438 #if O_RDONLY == 0
1439 if (flags == O_RDONLY)
1440 #else
1441 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1442 #endif
1443 Flags |= DB_RDONLY ;
1444
1445 #ifdef O_TRUNC
1446 if ((flags & O_TRUNC) == O_TRUNC)
1447 Flags |= DB_TRUNCATE ;
1448 #endif
1449
1450 #ifdef AT_LEAST_DB_4_4
1451 /* need this for recno */
1452 if ((flags & O_TRUNC) == O_TRUNC)
1453 Flags |= DB_CREATE ;
1454 #endif
1455
1456 #ifdef AT_LEAST_DB_4_1
1457 status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type,
1458 Flags, mode) ;
1459 #else
1460 status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type,
1461 Flags, mode) ;
1462 #endif
1463 /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
1464
1465 if (status == 0) {
1466
1467 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1468 0) ;
1469 /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
1470 }
1471
1472 if (status)
1473 RETVAL->dbp = NULL ;
1474
1475 }
1476
1477 return (RETVAL) ;
1478
1479 #endif /* Berkeley DB Version > 2 */
1480
1481 } /* ParseOpenInfo */
1482
1483
1484 #include "constants.h"
1485
1486 MODULE = DB_File PACKAGE = DB_File PREFIX = db_
1487
1488 INCLUDE: constants.xs
1489
1490 BOOT:
1491 {
1492 #ifdef dTHX
1493 dTHX;
1494 #endif
1495 #ifdef WANT_ERROR
1496 SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
1497 #endif
1498 MY_CXT_INIT;
1499 __getBerkeleyDBInfo() ;
1500
1501 DBT_clear(empty) ;
1502 empty.data = &zero ;
1503 empty.size = sizeof(recno_t) ;
1504 }
1505
1506
1507
1508 DB_File
1509 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1510 int isHASH
1511 char * dbtype
1512 int flags
1513 int mode
1514 CODE:
1515 {
1516 char * name = (char *) NULL ;
1517 SV * sv = (SV *) NULL ;
1518 STRLEN n_a;
1519
1520 if (items >= 3 && SvOK(ST(2)))
1521 name = (char*) SvPV(ST(2), n_a) ;
1522
1523 if (items == 6)
1524 sv = ST(5) ;
1525
1526 RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1527 if (RETVAL->dbp == NULL) {
1528 Safefree(RETVAL);
1529 RETVAL = NULL ;
1530 }
1531 }
1532 OUTPUT:
1533 RETVAL
1534
1535 int
1536 db_DESTROY(db)
1537 DB_File db
1538 PREINIT:
1539 dMY_CXT;
1540 INIT:
1541 CurrentDB = db ;
1542 Trace(("DESTROY %p\n", db));
1543 CLEANUP:
1544 Trace(("DESTROY %p done\n", db));
1545 if (db->hash)
1546 SvREFCNT_dec(db->hash) ;
1547 if (db->compare)
1548 SvREFCNT_dec(db->compare) ;
1549 if (db->prefix)
1550 SvREFCNT_dec(db->prefix) ;
1551 if (db->filter_fetch_key)
1552 SvREFCNT_dec(db->filter_fetch_key) ;
1553 if (db->filter_store_key)
1554 SvREFCNT_dec(db->filter_store_key) ;
1555 if (db->filter_fetch_value)
1556 SvREFCNT_dec(db->filter_fetch_value) ;
1557 if (db->filter_store_value)
1558 SvREFCNT_dec(db->filter_store_value) ;
1559 safefree(db) ;
1560 #ifdef DB_VERSION_MAJOR
1561 if (RETVAL > 0)
1562 RETVAL = -1 ;
1563 #endif
1564
1565
1566 int
1567 db_DELETE(db, key, flags=0)
1568 DB_File db
1569 DBTKEY key
1570 u_int flags
1571 PREINIT:
1572 dMY_CXT;
1573 INIT:
1574 CurrentDB = db ;
1575
1576
1577 int
db_EXISTS(db,key)1578 db_EXISTS(db, key)
1579 DB_File db
1580 DBTKEY key
1581 PREINIT:
1582 dMY_CXT;
1583 CODE:
1584 {
1585 DBT value ;
1586
1587 DBT_clear(value) ;
1588 CurrentDB = db ;
1589 RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1590 }
1591 OUTPUT:
1592 RETVAL
1593
1594 void
1595 db_FETCH(db, key, flags=0)
1596 DB_File db
1597 DBTKEY key
1598 u_int flags
1599 PREINIT:
1600 dMY_CXT ;
1601 int RETVAL ;
1602 CODE:
1603 {
1604 DBT value ;
1605
1606 DBT_clear(value) ;
1607 CurrentDB = db ;
1608 RETVAL = db_get(db, key, value, flags) ;
1609 ST(0) = sv_newmortal();
1610 OutputValue(ST(0), value)
1611 }
1612
1613 int
1614 db_STORE(db, key, value, flags=0)
1615 DB_File db
1616 DBTKEY key
1617 DBT value
1618 u_int flags
1619 PREINIT:
1620 dMY_CXT;
1621 INIT:
1622 CurrentDB = db ;
1623
1624
1625 void
1626 db_FIRSTKEY(db)
1627 DB_File db
1628 PREINIT:
1629 dMY_CXT ;
1630 int RETVAL ;
1631 CODE:
1632 {
1633 DBTKEY key ;
1634 DBT value ;
1635
1636 DBT_clear(key) ;
1637 DBT_clear(value) ;
1638 CurrentDB = db ;
1639 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1640 ST(0) = sv_newmortal();
1641 OutputKey(ST(0), key) ;
1642 }
1643
1644 void
1645 db_NEXTKEY(db, key)
1646 DB_File db
1647 DBTKEY key = NO_INIT
1648 PREINIT:
1649 dMY_CXT ;
1650 int RETVAL ;
1651 CODE:
1652 {
1653 DBT value ;
1654
1655 DBT_clear(key) ;
1656 DBT_clear(value) ;
1657 CurrentDB = db ;
1658 RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1659 ST(0) = sv_newmortal();
1660 OutputKey(ST(0), key) ;
1661 }
1662
1663 #
1664 # These would be nice for RECNO
1665 #
1666
1667 int
1668 unshift(db, ...)
1669 DB_File db
1670 ALIAS: UNSHIFT = 1
1671 PREINIT:
1672 dMY_CXT;
1673 CODE:
1674 {
1675 DBTKEY key ;
1676 DBT value ;
1677 int i ;
1678 int One ;
1679 STRLEN n_a;
1680
1681 DBT_clear(key) ;
1682 DBT_clear(value) ;
1683 CurrentDB = db ;
1684 #ifdef DB_VERSION_MAJOR
1685 /* get the first value */
1686 RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1687 RETVAL = 0 ;
1688 #else
1689 RETVAL = -1 ;
1690 #endif
1691 for (i = items-1 ; i > 0 ; --i)
1692 {
1693 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1694 value.data = SvPVbyte(ST(i), n_a) ;
1695 value.size = n_a ;
1696 One = 1 ;
1697 key.data = &One ;
1698 key.size = sizeof(int) ;
1699 #ifdef DB_VERSION_MAJOR
1700 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1701 #else
1702 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
1703 #endif
1704 if (RETVAL != 0)
1705 break;
1706 }
1707 }
1708 OUTPUT:
1709 RETVAL
1710
1711 void
1712 pop(db)
1713 DB_File db
1714 PREINIT:
1715 dMY_CXT;
1716 ALIAS: POP = 1
1717 PREINIT:
1718 I32 RETVAL;
1719 CODE:
1720 {
1721 DBTKEY key ;
1722 DBT value ;
1723
1724 DBT_clear(key) ;
1725 DBT_clear(value) ;
1726 CurrentDB = db ;
1727
1728 /* First get the final value */
1729 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1730 ST(0) = sv_newmortal();
1731 /* Now delete it */
1732 if (RETVAL == 0)
1733 {
1734 /* the call to del will trash value, so take a copy now */
1735 OutputValue(ST(0), value) ;
1736 RETVAL = db_del(db, key, R_CURSOR) ;
1737 if (RETVAL != 0)
1738 sv_setsv(ST(0), &PL_sv_undef);
1739 }
1740 }
1741
1742 void
1743 shift(db)
1744 DB_File db
1745 PREINIT:
1746 dMY_CXT;
1747 ALIAS: SHIFT = 1
1748 PREINIT:
1749 I32 RETVAL;
1750 CODE:
1751 {
1752 DBT value ;
1753 DBTKEY key ;
1754
1755 DBT_clear(key) ;
1756 DBT_clear(value) ;
1757 CurrentDB = db ;
1758 /* get the first value */
1759 RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1760 ST(0) = sv_newmortal();
1761 /* Now delete it */
1762 if (RETVAL == 0)
1763 {
1764 /* the call to del will trash value, so take a copy now */
1765 OutputValue(ST(0), value) ;
1766 RETVAL = db_del(db, key, R_CURSOR) ;
1767 if (RETVAL != 0)
1768 sv_setsv (ST(0), &PL_sv_undef) ;
1769 }
1770 }
1771
1772
1773 I32
push(db,...)1774 push(db, ...)
1775 DB_File db
1776 PREINIT:
1777 dMY_CXT;
1778 ALIAS: PUSH = 1
1779 CODE:
1780 {
1781 DBTKEY key ;
1782 DBT value ;
1783 DB * Db = db->dbp ;
1784 int i ;
1785 STRLEN n_a;
1786 int keyval ;
1787
1788 DBT_flags(key) ;
1789 DBT_flags(value) ;
1790 CurrentDB = db ;
1791 /* Set the Cursor to the Last element */
1792 RETVAL = do_SEQ(db, key, value, R_LAST) ;
1793 #ifndef DB_VERSION_MAJOR
1794 if (RETVAL >= 0)
1795 #endif
1796 {
1797 if (RETVAL == 0)
1798 keyval = *(int*)key.data ;
1799 else
1800 keyval = 0 ;
1801 for (i = 1 ; i < items ; ++i)
1802 {
1803 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1804 value.data = SvPVbyte(ST(i), n_a) ;
1805 value.size = n_a ;
1806 ++ keyval ;
1807 key.data = &keyval ;
1808 key.size = sizeof(int) ;
1809 RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1810 if (RETVAL != 0)
1811 break;
1812 }
1813 }
1814 }
1815 OUTPUT:
1816 RETVAL
1817
1818 I32
1819 length(db)
1820 DB_File db
1821 PREINIT:
1822 dMY_CXT;
1823 ALIAS: FETCHSIZE = 1
1824 CODE:
1825 CurrentDB = db ;
1826 RETVAL = GetArrayLength(aTHX_ db) ;
1827 OUTPUT:
1828 RETVAL
1829
1830
1831 #
1832 # Now provide an interface to the rest of the DB functionality
1833 #
1834
1835 int
1836 db_del(db, key, flags=0)
1837 DB_File db
1838 DBTKEY key
1839 u_int flags
1840 PREINIT:
1841 dMY_CXT;
1842 CODE:
1843 CurrentDB = db ;
1844 RETVAL = db_del(db, key, flags) ;
1845 #ifdef DB_VERSION_MAJOR
1846 if (RETVAL > 0)
1847 RETVAL = -1 ;
1848 else if (RETVAL == DB_NOTFOUND)
1849 RETVAL = 1 ;
1850 #endif
1851 OUTPUT:
1852 RETVAL
1853
1854
1855 int
1856 db_get(db, key, value, flags=0)
1857 DB_File db
1858 DBTKEY key
1859 DBT value = NO_INIT
1860 u_int flags
1861 PREINIT:
1862 dMY_CXT;
1863 CODE:
1864 CurrentDB = db ;
1865 DBT_clear(value) ;
1866 RETVAL = db_get(db, key, value, flags) ;
1867 #ifdef DB_VERSION_MAJOR
1868 if (RETVAL > 0)
1869 RETVAL = -1 ;
1870 else if (RETVAL == DB_NOTFOUND)
1871 RETVAL = 1 ;
1872 #endif
1873 OUTPUT:
1874 RETVAL
1875 value
1876
1877 int
1878 db_put(db, key, value, flags=0)
1879 DB_File db
1880 DBTKEY key
1881 DBT value
1882 u_int flags
1883 PREINIT:
1884 dMY_CXT;
1885 CODE:
1886 CurrentDB = db ;
1887 RETVAL = db_put(db, key, value, flags) ;
1888 #ifdef DB_VERSION_MAJOR
1889 if (RETVAL > 0)
1890 RETVAL = -1 ;
1891 else if (RETVAL == DB_KEYEXIST)
1892 RETVAL = 1 ;
1893 #endif
1894 OUTPUT:
1895 RETVAL
1896 key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1897
1898 int
1899 db_fd(db)
1900 DB_File db
1901 PREINIT:
1902 dMY_CXT ;
1903 CODE:
1904 CurrentDB = db ;
1905 #ifdef DB_VERSION_MAJOR
1906 RETVAL = -1 ;
1907 {
1908 int status = 0 ;
1909 status = (db->in_memory
1910 ? -1
1911 : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1912 if (status != 0)
1913 RETVAL = -1 ;
1914 }
1915 #else
1916 RETVAL = (db->in_memory
1917 ? -1
1918 : ((db->dbp)->fd)(db->dbp) ) ;
1919 #endif
1920 OUTPUT:
1921 RETVAL
1922
1923 int
1924 db_sync(db, flags=0)
1925 DB_File db
1926 u_int flags
1927 PREINIT:
1928 dMY_CXT;
1929 CODE:
1930 CurrentDB = db ;
1931 RETVAL = db_sync(db, flags) ;
1932 #ifdef DB_VERSION_MAJOR
1933 if (RETVAL > 0)
1934 RETVAL = -1 ;
1935 #endif
1936 OUTPUT:
1937 RETVAL
1938
1939
1940 int
1941 db_seq(db, key, value, flags)
1942 DB_File db
1943 DBTKEY key
1944 DBT value = NO_INIT
1945 u_int flags
1946 PREINIT:
1947 dMY_CXT;
1948 CODE:
1949 CurrentDB = db ;
1950 DBT_clear(value) ;
1951 RETVAL = db_seq(db, key, value, flags);
1952 #ifdef DB_VERSION_MAJOR
1953 if (RETVAL > 0)
1954 RETVAL = -1 ;
1955 else if (RETVAL == DB_NOTFOUND)
1956 RETVAL = 1 ;
1957 #endif
1958 OUTPUT:
1959 RETVAL
1960 key
1961 value
1962
1963 SV *
1964 filter_fetch_key(db, code)
1965 DB_File db
1966 SV * code
1967 SV * RETVAL = &PL_sv_undef ;
1968 CODE:
1969 DBM_setFilter(db->filter_fetch_key, code) ;
1970
1971 SV *
1972 filter_store_key(db, code)
1973 DB_File db
1974 SV * code
1975 SV * RETVAL = &PL_sv_undef ;
1976 CODE:
1977 DBM_setFilter(db->filter_store_key, code) ;
1978
1979 SV *
1980 filter_fetch_value(db, code)
1981 DB_File db
1982 SV * code
1983 SV * RETVAL = &PL_sv_undef ;
1984 CODE:
1985 DBM_setFilter(db->filter_fetch_value, code) ;
1986
1987 SV *
1988 filter_store_value(db, code)
1989 DB_File db
1990 SV * code
1991 SV * RETVAL = &PL_sv_undef ;
1992 CODE:
1993 DBM_setFilter(db->filter_store_value, code) ;
1994
1995