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