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