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