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