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