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