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