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