cpan/DB_File/DB_File.xs

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