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