ext/DB_File/DB_File.xs

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