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