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