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