ext/DB_File/DB_File.xs

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