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