ext/DB_File/DB_File.xs

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