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