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