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