This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f417b22a4641e5867fbd0629b18244a3502a1168
[perl5.git] / cpan / DB_File / DB_File.xs
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-2016 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
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 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
466
467 #ifdef CAN_PROTOTYPE
468 extern void __getBerkeleyDBInfo(void);
469 #endif
470
471 /* Internal Global Data */
472
473 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION
474
475 typedef struct {
476     recno_t     x_Value; 
477     recno_t     x_zero;
478     DB_File     x_CurrentDB;
479     DBTKEY      x_empty;
480 } my_cxt_t;
481
482 START_MY_CXT
483
484 #define Value           (MY_CXT.x_Value)
485 #define zero            (MY_CXT.x_zero)
486 #define CurrentDB       (MY_CXT.x_CurrentDB)
487 #define empty           (MY_CXT.x_empty)
488
489 #define ERR_BUFF "DB_File::Error"
490
491 #ifdef DB_VERSION_MAJOR
492
493 static int
494 #ifdef CAN_PROTOTYPE
495 db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
496 #else
497 db_put(db, key, value, flags)
498 DB_File         db ;
499 DBTKEY          key ;
500 DBT             value ;
501 u_int           flags ;
502 #endif
503 {
504     int status ;
505
506     if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
507         DBC * temp_cursor ;
508         DBT l_key, l_value;
509         
510 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
511         if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
512 #else
513         if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
514 #endif
515             return (-1) ;
516
517         memset(&l_key, 0, sizeof(l_key));
518         l_key.data = key.data;
519         l_key.size = key.size;
520         memset(&l_value, 0, sizeof(l_value));
521         l_value.data = value.data;
522         l_value.size = value.size;
523
524         if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
525             (void)temp_cursor->c_close(temp_cursor);
526             return (-1);
527         }
528
529         status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
530         (void)temp_cursor->c_close(temp_cursor);
531             
532         return (status) ;
533     }   
534     
535     
536     if (flagSet(flags, R_CURSOR)) {
537         return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
538     }
539     if (flagSet(flags, R_SETCURSOR)) {
540         if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
541                 return -1 ;
542         return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
543     
544     }
545
546     return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
547
548 }
549
550 #endif /* DB_VERSION_MAJOR */
551
552 static void
553 tidyUp(DB_File db)
554 {
555     db->aborted = TRUE ;
556 }
557
558
559 static int
560
561 #ifdef AT_LEAST_DB_6_0
562 #ifdef CAN_PROTOTYPE
563 btree_compare(DB * db, const DBT *key1, const DBT *key2, size_t* locp)
564 #else
565 btree_compare(db, key1, key2, locp)
566 DB * db ;
567 const DBT * key1 ;
568 const DBT * key2 ;
569 size_t* locp;
570 #endif /* CAN_PROTOTYPE */
571
572 #else /* Berkeley DB < 6.0 */
573 #ifdef AT_LEAST_DB_3_2
574
575 #ifdef CAN_PROTOTYPE
576 btree_compare(DB * db, const DBT *key1, const DBT *key2)
577 #else
578 btree_compare(db, key1, key2)
579 DB * db ;
580 const DBT * key1 ;
581 const DBT * key2 ;
582 #endif /* CAN_PROTOTYPE */
583
584 #else /* Berkeley DB < 3.2 */
585
586 #ifdef CAN_PROTOTYPE
587 btree_compare(const DBT *key1, const DBT *key2)
588 #else
589 btree_compare(key1, key2)
590 const DBT * key1 ;
591 const DBT * key2 ;
592 #endif
593
594 #endif
595 #endif
596
597 {
598 #ifdef dTHX
599     dTHX;
600 #endif    
601     dSP ;
602     dMY_CXT ;
603     void * data1, * data2 ;
604     int retval ;
605     int count ;
606     
607 #ifdef AT_LEAST_DB_3_2
608     PERL_UNUSED_ARG(db);
609 #endif
610
611     if (CurrentDB->in_compare) {
612         tidyUp(CurrentDB);
613         croak ("DB_File btree_compare: recursion detected\n") ;
614     }
615
616     data1 = (char *) key1->data ;
617     data2 = (char *) key2->data ;
618
619 #ifndef newSVpvn
620     /* As newSVpv will assume that the data pointer is a null terminated C 
621        string if the size parameter is 0, make sure that data points to an 
622        empty string if the length is 0
623     */
624     if (key1->size == 0)
625         data1 = "" ; 
626     if (key2->size == 0)
627         data2 = "" ;
628 #endif  
629
630     ENTER ;
631     SAVETMPS;
632     SAVESPTR(CurrentDB);
633     CurrentDB->in_compare = FALSE;
634     SAVEINT(CurrentDB->in_compare);
635     CurrentDB->in_compare = TRUE;
636
637     PUSHMARK(SP) ;
638     EXTEND(SP,2) ;
639     PUSHs(sv_2mortal(newSVpvn((const char*)data1,key1->size)));
640     PUSHs(sv_2mortal(newSVpvn((const char*)data2,key2->size)));
641     PUTBACK ;
642
643     count = perl_call_sv(CurrentDB->compare, G_SCALAR); 
644
645     SPAGAIN ;
646
647     if (count != 1){
648         tidyUp(CurrentDB);
649         croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
650     }
651
652     retval = POPi ;
653
654     PUTBACK ;
655     FREETMPS ;
656     LEAVE ;
657
658     return (retval) ;
659
660 }
661
662 static DB_Prefix_t
663 #ifdef AT_LEAST_DB_3_2
664
665 #ifdef CAN_PROTOTYPE
666 btree_prefix(DB * db, const DBT *key1, const DBT *key2)
667 #else
668 btree_prefix(db, key1, key2)
669 Db * db ;
670 const DBT * key1 ;
671 const DBT * key2 ;
672 #endif
673
674 #else /* Berkeley DB < 3.2 */
675
676 #ifdef CAN_PROTOTYPE
677 btree_prefix(const DBT *key1, const DBT *key2)
678 #else
679 btree_prefix(key1, key2)
680 const DBT * key1 ;
681 const DBT * key2 ;
682 #endif
683
684 #endif
685 {
686 #ifdef dTHX
687     dTHX;
688 #endif    
689     dSP ;
690     dMY_CXT ;
691     char * data1, * data2 ;
692     int retval ;
693     int count ;
694     
695 #ifdef AT_LEAST_DB_3_2
696     PERL_UNUSED_ARG(db);
697 #endif
698
699     if (CurrentDB->in_prefix){
700         tidyUp(CurrentDB);
701         croak ("DB_File btree_prefix: recursion detected\n") ;
702     }
703
704     data1 = (char *) key1->data ;
705     data2 = (char *) key2->data ;
706
707 #ifndef newSVpvn
708     /* As newSVpv will assume that the data pointer is a null terminated C 
709        string if the size parameter is 0, make sure that data points to an 
710        empty string if the length is 0
711     */
712     if (key1->size == 0)
713         data1 = "" ;
714     if (key2->size == 0)
715         data2 = "" ;
716 #endif  
717
718     ENTER ;
719     SAVETMPS;
720     SAVESPTR(CurrentDB);
721     CurrentDB->in_prefix = FALSE;
722     SAVEINT(CurrentDB->in_prefix);
723     CurrentDB->in_prefix = TRUE;
724
725     PUSHMARK(SP) ;
726     EXTEND(SP,2) ;
727     PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
728     PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
729     PUTBACK ;
730
731     count = perl_call_sv(CurrentDB->prefix, G_SCALAR); 
732
733     SPAGAIN ;
734
735     if (count != 1){
736         tidyUp(CurrentDB);
737         croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
738     }
739  
740     retval = POPi ;
741  
742     PUTBACK ;
743     FREETMPS ;
744     LEAVE ;
745
746     return (retval) ;
747 }
748
749
750 #ifdef BERKELEY_DB_1
751 #    define HASH_CB_SIZE_TYPE size_t
752 #else
753 #    define HASH_CB_SIZE_TYPE u_int32_t
754 #endif
755
756 static DB_Hash_t
757 #ifdef AT_LEAST_DB_3_2
758
759 #ifdef CAN_PROTOTYPE
760 hash_cb(DB * db, const void *data, u_int32_t size)
761 #else
762 hash_cb(db, data, size)
763 DB * db ;
764 const void * data ;
765 HASH_CB_SIZE_TYPE size ;
766 #endif
767
768 #else /* Berkeley DB < 3.2 */
769
770 #ifdef CAN_PROTOTYPE
771 hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
772 #else
773 hash_cb(data, size)
774 const void * data ;
775 HASH_CB_SIZE_TYPE size ;
776 #endif
777
778 #endif
779 {
780 #ifdef dTHX
781     dTHX;
782 #endif    
783     dSP ;
784     dMY_CXT;
785     int retval = 0;
786     int count ;
787
788 #ifdef AT_LEAST_DB_3_2
789     PERL_UNUSED_ARG(db);
790 #endif
791
792     if (CurrentDB->in_hash){
793         tidyUp(CurrentDB);
794         croak ("DB_File hash callback: recursion detected\n") ;
795     }
796
797 #ifndef newSVpvn
798     if (size == 0)
799         data = "" ;
800 #endif  
801
802      /* DGH - Next two lines added to fix corrupted stack problem */
803     ENTER ;
804     SAVETMPS;
805     SAVESPTR(CurrentDB);
806     CurrentDB->in_hash = FALSE;
807     SAVEINT(CurrentDB->in_hash);
808     CurrentDB->in_hash = TRUE;
809
810     PUSHMARK(SP) ;
811
812
813     XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
814     PUTBACK ;
815
816     count = perl_call_sv(CurrentDB->hash, G_SCALAR); 
817
818     SPAGAIN ;
819
820     if (count != 1){
821         tidyUp(CurrentDB);
822         croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
823     }
824
825     retval = POPi ;
826
827     PUTBACK ;
828     FREETMPS ;
829     LEAVE ;
830
831     return (retval) ;
832 }
833
834 #ifdef WANT_ERROR
835
836 static void
837 #ifdef AT_LEAST_DB_4_3
838 db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
839 #else
840 db_errcall_cb(const char * db_errpfx, char * buffer)
841 #endif
842 {
843 #ifdef dTHX
844     dTHX;
845 #endif    
846     SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
847 #ifdef AT_LEAST_DB_4_3
848     PERL_UNUSED_ARG(dbenv);
849 #endif
850     if (sv) {
851         if (db_errpfx)
852             sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
853         else
854             sv_setpv(sv, buffer) ;
855     }
856
857 #endif
858
859 #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
860
861 static void
862 #ifdef CAN_PROTOTYPE
863 PrintHash(INFO *hash)
864 #else
865 PrintHash(hash)
866 INFO * hash ;
867 #endif
868 {
869     printf ("HASH Info\n") ;
870     printf ("  hash      = %s\n", 
871                 (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
872     printf ("  bsize     = %d\n", hash->db_HA_bsize) ;
873     printf ("  ffactor   = %d\n", hash->db_HA_ffactor) ;
874     printf ("  nelem     = %d\n", hash->db_HA_nelem) ;
875     printf ("  cachesize = %d\n", hash->db_HA_cachesize) ;
876     printf ("  lorder    = %d\n", hash->db_HA_lorder) ;
877
878 }
879
880 static void
881 #ifdef CAN_PROTOTYPE
882 PrintRecno(INFO *recno)
883 #else
884 PrintRecno(recno)
885 INFO * recno ;
886 #endif
887 {
888     printf ("RECNO Info\n") ;
889     printf ("  flags     = %d\n", recno->db_RE_flags) ;
890     printf ("  cachesize = %d\n", recno->db_RE_cachesize) ;
891     printf ("  psize     = %d\n", recno->db_RE_psize) ;
892     printf ("  lorder    = %d\n", recno->db_RE_lorder) ;
893     printf ("  reclen    = %lu\n", (unsigned long)recno->db_RE_reclen) ;
894     printf ("  bval      = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
895     printf ("  bfname    = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
896 }
897
898 static void
899 #ifdef CAN_PROTOTYPE
900 PrintBtree(INFO *btree)
901 #else
902 PrintBtree(btree)
903 INFO * btree ;
904 #endif
905 {
906     printf ("BTREE Info\n") ;
907     printf ("  compare    = %s\n", 
908                 (btree->db_BT_compare ? "redefined" : "default")) ;
909     printf ("  prefix     = %s\n", 
910                 (btree->db_BT_prefix ? "redefined" : "default")) ;
911     printf ("  flags      = %d\n", btree->db_BT_flags) ;
912     printf ("  cachesize  = %d\n", btree->db_BT_cachesize) ;
913     printf ("  psize      = %d\n", btree->db_BT_psize) ;
914 #ifndef DB_VERSION_MAJOR
915     printf ("  maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
916     printf ("  minkeypage = %d\n", btree->db_BT_minkeypage) ;
917 #endif
918     printf ("  lorder     = %d\n", btree->db_BT_lorder) ;
919 }
920
921 #else
922
923 #define PrintRecno(recno)
924 #define PrintHash(hash)
925 #define PrintBtree(btree)
926
927 #endif /* TRACE */
928
929
930 static I32
931 #ifdef CAN_PROTOTYPE
932 GetArrayLength(pTHX_ DB_File db)
933 #else
934 GetArrayLength(db)
935 DB_File db ;
936 #endif
937 {
938     DBT         key ;
939     DBT         value ;
940     int         RETVAL ;
941
942     DBT_clear(key) ;
943     DBT_clear(value) ;
944     RETVAL = do_SEQ(db, key, value, R_LAST) ;
945     if (RETVAL == 0)
946         RETVAL = *(I32 *)key.data ;
947     else /* No key means empty file */
948         RETVAL = 0 ;
949
950     return ((I32)RETVAL) ;
951 }
952
953 static recno_t
954 #ifdef CAN_PROTOTYPE
955 GetRecnoKey(pTHX_ DB_File db, I32 value)
956 #else
957 GetRecnoKey(db, value)
958 DB_File  db ;
959 I32      value ;
960 #endif
961 {
962     if (value < 0) {
963         /* Get the length of the array */
964         I32 length = GetArrayLength(aTHX_ db) ;
965
966         /* check for attempt to write before start of array */
967         if (length + value + 1 <= 0) {
968             tidyUp(db);
969             croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
970         }
971
972         value = length + value + 1 ;
973     }
974     else
975         ++ value ;
976
977     return value ;
978 }
979
980
981 static DB_File
982 #ifdef CAN_PROTOTYPE
983 ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
984 #else
985 ParseOpenInfo(isHASH, name, flags, mode, sv)
986 int    isHASH ;
987 char * name ;
988 int    flags ;
989 int    mode ;
990 SV *   sv ;
991 #endif
992 {
993
994 #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1  or 2 */
995
996     SV **       svp;
997     HV *        action ;
998     DB_File     RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
999     void *      openinfo = NULL ;
1000     INFO        * info  = &RETVAL->info ;
1001     STRLEN      n_a;
1002     dMY_CXT;
1003
1004 #ifdef TRACE    
1005     printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n", 
1006                     name, flags, mode, sv == NULL) ;  
1007 #endif
1008     Zero(RETVAL, 1, DB_File_type) ;
1009
1010     /* Default to HASH */
1011     RETVAL->filtering = 0 ;
1012     RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
1013     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
1014     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
1015     RETVAL->type = DB_HASH ;
1016
1017      /* DGH - Next line added to avoid SEGV on existing hash DB */
1018     CurrentDB = RETVAL; 
1019
1020     /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
1021     RETVAL->in_memory = (name == NULL) ;
1022
1023     if (sv)
1024     {
1025         if (! SvROK(sv) )
1026             croak ("type parameter is not a reference") ;
1027
1028         svp  = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
1029         if (svp && SvOK(*svp))
1030             action  = (HV*) SvRV(*svp) ;
1031         else
1032             croak("internal error") ;
1033
1034         if (sv_isa(sv, "DB_File::HASHINFO"))
1035         {
1036
1037             if (!isHASH)
1038                 croak("DB_File can only tie an associative array to a DB_HASH database") ;
1039
1040             RETVAL->type = DB_HASH ;
1041             openinfo = (void*)info ;
1042   
1043             svp = hv_fetch(action, "hash", 4, FALSE); 
1044
1045             if (svp && SvOK(*svp))
1046             {
1047                 info->db_HA_hash = hash_cb ;
1048                 RETVAL->hash = newSVsv(*svp) ;
1049             }
1050             else
1051                 info->db_HA_hash = NULL ;
1052
1053            svp = hv_fetch(action, "ffactor", 7, FALSE);
1054            info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
1055          
1056            svp = hv_fetch(action, "nelem", 5, FALSE);
1057            info->db_HA_nelem = svp ? SvIV(*svp) : 0;
1058          
1059            svp = hv_fetch(action, "bsize", 5, FALSE);
1060            info->db_HA_bsize = svp ? SvIV(*svp) : 0;
1061            
1062            svp = hv_fetch(action, "cachesize", 9, FALSE);
1063            info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
1064          
1065            svp = hv_fetch(action, "lorder", 6, FALSE);
1066            info->db_HA_lorder = svp ? SvIV(*svp) : 0;
1067
1068            PrintHash(info) ; 
1069         }
1070         else if (sv_isa(sv, "DB_File::BTREEINFO"))
1071         {
1072             if (!isHASH)
1073                 croak("DB_File can only tie an associative array to a DB_BTREE database");
1074
1075             RETVAL->type = DB_BTREE ;
1076             openinfo = (void*)info ;
1077    
1078             svp = hv_fetch(action, "compare", 7, FALSE);
1079             if (svp && SvOK(*svp))
1080             {
1081                 info->db_BT_compare = btree_compare ;
1082                 RETVAL->compare = newSVsv(*svp) ;
1083             }
1084             else
1085                 info->db_BT_compare = NULL ;
1086
1087             svp = hv_fetch(action, "prefix", 6, FALSE);
1088             if (svp && SvOK(*svp))
1089             {
1090                 info->db_BT_prefix = btree_prefix ;
1091                 RETVAL->prefix = newSVsv(*svp) ;
1092             }
1093             else
1094                 info->db_BT_prefix = NULL ;
1095
1096             svp = hv_fetch(action, "flags", 5, FALSE);
1097             info->db_BT_flags = svp ? SvIV(*svp) : 0;
1098    
1099             svp = hv_fetch(action, "cachesize", 9, FALSE);
1100             info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
1101          
1102 #ifndef DB_VERSION_MAJOR
1103             svp = hv_fetch(action, "minkeypage", 10, FALSE);
1104             info->btree.minkeypage = svp ? SvIV(*svp) : 0;
1105         
1106             svp = hv_fetch(action, "maxkeypage", 10, FALSE);
1107             info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
1108 #endif
1109
1110             svp = hv_fetch(action, "psize", 5, FALSE);
1111             info->db_BT_psize = svp ? SvIV(*svp) : 0;
1112          
1113             svp = hv_fetch(action, "lorder", 6, FALSE);
1114             info->db_BT_lorder = svp ? SvIV(*svp) : 0;
1115
1116             PrintBtree(info) ;
1117          
1118         }
1119         else if (sv_isa(sv, "DB_File::RECNOINFO"))
1120         {
1121             if (isHASH)
1122                 croak("DB_File can only tie an array to a DB_RECNO database");
1123
1124             RETVAL->type = DB_RECNO ;
1125             openinfo = (void *)info ;
1126
1127             info->db_RE_flags = 0 ;
1128
1129             svp = hv_fetch(action, "flags", 5, FALSE);
1130             info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
1131          
1132             svp = hv_fetch(action, "reclen", 6, FALSE);
1133             info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
1134          
1135             svp = hv_fetch(action, "cachesize", 9, FALSE);
1136             info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
1137          
1138             svp = hv_fetch(action, "psize", 5, FALSE);
1139             info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
1140          
1141             svp = hv_fetch(action, "lorder", 6, FALSE);
1142             info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
1143
1144 #ifdef DB_VERSION_MAJOR
1145             info->re_source = name ;
1146             name = NULL ;
1147 #endif
1148             svp = hv_fetch(action, "bfname", 6, FALSE); 
1149             if (svp && SvOK(*svp)) {
1150                 char * ptr = SvPV(*svp,n_a) ;
1151 #ifdef DB_VERSION_MAJOR
1152                 name = (char*) n_a ? ptr : NULL ;
1153 #else
1154                 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
1155 #endif
1156             }
1157             else
1158 #ifdef DB_VERSION_MAJOR
1159                 name = NULL ;
1160 #else
1161                 info->db_RE_bfname = NULL ;
1162 #endif
1163          
1164             svp = hv_fetch(action, "bval", 4, FALSE);
1165 #ifdef DB_VERSION_MAJOR
1166             if (svp && SvOK(*svp))
1167             {
1168                 int value ;
1169                 if (SvPOK(*svp))
1170                     value = (int)*SvPV(*svp, n_a) ;
1171                 else
1172                     value = SvIV(*svp) ;
1173
1174                 if (info->flags & DB_FIXEDLEN) {
1175                     info->re_pad = value ;
1176                     info->flags |= DB_PAD ;
1177                 }
1178                 else {
1179                     info->re_delim = value ;
1180                     info->flags |= DB_DELIMITER ;
1181                 }
1182
1183             }
1184 #else
1185             if (svp && SvOK(*svp))
1186             {
1187                 if (SvPOK(*svp))
1188                     info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
1189                 else
1190                     info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
1191                 DB_flags(info->flags, DB_DELIMITER) ;
1192
1193             }
1194             else
1195             {
1196                 if (info->db_RE_flags & R_FIXEDLEN)
1197                     info->db_RE_bval = (u_char) ' ' ;
1198                 else
1199                     info->db_RE_bval = (u_char) '\n' ;
1200                 DB_flags(info->flags, DB_DELIMITER) ;
1201             }
1202 #endif
1203
1204 #ifdef DB_RENUMBER
1205             info->flags |= DB_RENUMBER ;
1206 #endif
1207          
1208             PrintRecno(info) ;
1209         }
1210         else
1211             croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1212     }
1213
1214
1215     /* OS2 Specific Code */
1216 #ifdef OS2
1217 #ifdef __EMX__
1218     flags |= O_BINARY;
1219 #endif /* __EMX__ */
1220 #endif /* OS2 */
1221
1222 #ifdef DB_VERSION_MAJOR
1223
1224     {
1225         int             Flags = 0 ;
1226         int             status ;
1227
1228         /* Map 1.x flags to 2.x flags */
1229         if ((flags & O_CREAT) == O_CREAT)
1230             Flags |= DB_CREATE ;
1231
1232 #if O_RDONLY == 0
1233         if (flags == O_RDONLY)
1234 #else
1235         if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1236 #endif
1237             Flags |= DB_RDONLY ;
1238
1239 #ifdef O_TRUNC
1240         if ((flags & O_TRUNC) == O_TRUNC)
1241             Flags |= DB_TRUNCATE ;
1242 #endif
1243
1244         status = db_open(name, RETVAL->type, Flags, mode, NULL, (DB_INFO*)openinfo, &RETVAL->dbp) ; 
1245         if (status == 0)
1246 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
1247             status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
1248 #else
1249             status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1250                         0) ;
1251 #endif
1252
1253         if (status)
1254             RETVAL->dbp = NULL ;
1255
1256     }
1257 #else
1258
1259 #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
1260     RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; 
1261 #else    
1262     RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; 
1263 #endif /* DB_LIBRARY_COMPATIBILITY_API */
1264
1265 #endif
1266
1267     return (RETVAL) ;
1268
1269 #else /* Berkeley DB Version > 2 */
1270
1271     SV **       svp;
1272     HV *        action ;
1273     DB_File     RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
1274     DB *        dbp ;
1275     STRLEN      n_a;
1276     int         status ;
1277     dMY_CXT;
1278
1279 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */
1280     Zero(RETVAL, 1, DB_File_type) ;
1281
1282     /* Default to HASH */
1283     RETVAL->filtering = 0 ;
1284     RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
1285     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
1286     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
1287     RETVAL->type = DB_HASH ;
1288
1289      /* DGH - Next line added to avoid SEGV on existing hash DB */
1290     CurrentDB = RETVAL; 
1291
1292     /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
1293     RETVAL->in_memory = (name == NULL) ;
1294
1295     status = db_create(&RETVAL->dbp, NULL,0) ;
1296     /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
1297     if (status) {
1298         RETVAL->dbp = NULL ;
1299         return (RETVAL) ;
1300     }   
1301     dbp = RETVAL->dbp ;
1302
1303 #ifdef WANT_ERROR
1304             RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
1305 #endif
1306     if (sv)
1307     {
1308         if (! SvROK(sv) )
1309             croak ("type parameter is not a reference") ;
1310
1311         svp  = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
1312         if (svp && SvOK(*svp))
1313             action  = (HV*) SvRV(*svp) ;
1314         else
1315             croak("internal error") ;
1316
1317         if (sv_isa(sv, "DB_File::HASHINFO"))
1318         {
1319
1320             if (!isHASH)
1321                 croak("DB_File can only tie an associative array to a DB_HASH database") ;
1322
1323             RETVAL->type = DB_HASH ;
1324   
1325             svp = hv_fetch(action, "hash", 4, FALSE); 
1326
1327             if (svp && SvOK(*svp))
1328             {
1329                 (void)dbp->set_h_hash(dbp, hash_cb) ;
1330                 RETVAL->hash = newSVsv(*svp) ;
1331             }
1332
1333            svp = hv_fetch(action, "ffactor", 7, FALSE);
1334            if (svp)
1335                (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ;
1336          
1337            svp = hv_fetch(action, "nelem", 5, FALSE);
1338            if (svp)
1339                (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
1340          
1341            svp = hv_fetch(action, "bsize", 5, FALSE);
1342            if (svp)
1343                (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
1344            
1345            svp = hv_fetch(action, "cachesize", 9, FALSE);
1346            if (svp)
1347                (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1348          
1349            svp = hv_fetch(action, "lorder", 6, FALSE);
1350            if (svp)
1351                (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1352
1353            PrintHash(info) ; 
1354         }
1355         else if (sv_isa(sv, "DB_File::BTREEINFO"))
1356         {
1357             if (!isHASH)
1358                 croak("DB_File can only tie an associative array to a DB_BTREE database");
1359
1360             RETVAL->type = DB_BTREE ;
1361    
1362             svp = hv_fetch(action, "compare", 7, FALSE);
1363             if (svp && SvOK(*svp))
1364             {
1365                 (void)dbp->set_bt_compare(dbp, btree_compare) ;
1366                 RETVAL->compare = newSVsv(*svp) ;
1367             }
1368
1369             svp = hv_fetch(action, "prefix", 6, FALSE);
1370             if (svp && SvOK(*svp))
1371             {
1372                 (void)dbp->set_bt_prefix(dbp, btree_prefix) ;
1373                 RETVAL->prefix = newSVsv(*svp) ;
1374             }
1375
1376            svp = hv_fetch(action, "flags", 5, FALSE);
1377            if (svp)
1378                (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ;
1379    
1380            svp = hv_fetch(action, "cachesize", 9, FALSE);
1381            if (svp)
1382                (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1383          
1384            svp = hv_fetch(action, "psize", 5, FALSE);
1385            if (svp)
1386                (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1387          
1388            svp = hv_fetch(action, "lorder", 6, FALSE);
1389            if (svp)
1390                (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1391
1392             PrintBtree(info) ;
1393          
1394         }
1395         else if (sv_isa(sv, "DB_File::RECNOINFO"))
1396         {
1397             int fixed = FALSE ;
1398
1399             if (isHASH)
1400                 croak("DB_File can only tie an array to a DB_RECNO database");
1401
1402             RETVAL->type = DB_RECNO ;
1403
1404            svp = hv_fetch(action, "flags", 5, FALSE);
1405            if (svp) {
1406                 int flags = SvIV(*svp) ;
1407                 /* remove FIXDLEN, if present */
1408                 if (flags & DB_FIXEDLEN) {
1409                     fixed = TRUE ;
1410                     flags &= ~DB_FIXEDLEN ;
1411                 }
1412            }
1413
1414            svp = hv_fetch(action, "cachesize", 9, FALSE);
1415            if (svp) {
1416                status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
1417            }
1418          
1419            svp = hv_fetch(action, "psize", 5, FALSE);
1420            if (svp) {
1421                status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
1422             }
1423          
1424            svp = hv_fetch(action, "lorder", 6, FALSE);
1425            if (svp) {
1426                status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
1427            }
1428
1429             svp = hv_fetch(action, "bval", 4, FALSE);
1430             if (svp && SvOK(*svp))
1431             {
1432                 int value ;
1433                 if (SvPOK(*svp))
1434                     value = (int)*SvPV(*svp, n_a) ;
1435                 else
1436                     value = (int)SvIV(*svp) ;
1437
1438                 if (fixed) {
1439                     (void)dbp->set_re_pad(dbp, value) ;
1440                 }
1441                 else {
1442                     (void)dbp->set_re_delim(dbp, value) ;
1443                 }
1444
1445             }
1446
1447            if (fixed) {
1448                svp = hv_fetch(action, "reclen", 6, FALSE);
1449                if (svp) {
1450                    u_int32_t len =  my_SvUV32(*svp) ;
1451                    (void)dbp->set_re_len(dbp, len) ;
1452                }    
1453            }
1454          
1455             if (name != NULL) {
1456                 (void)dbp->set_re_source(dbp, name) ;
1457                 name = NULL ;
1458             }   
1459
1460             svp = hv_fetch(action, "bfname", 6, FALSE); 
1461             if (svp && SvOK(*svp)) {
1462                 char * ptr = SvPV(*svp,n_a) ;
1463                 name = (char*) n_a ? ptr : NULL ;
1464             }
1465             else
1466                 name = NULL ;
1467          
1468
1469             (void)dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
1470          
1471                 if (flags){
1472                     (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
1473                 }
1474             PrintRecno(info) ;
1475         }
1476         else
1477             croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1478     }
1479
1480     {
1481         u_int32_t       Flags = 0 ;
1482         int             status ;
1483
1484         /* Map 1.x flags to 3.x flags */
1485         if ((flags & O_CREAT) == O_CREAT)
1486             Flags |= DB_CREATE ;
1487
1488 #if O_RDONLY == 0
1489         if (flags == O_RDONLY)
1490 #else
1491         if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1492 #endif
1493             Flags |= DB_RDONLY ;
1494
1495 #ifdef O_TRUNC
1496         if ((flags & O_TRUNC) == O_TRUNC)
1497             Flags |= DB_TRUNCATE ;
1498 #endif
1499
1500 #ifdef AT_LEAST_DB_4_4
1501         /* need this for recno */
1502         if ((flags & O_TRUNC) == O_TRUNC)
1503             Flags |= DB_CREATE ;
1504 #endif
1505
1506 #ifdef AT_LEAST_DB_4_1
1507         status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, 
1508                                 Flags, mode) ; 
1509 #else
1510         status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, 
1511                                 Flags, mode) ; 
1512 #endif
1513         /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
1514
1515         if (status == 0) {
1516
1517             status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1518                         0) ;
1519             /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
1520         }
1521
1522         if (status)
1523         {
1524             db_close(RETVAL); /* close **dbp handle to prevent mem.leak */
1525             RETVAL->dbp = NULL ;
1526         }
1527
1528     }
1529
1530     return (RETVAL) ;
1531
1532 #endif /* Berkeley DB Version > 2 */
1533
1534 } /* ParseOpenInfo */
1535
1536
1537 #include "constants.h"   
1538
1539 MODULE = DB_File        PACKAGE = DB_File       PREFIX = db_
1540
1541 INCLUDE: constants.xs
1542
1543 BOOT:
1544   {
1545 #ifdef dTHX
1546     dTHX;
1547 #endif    
1548 #ifdef WANT_ERROR
1549     SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; 
1550 #endif
1551     MY_CXT_INIT;
1552 #ifdef WANT_ERROR
1553     PERL_UNUSED_VAR(sv_err); /* huh? we just retrieved it... */
1554 #endif
1555     __getBerkeleyDBInfo() ;
1556  
1557     DBT_clear(empty) ; 
1558     empty.data = &zero ;
1559     empty.size =  sizeof(recno_t) ;
1560   }
1561
1562
1563
1564 DB_File
1565 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1566         int             isHASH
1567         char *          dbtype
1568         int             flags
1569         int             mode
1570         CODE:
1571         {
1572             char *      name = (char *) NULL ; 
1573             SV *        sv = (SV *) NULL ; 
1574             STRLEN      n_a;
1575
1576             if (items >= 3 && SvOK(ST(2))) 
1577                 name = (char*) SvPV(ST(2), n_a) ; 
1578
1579             if (items == 6)
1580                 sv = ST(5) ;
1581
1582             RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1583             Trace(("db_DoTie_ %p\n", RETVAL));
1584             if (RETVAL->dbp == NULL) {
1585                 Safefree(RETVAL);
1586                 RETVAL = NULL ;
1587             }
1588         }
1589         OUTPUT: 
1590             RETVAL
1591
1592 int
1593 db_DESTROY(db)
1594         DB_File         db
1595         PREINIT:
1596           dMY_CXT;
1597         INIT:
1598           CurrentDB = db ;
1599           Trace(("DESTROY %p\n", db));
1600         CLEANUP:
1601           Trace(("DESTROY %p done\n", db));
1602           if (db->hash)
1603             SvREFCNT_dec(db->hash) ;
1604           if (db->compare)
1605             SvREFCNT_dec(db->compare) ;
1606           if (db->prefix)
1607             SvREFCNT_dec(db->prefix) ;
1608           if (db->filter_fetch_key)
1609             SvREFCNT_dec(db->filter_fetch_key) ;
1610           if (db->filter_store_key)
1611             SvREFCNT_dec(db->filter_store_key) ;
1612           if (db->filter_fetch_value)
1613             SvREFCNT_dec(db->filter_fetch_value) ;
1614           if (db->filter_store_value)
1615             SvREFCNT_dec(db->filter_store_value) ;
1616           safefree(db) ;
1617 #ifdef DB_VERSION_MAJOR
1618           if (RETVAL > 0)
1619             RETVAL = -1 ;
1620 #endif
1621
1622
1623 int
1624 db_DELETE(db, key, flags=0)
1625         DB_File         db
1626         DBTKEY          key
1627         u_int           flags
1628         PREINIT:
1629           dMY_CXT;
1630         INIT:
1631           (void)flags;
1632           CurrentDB = db ;
1633
1634
1635 int
1636 db_EXISTS(db, key)
1637         DB_File         db
1638         DBTKEY          key
1639         PREINIT:
1640           dMY_CXT;
1641         CODE:
1642         {
1643           DBT           value ;
1644         
1645           DBT_clear(value) ; 
1646           CurrentDB = db ;
1647           RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1648         }
1649         OUTPUT:
1650           RETVAL
1651
1652 void
1653 db_FETCH(db, key, flags=0)
1654         DB_File         db
1655         DBTKEY          key
1656         u_int           flags
1657         PREINIT:
1658           dMY_CXT ;
1659           int RETVAL ;
1660         CODE:
1661         {
1662             DBT         value ;
1663
1664             DBT_clear(value) ; 
1665             CurrentDB = db ;
1666             RETVAL = db_get(db, key, value, flags) ;
1667             ST(0) = sv_newmortal();
1668             OutputValue(ST(0), value)
1669         }
1670
1671 int
1672 db_STORE(db, key, value, flags=0)
1673         DB_File         db
1674         DBTKEY          key
1675         DBT             value
1676         u_int           flags
1677         PREINIT:
1678           dMY_CXT;
1679         INIT:
1680           (void)flags;
1681           CurrentDB = db ;
1682
1683
1684 void
1685 db_FIRSTKEY(db)
1686         DB_File         db
1687         PREINIT:
1688           dMY_CXT ;
1689           int RETVAL ;
1690         CODE:
1691         {
1692             DBTKEY      key ;
1693             DBT         value ;
1694
1695             DBT_clear(key) ; 
1696             DBT_clear(value) ; 
1697             CurrentDB = db ;
1698             RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1699             ST(0) = sv_newmortal();
1700             OutputKey(ST(0), key) ;
1701         }
1702
1703 void
1704 db_NEXTKEY(db, key)
1705         DB_File         db
1706         DBTKEY          key = NO_INIT
1707         PREINIT:
1708           dMY_CXT ;
1709           int RETVAL ;
1710         CODE:
1711         {
1712             DBT         value ;
1713
1714             DBT_clear(key) ; 
1715             DBT_clear(value) ; 
1716             CurrentDB = db ;
1717             RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1718             ST(0) = sv_newmortal();
1719             OutputKey(ST(0), key) ;
1720         }
1721
1722 #
1723 # These would be nice for RECNO
1724 #
1725
1726 int
1727 unshift(db, ...)
1728         DB_File         db
1729         ALIAS:          UNSHIFT = 1
1730         PREINIT:
1731           dMY_CXT;
1732         CODE:
1733         {
1734             DBTKEY      key ;
1735             DBT         value ;
1736             int         i ;
1737             int         One ;
1738             STRLEN      n_a;
1739
1740             DBT_clear(key) ; 
1741             DBT_clear(value) ; 
1742             CurrentDB = db ;
1743 #ifdef DB_VERSION_MAJOR
1744             /* get the first value */
1745             RETVAL = do_SEQ(db, key, value, DB_FIRST) ;  
1746             RETVAL = 0 ;
1747 #else
1748             RETVAL = -1 ;
1749 #endif
1750             for (i = items-1 ; i > 0 ; --i)
1751             {
1752                 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1753                 value.data = SvPVbyte(ST(i), n_a) ;
1754                 value.size = n_a ;
1755                 One = 1 ;
1756                 key.data = &One ;
1757                 key.size = sizeof(int) ;
1758 #ifdef DB_VERSION_MAJOR
1759                 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1760 #else
1761                 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
1762 #endif
1763                 if (RETVAL != 0)
1764                     break;
1765             }
1766         }
1767         OUTPUT:
1768             RETVAL
1769
1770 void
1771 pop(db)
1772         DB_File         db
1773         PREINIT:
1774           dMY_CXT;
1775         ALIAS:          POP = 1
1776         PREINIT:
1777           I32 RETVAL;
1778         CODE:
1779         {
1780             DBTKEY      key ;
1781             DBT         value ;
1782
1783             DBT_clear(key) ; 
1784             DBT_clear(value) ; 
1785             CurrentDB = db ;
1786
1787             /* First get the final value */
1788             RETVAL = do_SEQ(db, key, value, R_LAST) ;    
1789             ST(0) = sv_newmortal();
1790             /* Now delete it */
1791             if (RETVAL == 0)
1792             {
1793                 /* the call to del will trash value, so take a copy now */
1794                 OutputValue(ST(0), value) ;
1795                 RETVAL = db_del(db, key, R_CURSOR) ;
1796                 if (RETVAL != 0) 
1797                     sv_setsv(ST(0), &PL_sv_undef); 
1798             }
1799         }
1800
1801 void
1802 shift(db)
1803         DB_File         db
1804         PREINIT:
1805           dMY_CXT;
1806         ALIAS:          SHIFT = 1
1807         PREINIT:
1808           I32 RETVAL;
1809         CODE:
1810         {
1811             DBT         value ;
1812             DBTKEY      key ;
1813
1814             DBT_clear(key) ; 
1815             DBT_clear(value) ; 
1816             CurrentDB = db ;
1817             /* get the first value */
1818             RETVAL = do_SEQ(db, key, value, R_FIRST) ;   
1819             ST(0) = sv_newmortal();
1820             /* Now delete it */
1821             if (RETVAL == 0)
1822             {
1823                 /* the call to del will trash value, so take a copy now */
1824                 OutputValue(ST(0), value) ;
1825                 RETVAL = db_del(db, key, R_CURSOR) ;
1826                 if (RETVAL != 0)
1827                     sv_setsv (ST(0), &PL_sv_undef) ;
1828             }
1829         }
1830
1831
1832 I32
1833 push(db, ...)
1834         DB_File         db
1835         PREINIT:
1836           dMY_CXT;
1837         ALIAS:          PUSH = 1
1838         CODE:
1839         {
1840             DBTKEY      key ;
1841             DBT         value ;
1842             DB *        Db = db->dbp ;
1843             int         i ;
1844             STRLEN      n_a;
1845             int         keyval ;
1846
1847             DBT_flags(key) ; 
1848             DBT_flags(value) ; 
1849             CurrentDB = db ;
1850             /* Set the Cursor to the Last element */
1851             RETVAL = do_SEQ(db, key, value, R_LAST) ;
1852 #ifndef DB_VERSION_MAJOR                                    
1853             if (RETVAL >= 0)
1854 #endif      
1855             {
1856                 if (RETVAL == 0)
1857                     keyval = *(int*)key.data ;
1858                 else
1859                     keyval = 0 ;
1860                 for (i = 1 ; i < items ; ++i)
1861                 {
1862                     DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
1863                     value.data = SvPVbyte(ST(i), n_a) ;
1864                     value.size = n_a ;
1865                     ++ keyval ;
1866                     key.data = &keyval ;
1867                     key.size = sizeof(int) ;
1868                     RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1869                     if (RETVAL != 0)
1870                         break;
1871                 }
1872             }
1873         }
1874         OUTPUT:
1875             RETVAL
1876
1877 I32
1878 length(db)
1879         DB_File         db
1880         PREINIT:
1881           dMY_CXT;
1882         ALIAS:          FETCHSIZE = 1
1883         CODE:
1884             CurrentDB = db ;
1885             RETVAL = GetArrayLength(aTHX_ db) ;
1886         OUTPUT:
1887             RETVAL
1888
1889
1890 #
1891 # Now provide an interface to the rest of the DB functionality
1892 #
1893
1894 int
1895 db_del(db, key, flags=0)
1896         DB_File         db
1897         DBTKEY          key
1898         u_int           flags
1899         PREINIT:
1900           dMY_CXT;
1901         CODE:
1902           CurrentDB = db ;
1903           RETVAL = db_del(db, key, flags) ;
1904 #ifdef DB_VERSION_MAJOR
1905           if (RETVAL > 0)
1906             RETVAL = -1 ;
1907           else if (RETVAL == DB_NOTFOUND)
1908             RETVAL = 1 ;
1909 #endif
1910         OUTPUT:
1911           RETVAL
1912
1913
1914 int
1915 db_get(db, key, value, flags=0)
1916         DB_File         db
1917         DBTKEY          key
1918         DBT             value = NO_INIT
1919         u_int           flags
1920         PREINIT:
1921           dMY_CXT;
1922         CODE:
1923           CurrentDB = db ;
1924           DBT_clear(value) ; 
1925           RETVAL = db_get(db, key, value, flags) ;
1926 #ifdef DB_VERSION_MAJOR
1927           if (RETVAL > 0)
1928             RETVAL = -1 ;
1929           else if (RETVAL == DB_NOTFOUND)
1930             RETVAL = 1 ;
1931 #endif
1932         OUTPUT:
1933           RETVAL
1934           value
1935
1936 int
1937 db_put(db, key, value, flags=0)
1938         DB_File         db
1939         DBTKEY          key
1940         DBT             value
1941         u_int           flags
1942         PREINIT:
1943           dMY_CXT;
1944         CODE:
1945           CurrentDB = db ;
1946           RETVAL = db_put(db, key, value, flags) ;
1947 #ifdef DB_VERSION_MAJOR
1948           if (RETVAL > 0)
1949             RETVAL = -1 ;
1950           else if (RETVAL == DB_KEYEXIST)
1951             RETVAL = 1 ;
1952 #endif
1953         OUTPUT:
1954           RETVAL
1955           key           if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1956
1957 int
1958 db_fd(db)
1959         DB_File         db
1960         PREINIT:
1961           dMY_CXT ;
1962         CODE:
1963           CurrentDB = db ;
1964 #ifdef DB_VERSION_MAJOR
1965           RETVAL = -1 ;
1966           {
1967             int status = 0 ;
1968             status = (db->in_memory
1969                       ? -1 
1970                       : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1971             if (status != 0)
1972               RETVAL = -1 ;
1973           }
1974 #else
1975           RETVAL = (db->in_memory
1976                 ? -1 
1977                 : ((db->dbp)->fd)(db->dbp) ) ;
1978 #endif
1979         OUTPUT:
1980           RETVAL
1981
1982 int
1983 db_sync(db, flags=0)
1984         DB_File         db
1985         u_int           flags
1986         PREINIT:
1987           dMY_CXT;
1988         CODE:
1989           CurrentDB = db ;
1990           RETVAL = db_sync(db, flags) ;
1991 #ifdef DB_VERSION_MAJOR
1992           if (RETVAL > 0)
1993             RETVAL = -1 ;
1994 #endif
1995         OUTPUT:
1996           RETVAL
1997
1998
1999 int
2000 db_seq(db, key, value, flags)
2001         DB_File         db
2002         DBTKEY          key 
2003         DBT             value = NO_INIT
2004         u_int           flags
2005         PREINIT:
2006           dMY_CXT;
2007         CODE:
2008           CurrentDB = db ;
2009           DBT_clear(value) ; 
2010           RETVAL = db_seq(db, key, value, flags);
2011 #ifdef DB_VERSION_MAJOR
2012           if (RETVAL > 0)
2013             RETVAL = -1 ;
2014           else if (RETVAL == DB_NOTFOUND)
2015             RETVAL = 1 ;
2016 #endif
2017         OUTPUT:
2018           RETVAL
2019           key
2020           value
2021
2022 SV *
2023 filter_fetch_key(db, code)
2024         DB_File         db
2025         SV *            code
2026         SV *            RETVAL = &PL_sv_undef ;
2027         CODE:
2028             DBM_setFilter(db->filter_fetch_key, code) ;
2029
2030 SV *
2031 filter_store_key(db, code)
2032         DB_File         db
2033         SV *            code
2034         SV *            RETVAL = &PL_sv_undef ;
2035         CODE:
2036             DBM_setFilter(db->filter_store_key, code) ;
2037
2038 SV *
2039 filter_fetch_value(db, code)
2040         DB_File         db
2041         SV *            code
2042         SV *            RETVAL = &PL_sv_undef ;
2043         CODE:
2044             DBM_setFilter(db->filter_fetch_value, code) ;
2045
2046 SV *
2047 filter_store_value(db, code)
2048         DB_File         db
2049         SV *            code
2050         SV *            RETVAL = &PL_sv_undef ;
2051         CODE:
2052             DBM_setFilter(db->filter_store_value, code) ;
2053