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