ext/DB_File/DB_File.xs

   1 /*
   2
   3  DB_File.xs -- Perl 5 interface to Berkeley DB
   4
   5  written by Paul Marquess <Paul.Marquess@btinternet.com>
   6  last modified 1st September 2002
   7  version 1.805
   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
 109 */
 110
 111 #define PERL_NO_GET_CONTEXT
 112 #include "EXTERN.h"
 113 #include "perl.h"
 114 #include "XSUB.h"
 115
 116 #ifdef _NOT_CORE
 117 #  include "ppport.h"
 118 #endif
 119
 120 /* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
 121    DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
 122
 123 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
 124  * shortly #included by the <db.h>) __attribute__ to the possibly
 125  * already defined __attribute__, for example by GNUC or by Perl. */
 126
 127 /* #if DB_VERSION_MAJOR_CFG < 2  */
 128 #ifndef DB_VERSION_MAJOR
 129 #    undef __attribute__
 130 #endif
 131
 132 #ifdef COMPAT185
 133 #    include <db_185.h>
 134 #else
 135 #    include <db.h>
 136 #endif
 137
 138 /* Wall starts with 5.7.x */
 139
 140 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
 141
 142 /* Since we dropped the gccish definition of __attribute__ we will want
 143  * to redefine dNOOP, however (so that dTHX continues to work).  Yes,
 144  * all this means that we can't do attribute checking on the DB_File,
 145  * boo, hiss. */
 146 #  ifndef DB_VERSION_MAJOR
 147
 148 #    undef  dNOOP
 149 #    define dNOOP extern int Perl___notused
 150
 151     /* Ditto for dXSARGS. */
 152 #    undef  dXSARGS
 153 #    define dXSARGS                             \
 154         dSP; dMARK;                     \
 155         I32 ax = mark - PL_stack_base + 1;      \
 156         I32 items = sp - mark
 157
 158 #  endif
 159
 160 /* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
 161 #  undef dXSI32
 162 #  define dXSI32 dNOOP
 163
 164 #endif /* Perl >= 5.7 */
 165
 166 #include <fcntl.h>
 167
 168 /* #define TRACE */
 169
 170 #ifdef TRACE
 171 #    define Trace(x)        printf x
 172 #else
 173 #    define Trace(x)
 174 #endif
 175
 176
 177 #define DBT_clear(x)    Zero(&x, 1, DBT) ;
 178
 179 #ifdef DB_VERSION_MAJOR
 180
 181 #if DB_VERSION_MAJOR == 2
 182 #    define BERKELEY_DB_1_OR_2
 183 #endif
 184
 185 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
 186 #    define AT_LEAST_DB_3_2
 187 #endif
 188
 189 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
 190 #    define AT_LEAST_DB_4_1
 191 #endif
 192
 193 /* map version 2 features & constants onto their version 1 equivalent */
 194
 195 #ifdef DB_Prefix_t
 196 #    undef DB_Prefix_t
 197 #endif
 198 #define DB_Prefix_t     size_t
 199
 200 #ifdef DB_Hash_t
 201 #    undef DB_Hash_t
 202 #endif
 203 #define DB_Hash_t       u_int32_t
 204
 205 /* DBTYPE stays the same */
 206 /* HASHINFO, RECNOINFO and BTREEINFO  map to DB_INFO */
 207 #if DB_VERSION_MAJOR == 2
 208     typedef DB_INFO     INFO ;
 209 #else /* DB_VERSION_MAJOR > 2 */
 210 #    define DB_FIXEDLEN (0x8000)
 211 #endif /* DB_VERSION_MAJOR == 2 */
 212
 213 /* version 2 has db_recno_t in place of recno_t */
 214 typedef db_recno_t      recno_t;
 215
 216
 217 #define R_CURSOR        DB_SET_RANGE
 218 #define R_FIRST         DB_FIRST
 219 #define R_IAFTER        DB_AFTER
 220 #define R_IBEFORE       DB_BEFORE
 221 #define R_LAST          DB_LAST
 222 #define R_NEXT          DB_NEXT
 223 #define R_NOOVERWRITE   DB_NOOVERWRITE
 224 #define R_PREV          DB_PREV
 225
 226 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
 227 #  define R_SETCURSOR   0x800000
 228 #else
 229 #  define R_SETCURSOR   (-100)
 230 #endif
 231
 232 #define R_RECNOSYNC     0
 233 #define R_FIXEDLEN      DB_FIXEDLEN
 234 #define R_DUP           DB_DUP
 235
 236
 237 #define db_HA_hash      h_hash
 238 #define db_HA_ffactor   h_ffactor
 239 #define db_HA_nelem     h_nelem
 240 #define db_HA_bsize     db_pagesize
 241 #define db_HA_cachesize db_cachesize
 242 #define db_HA_lorder    db_lorder
 243
 244 #define db_BT_compare   bt_compare
 245 #define db_BT_prefix    bt_prefix
 246 #define db_BT_flags     flags
 247 #define db_BT_psize     db_pagesize
 248 #define db_BT_cachesize db_cachesize
 249 #define db_BT_lorder    db_lorder
 250 #define db_BT_maxkeypage
 251 #define db_BT_minkeypage
 252
 253
 254 #define db_RE_reclen    re_len
 255 #define db_RE_flags     flags
 256 #define db_RE_bval      re_pad
 257 #define db_RE_bfname    re_source
 258 #define db_RE_psize     db_pagesize
 259 #define db_RE_cachesize db_cachesize
 260 #define db_RE_lorder    db_lorder
 261
 262 #define TXN     NULL,
 263
 264 #define do_SEQ(db, key, value, flag)    (db->cursor->c_get)(db->cursor, &key, &value, flag)
 265
 266
 267 #define DBT_flags(x)    x.flags = 0
 268 #define DB_flags(x, v)  x |= v
 269
 270 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
 271 #    define flagSet(flags, bitmask)     ((flags) & (bitmask))
 272 #else
 273 #    define flagSet(flags, bitmask)     (((flags) & DB_OPFLAGS_MASK) == (bitmask))
 274 #endif
 275
 276 #else /* db version 1.x */
 277
 278 #define BERKELEY_DB_1
 279 #define BERKELEY_DB_1_OR_2
 280
 281 typedef union INFO {
 282         HASHINFO        hash ;
 283         RECNOINFO       recno ;
 284         BTREEINFO       btree ;
 285       } INFO ;
 286
 287
 288 #ifdef mDB_Prefix_t
 289 #  ifdef DB_Prefix_t
 290 #    undef DB_Prefix_t
 291 #  endif
 292 #  define DB_Prefix_t   mDB_Prefix_t
 293 #endif
 294
 295 #ifdef mDB_Hash_t
 296 #  ifdef DB_Hash_t
 297 #    undef DB_Hash_t
 298 #  endif
 299 #  define DB_Hash_t     mDB_Hash_t
 300 #endif
 301
 302 #define db_HA_hash      hash.hash
 303 #define db_HA_ffactor   hash.ffactor
 304 #define db_HA_nelem     hash.nelem
 305 #define db_HA_bsize     hash.bsize
 306 #define db_HA_cachesize hash.cachesize
 307 #define db_HA_lorder    hash.lorder
 308
 309 #define db_BT_compare   btree.compare
 310 #define db_BT_prefix    btree.prefix
 311 #define db_BT_flags     btree.flags
 312 #define db_BT_psize     btree.psize
 313 #define db_BT_cachesize btree.cachesize
 314 #define db_BT_lorder    btree.lorder
 315 #define db_BT_maxkeypage btree.maxkeypage
 316 #define db_BT_minkeypage btree.minkeypage
 317
 318 #define db_RE_reclen    recno.reclen
 319 #define db_RE_flags     recno.flags
 320 #define db_RE_bval      recno.bval
 321 #define db_RE_bfname    recno.bfname
 322 #define db_RE_psize     recno.psize
 323 #define db_RE_cachesize recno.cachesize
 324 #define db_RE_lorder    recno.lorder
 325
 326 #define TXN
 327
 328 #define do_SEQ(db, key, value, flag)    (db->dbp->seq)(db->dbp, &key, &value, flag)
 329 #define DBT_flags(x)
 330 #define DB_flags(x, v)
 331 #define flagSet(flags, bitmask)        ((flags) & (bitmask))
 332
 333 #endif /* db version 1 */
 334
 335
 336
 337 #define db_DELETE(db, key, flags)       ((db->dbp)->del)(db->dbp, TXN &key, 0)
 338 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
 339 #define db_FETCH(db, key, flags)        ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
 340
 341 #define db_sync(db, flags)              ((db->dbp)->sync)(db->dbp, flags)
 342 #define db_get(db, key, value, flags)   ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
 343
 344 #ifdef DB_VERSION_MAJOR
 345 #define db_DESTROY(db)                  (!db->aborted && ( db->cursor->c_close(db->cursor),\
 346                                           (db->dbp->close)(db->dbp, 0) ))
 347 #define db_close(db)                    ((db->dbp)->close)(db->dbp, 0)
 348 #define db_del(db, key, flags)          (flagSet(flags, R_CURSOR)                                       \
 349                                                 ? ((db->cursor)->c_del)(db->cursor, 0)          \
 350                                                 : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
 351
 352 #else /* ! DB_VERSION_MAJOR */
 353
 354 #define db_DESTROY(db)                  (!db->aborted && ((db->dbp)->close)(db->dbp))
 355 #define db_close(db)                    ((db->dbp)->close)(db->dbp)
 356 #define db_del(db, key, flags)          ((db->dbp)->del)(db->dbp, &key, flags)
 357 #define db_put(db, key, value, flags)   ((db->dbp)->put)(db->dbp, &key, &value, flags)
 358
 359 #endif /* ! DB_VERSION_MAJOR */
 360
 361
 362 #define db_seq(db, key, value, flags)   do_SEQ(db, key, value, flags)
 363
 364 typedef struct {
 365         DBTYPE  type ;
 366         DB *    dbp ;
 367         SV *    compare ;
 368         bool    in_compare ;
 369         SV *    prefix ;
 370         bool    in_prefix ;
 371         SV *    hash ;
 372         bool    in_hash ;
 373         bool    aborted ;
 374         int     in_memory ;
 375 #ifdef BERKELEY_DB_1_OR_2
 376         INFO    info ;
 377 #endif
 378 #ifdef DB_VERSION_MAJOR
 379         DBC *   cursor ;
 380 #endif
 381         SV *    filter_fetch_key ;
 382         SV *    filter_store_key ;
 383         SV *    filter_fetch_value ;
 384         SV *    filter_store_value ;
 385         int     filtering ;
 386
 387         } DB_File_type;
 388
 389 typedef DB_File_type * DB_File ;
 390 typedef DBT DBTKEY ;
 391
 392 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
 393
 394 #define OutputValue(arg, name)                                          \
 395         { if (RETVAL == 0) {                                            \
 396               my_sv_setpvn(arg, name.data, name.size) ;                 \
 397               TAINT;                                            \
 398               SvTAINTED_on(arg);                                        \
 399               DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ;      \
 400           }                                                             \
 401         }
 402
 403 #define OutputKey(arg, name)                                            \
 404         { if (RETVAL == 0)                                              \
 405           {                                                             \
 406                 if (db->type != DB_RECNO) {                             \
 407                     my_sv_setpvn(arg, name.data, name.size);            \
 408                 }                                                       \
 409                 else                                                    \
 410                     sv_setiv(arg, (I32)*(I32*)name.data - 1);           \
 411               TAINT;                                            \
 412               SvTAINTED_on(arg);                                        \
 413               DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ;  \
 414           }                                                             \
 415         }
 416
 417 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
 418
 419 #ifdef CAN_PROTOTYPE
 420 extern void __getBerkeleyDBInfo(void);
 421 #endif
 422
 423 /* Internal Global Data */
 424
 425 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION
 426
 427 typedef struct {
 428     recno_t     x_Value;
 429     recno_t     x_zero;
 430     DB_File     x_CurrentDB;
 431     DBTKEY      x_empty;
 432 } my_cxt_t;
 433
 434 START_MY_CXT
 435
 436 #define Value           (MY_CXT.x_Value)
 437 #define zero            (MY_CXT.x_zero)
 438 #define CurrentDB       (MY_CXT.x_CurrentDB)
 439 #define empty           (MY_CXT.x_empty)
 440
 441 #define ERR_BUFF "DB_File::Error"
 442
 443 #ifdef DB_VERSION_MAJOR
 444
 445 static int
 446 #ifdef CAN_PROTOTYPE
 447 db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
 448 #else
 449 db_put(db, key, value, flags)
 450 DB_File         db ;
 451 DBTKEY          key ;
 452 DBT             value ;
 453 u_int           flags ;
 454 #endif
 455 {
 456     int status ;
 457
 458     if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
 459         DBC * temp_cursor ;
 460         DBT l_key, l_value;
 461
 462 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
 463         if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
 464 #else
 465         if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
 466 #endif
 467             return (-1) ;
 468
 469         memset(&l_key, 0, sizeof(l_key));
 470         l_key.data = key.data;
 471         l_key.size = key.size;
 472         memset(&l_value, 0, sizeof(l_value));
 473         l_value.data = value.data;
 474         l_value.size = value.size;
 475
 476         if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
 477             (void)temp_cursor->c_close(temp_cursor);
 478             return (-1);
 479         }
 480
 481         status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
 482         (void)temp_cursor->c_close(temp_cursor);
 483
 484         return (status) ;
 485     }
 486
 487
 488     if (flagSet(flags, R_CURSOR)) {
 489         return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
 490     }
 491
 492     if (flagSet(flags, R_SETCURSOR)) {
 493         if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
 494                 return -1 ;
 495         return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
 496
 497     }
 498
 499     return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
 500
 501 }
 502
 503 #endif /* DB_VERSION_MAJOR */
 504
 505 static void
 506 tidyUp(DB_File db)
 507 {
 508     /* db_DESTROY(db); */
 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     DB_File     keep_CurrentDB = CurrentDB;
 547
 548
 549     if (CurrentDB->in_compare) {
 550         tidyUp(CurrentDB);
 551         croak ("DB_File btree_compare: recursion detected\n") ;
 552     }
 553
 554     data1 = (char *) key1->data ;
 555     data2 = (char *) key2->data ;
 556
 557 #ifndef newSVpvn
 558     /* As newSVpv will assume that the data pointer is a null terminated C
 559        string if the size parameter is 0, make sure that data points to an
 560        empty string if the length is 0
 561     */
 562     if (key1->size == 0)
 563         data1 = "" ;
 564     if (key2->size == 0)
 565         data2 = "" ;
 566 #endif
 567
 568     ENTER ;
 569     SAVETMPS;
 570
 571     PUSHMARK(SP) ;
 572     EXTEND(SP,2) ;
 573     PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
 574     PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
 575     PUTBACK ;
 576
 577     CurrentDB->in_compare = TRUE;
 578
 579     count = perl_call_sv(CurrentDB->compare, G_SCALAR);
 580
 581     CurrentDB = keep_CurrentDB;
 582     CurrentDB->in_compare = FALSE;
 583
 584     SPAGAIN ;
 585
 586     if (count != 1){
 587         tidyUp(CurrentDB);
 588         croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
 589     }
 590
 591     retval = POPi ;
 592
 593     PUTBACK ;
 594     FREETMPS ;
 595     LEAVE ;
 596
 597     return (retval) ;
 598
 599 }
 600
 601 static DB_Prefix_t
 602 #ifdef AT_LEAST_DB_3_2
 603
 604 #ifdef CAN_PROTOTYPE
 605 btree_prefix(DB * db, const DBT *key1, const DBT *key2)
 606 #else
 607 btree_prefix(db, key1, key2)
 608 Db * db ;
 609 const DBT * key1 ;
 610 const DBT * key2 ;
 611 #endif
 612
 613 #else /* Berkeley DB < 3.2 */
 614
 615 #ifdef CAN_PROTOTYPE
 616 btree_prefix(const DBT *key1, const DBT *key2)
 617 #else
 618 btree_prefix(key1, key2)
 619 const DBT * key1 ;
 620 const DBT * key2 ;
 621 #endif
 622
 623 #endif
 624 {
 625 #ifdef dTHX
 626     dTHX;
 627 #endif
 628     dSP ;
 629     dMY_CXT ;
 630     char * data1, * data2 ;
 631     int retval ;
 632     int count ;
 633     DB_File     keep_CurrentDB = CurrentDB;
 634
 635     if (CurrentDB->in_prefix){
 636         tidyUp(CurrentDB);
 637         croak ("DB_File btree_prefix: recursion detected\n") ;
 638     }
 639
 640     data1 = (char *) key1->data ;
 641     data2 = (char *) key2->data ;
 642
 643 #ifndef newSVpvn
 644     /* As newSVpv will assume that the data pointer is a null terminated C
 645        string if the size parameter is 0, make sure that data points to an
 646        empty string if the length is 0
 647     */
 648     if (key1->size == 0)
 649         data1 = "" ;
 650     if (key2->size == 0)
 651         data2 = "" ;
 652 #endif
 653
 654     ENTER ;
 655     SAVETMPS;
 656
 657     PUSHMARK(SP) ;
 658     EXTEND(SP,2) ;
 659     PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
 660     PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
 661     PUTBACK ;
 662
 663     CurrentDB->in_prefix = TRUE;
 664
 665     count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
 666
 667     CurrentDB = keep_CurrentDB;
 668     CurrentDB->in_prefix = FALSE;
 669
 670     SPAGAIN ;
 671
 672     if (count != 1){
 673         tidyUp(CurrentDB);
 674         croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
 675     }
 676
 677     retval = POPi ;
 678
 679     PUTBACK ;
 680     FREETMPS ;
 681     LEAVE ;
 682
 683     return (retval) ;
 684 }
 685
 686
 687 #ifdef BERKELEY_DB_1
 688 #    define HASH_CB_SIZE_TYPE size_t
 689 #else
 690 #    define HASH_CB_SIZE_TYPE u_int32_t
 691 #endif
 692
 693 static DB_Hash_t
 694 #ifdef AT_LEAST_DB_3_2
 695
 696 #ifdef CAN_PROTOTYPE
 697 hash_cb(DB * db, const void *data, u_int32_t size)
 698 #else
 699 hash_cb(db, data, size)
 700 DB * db ;
 701 const void * data ;
 702 HASH_CB_SIZE_TYPE size ;
 703 #endif
 704
 705 #else /* Berkeley DB < 3.2 */
 706
 707 #ifdef CAN_PROTOTYPE
 708 hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
 709 #else
 710 hash_cb(data, size)
 711 const void * data ;
 712 HASH_CB_SIZE_TYPE size ;
 713 #endif
 714
 715 #endif
 716 {
 717 #ifdef dTHX
 718     dTHX;
 719 #endif
 720     dSP ;
 721     dMY_CXT;
 722     int retval ;
 723     int count ;
 724     DB_File     keep_CurrentDB = CurrentDB;
 725
 726     if (CurrentDB->in_hash){
 727         tidyUp(CurrentDB);
 728         croak ("DB_File hash callback: recursion detected\n") ;
 729     }
 730
 731 #ifndef newSVpvn
 732     if (size == 0)
 733         data = "" ;
 734 #endif
 735
 736      /* DGH - Next two lines added to fix corrupted stack problem */
 737     ENTER ;
 738     SAVETMPS;
 739
 740     PUSHMARK(SP) ;
 741
 742     XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
 743     PUTBACK ;
 744
 745     keep_CurrentDB->in_hash = TRUE;
 746
 747     count = perl_call_sv(CurrentDB->hash, G_SCALAR);
 748
 749     CurrentDB = keep_CurrentDB;
 750     CurrentDB->in_hash = FALSE;
 751
 752     SPAGAIN ;
 753
 754     if (count != 1){
 755         tidyUp(CurrentDB);
 756         croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
 757     }
 758
 759     retval = POPi ;
 760
 761     PUTBACK ;
 762     FREETMPS ;
 763     LEAVE ;
 764
 765     return (retval) ;
 766 }
 767
 768 static void
 769 #ifdef CAN_PROTOTYPE
 770 db_errcall_cb(const char * db_errpfx, char * buffer)
 771 #else
 772 db_errcall_cb(db_errpfx, buffer)
 773 const char * db_errpfx;
 774 char * buffer;
 775 #endif
 776 {
 777     SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
 778     if (sv) {
 779         if (db_errpfx)
 780             sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
 781         else
 782             sv_setpv(sv, buffer) ;
 783     }
 784 }
 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    = %ul\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     SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
