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