ext/DB_File/DB_File.xs

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