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