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