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