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