1459     MY_CXT_INIT;
1460     __getBerkeleyDBInfo() ;
1461
1462     DBT_clear(empty) ;
1463     empty.data = &zero ;
1464     empty.size =  sizeof(recno_t) ;
1465   }
1466
1467
1468
1469 DB_File
1470 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1471         int             isHASH
1472         char *          dbtype
1473         int             flags
1474         int             mode
1475         CODE:
1476         {
1477             char *      name = (char *) NULL ;
1478             SV *        sv = (SV *) NULL ;
1479             STRLEN      n_a;
1480
1481             if (items >= 3 && SvOK(ST(2)))
1482                 name = (char*) SvPV(ST(2), n_a) ;
1483
1484             if (items == 6)
1485                 sv = ST(5) ;
1486
1487             RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1488             if (RETVAL->dbp == NULL)
1489                 RETVAL = NULL ;
1490         }
1491         OUTPUT:
1492             RETVAL
1493
1494 int
1495 db_DESTROY(db)
1496         DB_File         db
1497         PREINIT:
1498           dMY_CXT;
1499         INIT:
1500           CurrentDB = db ;
1501           Trace(("DESTROY %p\n", db));
1502         CLEANUP:
1503           Trace(("DESTROY %p done\n", db));
1504           if (db->hash)
1505             SvREFCNT_dec(db->hash) ;
1506           if (db->compare)
1507             SvREFCNT_dec(db->compare) ;
1508           if (db->prefix)
1509             SvREFCNT_dec(db->prefix) ;
1510           if (db->filter_fetch_key)
1511             SvREFCNT_dec(db->filter_fetch_key) ;
1512           if (db->filter_store_key)
1513             SvREFCNT_dec(db->filter_store_key) ;
1514           if (db->filter_fetch_value)
1515             SvREFCNT_dec(db->filter_fetch_value) ;
1516           if (db->filter_store_value)
1517             SvREFCNT_dec(db->filter_store_value) ;
1518           safefree(db) ;
1519 #ifdef DB_VERSION_MAJOR
1520           if (RETVAL > 0)
1521             RETVAL = -1 ;
1522 #endif
1523
1524
1525 int
1526 db_DELETE(db, key, flags=0)
1527         DB_File         db
1528         DBTKEY          key
1529         u_int           flags
1530         PREINIT:
1531           dMY_CXT;
1532         INIT:
1533           CurrentDB = db ;
1534
1535
1536 int
1537 db_EXISTS(db, key)
1538         DB_File         db
1539         DBTKEY          key
1540         PREINIT:
1541           dMY_CXT;
1542         CODE:
1543         {
1544           DBT           value ;
1545
1546           DBT_clear(value) ;
1547           CurrentDB = db ;
1548           RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1549         }
1550         OUTPUT:
1551           RETVAL
1552
1553 void
1554 db_FETCH(db, key, flags=0)
1555         DB_File         db
1556         DBTKEY          key
1557         u_int           flags
1558         PREINIT:
1559           dMY_CXT ;
1560           int RETVAL ;
1561         CODE:
1562         {
1563             DBT         value ;
1564
1565             DBT_clear(value) ;
1566             CurrentDB = db ;
1567             RETVAL = db_get(db, key, value, flags) ;
1568             ST(0) = sv_newmortal();
1569             OutputValue(ST(0), value)
1570         }
1571
1572 int
1573 db_STORE(db, key, value, flags=0)
1574         DB_File         db
1575         DBTKEY          key
1576         DBT             value
1577         u_int           flags
1578         PREINIT:
1579           dMY_CXT;
1580         INIT:
1581           CurrentDB = db ;
1582
1583
1584 void
1585 db_FIRSTKEY(db)
1586         DB_File         db
1587         PREINIT:
1588           dMY_CXT ;
1589           int RETVAL ;
1590         CODE:
1591         {
1592             DBTKEY      key ;
1593             DBT         value ;
1594
1595             DBT_clear(key) ;
1596             DBT_clear(value) ;
1597             CurrentDB = db ;
1598             RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1599             ST(0) = sv_newmortal();
1600             OutputKey(ST(0), key) ;
1601         }
1602
1603 void
1604 db_NEXTKEY(db, key)
1605         DB_File         db
1606         DBTKEY          key = NO_INIT
1607         PREINIT:
1608           dMY_CXT ;
1609           int RETVAL ;
1610         CODE:
1611         {
1612             DBT         value ;
1613
1614             DBT_clear(key) ;
1615             DBT_clear(value) ;
1616             CurrentDB = db ;
1617             RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1618             ST(0) = sv_newmortal();
1619             OutputKey(ST(0), key) ;
1620         }
1621
1622 #
1623 # These would be nice for RECNO
1624 #
1625
1626 int
1627 unshift(db, ...)
1628         DB_File         db
1629         ALIAS:          UNSHIFT = 1
1630         PREINIT:
1631           dMY_CXT;
1632         CODE:
1633         {
1634             DBTKEY      key ;
1635             DBT         value ;
1636             int         i ;
1637             int         One ;
1638             STRLEN      n_a;
1639
1640             DBT_clear(key) ;
1641             DBT_clear(value) ;
1642             CurrentDB = db ;
1643 #ifdef DB_VERSION_MAJOR
1644             /* get the first value */
1645             RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1646             RETVAL = 0 ;
1647 #else
1648             RETVAL = -1 ;
1649 #endif
1650             for (i = items-1 ; i > 0 ; --i)
1651             {
1652                 value.data = SvPV(ST(i), n_a) ;
1653                 value.size = n_a ;
1654                 One = 1 ;
1655                 key.data = &One ;
1656                 key.size = sizeof(int) ;
1657 #ifdef DB_VERSION_MAJOR
1658                 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1659 #else
1660                 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
1661 #endif
1662                 if (RETVAL != 0)
1663                     break;
1664             }
1665         }
1666         OUTPUT:
1667             RETVAL
1668
1669 void
1670 pop(db)
1671         DB_File         db
1672         PREINIT:
1673           dMY_CXT;
1674         ALIAS:          POP = 1
1675         PREINIT:
1676           I32 RETVAL;
1677         CODE:
1678         {
1679             DBTKEY      key ;
1680             DBT         value ;
1681
1682             DBT_clear(key) ;
1683             DBT_clear(value) ;
1684             CurrentDB = db ;
1685
1686             /* First get the final value */
1687             RETVAL = do_SEQ(db, key, value, R_LAST) ;
1688             ST(0) = sv_newmortal();
1689             /* Now delete it */
1690             if (RETVAL == 0)
1691             {
1692                 /* the call to del will trash value, so take a copy now */
1693                 OutputValue(ST(0), value) ;
1694                 RETVAL = db_del(db, key, R_CURSOR) ;
1695                 if (RETVAL != 0)
1696                     sv_setsv(ST(0), &PL_sv_undef);
1697             }
1698         }
1699
1700 void
1701 shift(db)
1702         DB_File         db
1703         PREINIT:
1704           dMY_CXT;
1705         ALIAS:          SHIFT = 1
1706         PREINIT:
1707           I32 RETVAL;
1708         CODE:
1709         {
1710             DBT         value ;
1711             DBTKEY      key ;
1712
1713             DBT_clear(key) ;
1714             DBT_clear(value) ;
1715             CurrentDB = db ;
1716             /* get the first value */
1717             RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1718             ST(0) = sv_newmortal();
1719             /* Now delete it */
1720             if (RETVAL == 0)
1721             {
1722                 /* the call to del will trash value, so take a copy now */
1723                 OutputValue(ST(0), value) ;
1724                 RETVAL = db_del(db, key, R_CURSOR) ;
1725                 if (RETVAL != 0)
1726                     sv_setsv (ST(0), &PL_sv_undef) ;
1727             }
1728         }
1729
1730
1731 I32
1732 push(db, ...)
1733         DB_File         db
1734         PREINIT:
1735           dMY_CXT;
1736         ALIAS:          PUSH = 1
1737         CODE:
1738         {
1739             DBTKEY      key ;
1740             DBT         value ;
1741             DB *        Db = db->dbp ;
1742             int         i ;
1743             STRLEN      n_a;
1744             int         keyval ;
1745
1746             DBT_flags(key) ;
1747             DBT_flags(value) ;
1748             CurrentDB = db ;
1749             /* Set the Cursor to the Last element */
1750             RETVAL = do_SEQ(db, key, value, R_LAST) ;
1751 #ifndef DB_VERSION_MAJOR
1752             if (RETVAL >= 0)
1753 #endif
1754             {
1755                 if (RETVAL == 0)
1756                     keyval = *(int*)key.data ;
1757                 else
1758                     keyval = 0 ;
1759                 for (i = 1 ; i < items ; ++i)
1760                 {
1761                     value.data = SvPV(ST(i), n_a) ;
1762                     value.size = n_a ;
1763                     ++ keyval ;
1764                     key.data = &keyval ;
1765                     key.size = sizeof(int) ;
1766                     RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1767                     if (RETVAL != 0)
1768                         break;
1769                 }
1770             }
1771         }
1772         OUTPUT:
1773             RETVAL
1774
1775 I32
1776 length(db)
1777         DB_File         db
1778         PREINIT:
1779           dMY_CXT;
1780         ALIAS:          FETCHSIZE = 1
1781         CODE:
1782             CurrentDB = db ;
1783             RETVAL = GetArrayLength(aTHX_ db) ;
1784         OUTPUT:
1785             RETVAL
1786
1787
1788 #
1789 # Now provide an interface to the rest of the DB functionality
1790 #
1791
1792 int
1793 db_del(db, key, flags=0)
1794         DB_File         db
1795         DBTKEY          key
1796         u_int           flags
1797         PREINIT:
1798           dMY_CXT;
1799         CODE:
1800           CurrentDB = db ;
1801           RETVAL = db_del(db, key, flags) ;
1802 #ifdef DB_VERSION_MAJOR
1803           if (RETVAL > 0)
1804             RETVAL = -1 ;
1805           else if (RETVAL == DB_NOTFOUND)
1806             RETVAL = 1 ;
1807 #endif
1808         OUTPUT:
1809           RETVAL
1810
1811
1812 int
1813 db_get(db, key, value, flags=0)
1814         DB_File         db
1815         DBTKEY          key
1816         DBT             value = NO_INIT
1817         u_int           flags
1818         PREINIT:
1819           dMY_CXT;
1820         CODE:
1821           CurrentDB = db ;
1822           DBT_clear(value) ;
1823           RETVAL = db_get(db, key, value, flags) ;
1824 #ifdef DB_VERSION_MAJOR
1825           if (RETVAL > 0)
1826             RETVAL = -1 ;
1827           else if (RETVAL == DB_NOTFOUND)
1828             RETVAL = 1 ;
1829 #endif
1830         OUTPUT:
1831           RETVAL
1832           value
1833
1834 int
1835 db_put(db, key, value, flags=0)
1836         DB_File         db
1837         DBTKEY          key
1838         DBT             value
1839         u_int           flags
1840         PREINIT:
1841           dMY_CXT;
1842         CODE:
1843           CurrentDB = db ;
1844           RETVAL = db_put(db, key, value, flags) ;
1845 #ifdef DB_VERSION_MAJOR
1846           if (RETVAL > 0)
1847             RETVAL = -1 ;
1848           else if (RETVAL == DB_KEYEXIST)
1849             RETVAL = 1 ;
1850 #endif
1851         OUTPUT:
1852           RETVAL
1853           key           if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1854
1855 int
1856 db_fd(db)
1857         DB_File         db
1858         PREINIT:
1859           dMY_CXT ;
1860         CODE:
1861           CurrentDB = db ;
1862 #ifdef DB_VERSION_MAJOR
1863           RETVAL = -1 ;
1864           {
1865             int status = 0 ;
1866             status = (db->in_memory
1867                       ? -1
1868                       : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1869             if (status != 0)
1870               RETVAL = -1 ;
1871           }
1872 #else
1873           RETVAL = (db->in_memory
1874                 ? -1
1875                 : ((db->dbp)->fd)(db->dbp) ) ;
1876 #endif
1877         OUTPUT:
1878           RETVAL
1879
1880 int
1881 db_sync(db, flags=0)
1882         DB_File         db
1883         u_int           flags
1884         PREINIT:
1885           dMY_CXT;
1886         CODE:
1887           CurrentDB = db ;
1888           RETVAL = db_sync(db, flags) ;
1889 #ifdef DB_VERSION_MAJOR
1890           if (RETVAL > 0)
1891             RETVAL = -1 ;
1892 #endif
1893         OUTPUT:
1894           RETVAL
1895
1896
1897 int
1898 db_seq(db, key, value, flags)
1899         DB_File         db
1900         DBTKEY          key
1901         DBT             value = NO_INIT
1902         u_int           flags
1903         PREINIT:
1904           dMY_CXT;
1905         CODE:
1906           CurrentDB = db ;
1907           DBT_clear(value) ;
1908           RETVAL = db_seq(db, key, value, flags);
1909 #ifdef DB_VERSION_MAJOR
1910           if (RETVAL > 0)
1911             RETVAL = -1 ;
1912           else if (RETVAL == DB_NOTFOUND)
1913             RETVAL = 1 ;
1914 #endif
1915         OUTPUT:
1916           RETVAL
1917           key
1918           value
1919
1920 SV *
1921 filter_fetch_key(db, code)
1922         DB_File         db
1923         SV *            code
1924         SV *            RETVAL = &PL_sv_undef ;
1925         CODE:
1926             DBM_setFilter(db->filter_fetch_key, code) ;
1927
1928 SV *
1929 filter_store_key(db, code)
1930         DB_File         db
1931         SV *            code
1932         SV *            RETVAL = &PL_sv_undef ;
1933         CODE:
1934             DBM_setFilter(db->filter_store_key, code) ;
1935
1936 SV *
1937 filter_fetch_value(db, code)
1938         DB_File         db
1939         SV *            code
1940         SV *            RETVAL = &PL_sv_undef ;
1941         CODE:
1942             DBM_setFilter(db->filter_fetch_value, code) ;
1943
1944 SV *
1945 filter_store_value(db, code)
1946         DB_File         db
1947         SV *            code
1948         SV *            RETVAL = &PL_sv_undef ;
1949         CODE:
1950             DBM_setFilter(db->filter_store_value, code) ;
1951