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