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 static DB_Hash_t
 588 #ifdef CAN_PROTOTYPE
 589 hash_cb(const void *data, size_t size)
 590 #else
 591 hash_cb(data, size)
 592 const void * data ;
 593 size_t size ;
 594 #endif
 595 {
 596 #ifdef dTHX
 597     dTHX;
 598 #endif
 599     dSP ;
 600     int retval ;
 601     int count ;
 602
 603 #ifndef newSVpvn
 604     if (size == 0)
 605         data = "" ;
 606 #endif
 607
 608      /* DGH - Next two lines added to fix corrupted stack problem */
 609     ENTER ;
 610     SAVETMPS;
 611
 612     PUSHMARK(SP) ;
 613
 614     XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
 615     PUTBACK ;
 616
 617     count = perl_call_sv(CurrentDB->hash, G_SCALAR);
 618
 619     SPAGAIN ;
 620
 621     if (count != 1)
 622         croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
 623
 624     retval = POPi ;
 625
 626     PUTBACK ;
 627     FREETMPS ;
 628     LEAVE ;
 629
 630     return (retval) ;
 631 }
 632
 633
 634 #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
 635
 636 static void
 637 #ifdef CAN_PROTOTYPE
 638 PrintHash(INFO *hash)
 639 #else
 640 PrintHash(hash)
 641 INFO * hash ;
 642 #endif
 643 {
 644     printf ("HASH Info\n") ;
 645     printf ("  hash      = %s\n",
 646                 (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
 647     printf ("  bsize     = %d\n", hash->db_HA_bsize) ;
 648     printf ("  ffactor   = %d\n", hash->db_HA_ffactor) ;
 649     printf ("  nelem     = %d\n", hash->db_HA_nelem) ;
 650     printf ("  cachesize = %d\n", hash->db_HA_cachesize) ;
 651     printf ("  lorder    = %d\n", hash->db_HA_lorder) ;
 652
 653 }
 654
 655 static void
 656 #ifdef CAN_PROTOTYPE
 657 PrintRecno(INFO *recno)
 658 #else
 659 PrintRecno(recno)
 660 INFO * recno ;
 661 #endif
 662 {
 663     printf ("RECNO Info\n") ;
 664     printf ("  flags     = %d\n", recno->db_RE_flags) ;
 665     printf ("  cachesize = %d\n", recno->db_RE_cachesize) ;
 666     printf ("  psize     = %d\n", recno->db_RE_psize) ;
 667     printf ("  lorder    = %d\n", recno->db_RE_lorder) ;
 668     printf ("  reclen    = %ul\n", (unsigned long)recno->db_RE_reclen) ;
 669     printf ("  bval      = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
 670     printf ("  bfname    = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
 671 }
 672
 673 static void
 674 #ifdef CAN_PROTOTYPE
 675 PrintBtree(INFO *btree)
 676 #else
 677 PrintBtree(btree)
 678 INFO * btree ;
 679 #endif
 680 {
 681     printf ("BTREE Info\n") ;
 682     printf ("  compare    = %s\n",
 683                 (btree->db_BT_compare ? "redefined" : "default")) ;
 684     printf ("  prefix     = %s\n",
 685                 (btree->db_BT_prefix ? "redefined" : "default")) ;
 686     printf ("  flags      = %d\n", btree->db_BT_flags) ;
 687     printf ("  cachesize  = %d\n", btree->db_BT_cachesize) ;
 688     printf ("  psize      = %d\n", btree->db_BT_psize) ;
 689 #ifndef DB_VERSION_MAJOR
 690     printf ("  maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
 691     printf ("  minkeypage = %d\n", btree->db_BT_minkeypage) ;
 692 #endif
 693     printf ("  lorder     = %d\n", btree->db_BT_lorder) ;
 694 }
 695
 696 #else
 697
 698 #define PrintRecno(recno)
 699 #define PrintHash(hash)
 700 #define PrintBtree(btree)
 701
 702 #endif /* TRACE */
 703
 704
 705 static I32
 706 #ifdef CAN_PROTOTYPE
 707 GetArrayLength(pTHX_ DB_File db)
 708 #else
 709 GetArrayLength(db)
 710 DB_File db ;
 711 #endif
 712 {
 713     DBT         key ;
 714     DBT         value ;
 715     int         RETVAL ;
 716
 717     DBT_clear(key) ;
 718     DBT_clear(value) ;
 719     RETVAL = do_SEQ(db, key, value, R_LAST) ;
 720     if (RETVAL == 0)
 721         RETVAL = *(I32 *)key.data ;
 722     else /* No key means empty file */
 723         RETVAL = 0 ;
 724
 725     return ((I32)RETVAL) ;
 726 }
 727
 728 static recno_t
 729 #ifdef CAN_PROTOTYPE
 730 GetRecnoKey(pTHX_ DB_File db, I32 value)
 731 #else
 732 GetRecnoKey(db, value)
 733 DB_File  db ;
 734 I32      value ;
 735 #endif
 736 {
 737     if (value < 0) {
 738         /* Get the length of the array */
 739         I32 length = GetArrayLength(aTHX_ db) ;
 740
 741         /* check for attempt to write before start of array */
 742         if (length + value + 1 <= 0)
 743             croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
 744
 745         value = length + value + 1 ;
 746     }
 747     else
 748         ++ value ;
 749
 750     return value ;
 751 }
 752
 753
 754 static DB_File
 755 #ifdef CAN_PROTOTYPE
 756 ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
 757 #else
 758 ParseOpenInfo(isHASH, name, flags, mode, sv)
 759 int    isHASH ;
 760 char * name ;
 761 int    flags ;
 762 int    mode ;
 763 SV *   sv ;
 764 #endif
 765 {
 766
 767 #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1  or 2 */
 768
 769     SV **       svp;
 770     HV *        action ;
 771     DB_File     RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
 772     void *      openinfo = NULL ;
 773     INFO        * info  = &RETVAL->info ;
 774     STRLEN      n_a;
 775
 776 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */
 777     Zero(RETVAL, 1, DB_File_type) ;
 778
 779     /* Default to HASH */
 780 #ifdef DBM_FILTERING
 781     RETVAL->filtering = 0 ;
 782     RETVAL->filter_fetch_key = RETVAL->filter_store_key =
 783     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
 784 #endif /* DBM_FILTERING */
 785     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
 786     RETVAL->type = DB_HASH ;
 787
 788      /* DGH - Next line added to avoid SEGV on existing hash DB */
 789     CurrentDB = RETVAL;
 790
 791     /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
 792     RETVAL->in_memory = (name == NULL) ;
 793
 794     if (sv)
 795     {
 796         if (! SvROK(sv) )
 797             croak ("type parameter is not a reference") ;
 798
 799         svp  = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
 800         if (svp && SvOK(*svp))
 801             action  = (HV*) SvRV(*svp) ;
 802         else
 803             croak("internal error") ;
 804
 805         if (sv_isa(sv, "DB_File::HASHINFO"))
 806         {
 807
 808             if (!isHASH)
 809                 croak("DB_File can only tie an associative array to a DB_HASH database") ;
 810
 811             RETVAL->type = DB_HASH ;
 812             openinfo = (void*)info ;
 813
 814             svp = hv_fetch(action, "hash", 4, FALSE);
 815
 816             if (svp && SvOK(*svp))
 817             {
 818                 info->db_HA_hash = hash_cb ;
 819                 RETVAL->hash = newSVsv(*svp) ;
 820             }
 821             else
 822                 info->db_HA_hash = NULL ;
 823
 824            svp = hv_fetch(action, "ffactor", 7, FALSE);
 825            info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
 826
 827            svp = hv_fetch(action, "nelem", 5, FALSE);
 828            info->db_HA_nelem = svp ? SvIV(*svp) : 0;
 829
 830            svp = hv_fetch(action, "bsize", 5, FALSE);
 831            info->db_HA_bsize = svp ? SvIV(*svp) : 0;
 832
 833            svp = hv_fetch(action, "cachesize", 9, FALSE);
 834            info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
 835
 836            svp = hv_fetch(action, "lorder", 6, FALSE);
 837            info->db_HA_lorder = svp ? SvIV(*svp) : 0;
 838
 839            PrintHash(info) ;
 840         }
 841         else if (sv_isa(sv, "DB_File::BTREEINFO"))
 842         {
 843             if (!isHASH)
 844                 croak("DB_File can only tie an associative array to a DB_BTREE database");
 845
 846             RETVAL->type = DB_BTREE ;
 847             openinfo = (void*)info ;
 848
 849             svp = hv_fetch(action, "compare", 7, FALSE);
 850             if (svp && SvOK(*svp))
 851             {
 852                 info->db_BT_compare = btree_compare ;
 853                 RETVAL->compare = newSVsv(*svp) ;
 854             }
 855             else
 856                 info->db_BT_compare = NULL ;
 857
 858             svp = hv_fetch(action, "prefix", 6, FALSE);
 859             if (svp && SvOK(*svp))
 860             {
 861                 info->db_BT_prefix = btree_prefix ;
 862                 RETVAL->prefix = newSVsv(*svp) ;
 863             }
 864             else
 865                 info->db_BT_prefix = NULL ;
 866
 867             svp = hv_fetch(action, "flags", 5, FALSE);
 868             info->db_BT_flags = svp ? SvIV(*svp) : 0;
 869
 870             svp = hv_fetch(action, "cachesize", 9, FALSE);
 871             info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
 872
 873 #ifndef DB_VERSION_MAJOR
 874             svp = hv_fetch(action, "minkeypage", 10, FALSE);
 875             info->btree.minkeypage = svp ? SvIV(*svp) : 0;
 876
 877             svp = hv_fetch(action, "maxkeypage", 10, FALSE);
 878             info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
 879 #endif
 880
 881             svp = hv_fetch(action, "psize", 5, FALSE);
 882             info->db_BT_psize = svp ? SvIV(*svp) : 0;
 883
 884             svp = hv_fetch(action, "lorder", 6, FALSE);
 885             info->db_BT_lorder = svp ? SvIV(*svp) : 0;
 886
 887             PrintBtree(info) ;
 888
 889         }
 890         else if (sv_isa(sv, "DB_File::RECNOINFO"))
 891         {
 892             if (isHASH)
 893                 croak("DB_File can only tie an array to a DB_RECNO database");
 894
 895             RETVAL->type = DB_RECNO ;
 896             openinfo = (void *)info ;
 897
 898             info->db_RE_flags = 0 ;
 899
 900             svp = hv_fetch(action, "flags", 5, FALSE);
 901             info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
 902
 903             svp = hv_fetch(action, "reclen", 6, FALSE);
 904             info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
 905
 906             svp = hv_fetch(action, "cachesize", 9, FALSE);
 907             info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
 908
 909             svp = hv_fetch(action, "psize", 5, FALSE);
 910             info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
 911
 912             svp = hv_fetch(action, "lorder", 6, FALSE);
 913             info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
 914
 915 #ifdef DB_VERSION_MAJOR
 916             info->re_source = name ;
 917             name = NULL ;
 918 #endif
 919             svp = hv_fetch(action, "bfname", 6, FALSE);
 920             if (svp && SvOK(*svp)) {
 921                 char * ptr = SvPV(*svp,n_a) ;
 922 #ifdef DB_VERSION_MAJOR
 923                 name = (char*) n_a ? ptr : NULL ;
 924 #else
 925                 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
 926 #endif
 927             }
 928             else
 929 #ifdef DB_VERSION_MAJOR
 930                 name = NULL ;
 931 #else
 932                 info->db_RE_bfname = NULL ;
 933 #endif
 934
 935             svp = hv_fetch(action, "bval", 4, FALSE);
 936 #ifdef DB_VERSION_MAJOR
 937             if (svp && SvOK(*svp))
 938             {
 939                 int value ;
 940                 if (SvPOK(*svp))
 941                     value = (int)*SvPV(*svp, n_a) ;
 942                 else
 943                     value = SvIV(*svp) ;
 944
 945                 if (info->flags & DB_FIXEDLEN) {
 946                     info->re_pad = value ;
 947                     info->flags |= DB_PAD ;
 948                 }
 949                 else {
 950                     info->re_delim = value ;
 951                     info->flags |= DB_DELIMITER ;
 952                 }
 953
 954             }
 955 #else
 956             if (svp && SvOK(*svp))
 957             {
 958                 if (SvPOK(*svp))
 959                     info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
 960                 else
 961                     info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
 962                 DB_flags(info->flags, DB_DELIMITER) ;
 963
 964             }
 965             else
 966             {
 967                 if (info->db_RE_flags & R_FIXEDLEN)
 968                     info->db_RE_bval = (u_char) ' ' ;
 969                 else
 970                     info->db_RE_bval = (u_char) '\n' ;
 971                 DB_flags(info->flags, DB_DELIMITER) ;
 972             }
 973 #endif
 974
 975 #ifdef DB_RENUMBER
 976             info->flags |= DB_RENUMBER ;
 977 #endif
 978
 979             PrintRecno(info) ;
 980         }
 981         else
 982             croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
 983     }
 984
 985
 986     /* OS2 Specific Code */
 987 #ifdef OS2
 988 #ifdef __EMX__
 989     flags |= O_BINARY;
 990 #endif /* __EMX__ */
 991 #endif /* OS2 */
 992
 993 #ifdef DB_VERSION_MAJOR
 994
 995     {
 996         int             Flags = 0 ;
 997         int             status ;
 998
 999         /* Map 1.x flags to 2.x flags */
1000         if ((flags & O_CREAT) == O_CREAT)
1001             Flags |= DB_CREATE ;
1002
1003 #if O_RDONLY == 0
1004         if (flags == O_RDONLY)
1005 #else
1006         if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1007 #endif
1008             Flags |= DB_RDONLY ;
1009
1010 #ifdef O_TRUNC
1011         if ((flags & O_TRUNC) == O_TRUNC)
1012             Flags |= DB_TRUNCATE ;
1013 #endif
1014
1015         status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
1016         if (status == 0)
1017 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
1018             status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
1019 #else
1020             status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1021                         0) ;
1022 #endif
1023
1024         if (status)
1025             RETVAL->dbp = NULL ;
1026
1027     }
1028 #else
1029
1030 #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
1031     RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ;
1032 #else
1033     RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
1034 #endif /* DB_LIBRARY_COMPATIBILITY_API */
1035
1036 #endif
1037
1038     return (RETVAL) ;
1039
1040 #else /* Berkeley DB Version > 2 */
1041
1042     SV **       svp;
1043     HV *        action ;
1044     DB_File     RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
1045     DB *        dbp ;
1046     STRLEN      n_a;
1047     int         status ;
1048
1049 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */
1050     Zero(RETVAL, 1, DB_File_type) ;
1051
1052     /* Default to HASH */
1053 #ifdef DBM_FILTERING
1054     RETVAL->filtering = 0 ;
1055     RETVAL->filter_fetch_key = RETVAL->filter_store_key =
1056     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
1057 #endif /* DBM_FILTERING */
1058     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
1059     RETVAL->type = DB_HASH ;
1060
1061      /* DGH - Next line added to avoid SEGV on existing hash DB */
1062     CurrentDB = RETVAL;
1063
1064     /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
1065     RETVAL->in_memory = (name == NULL) ;
1066
1067     status = db_create(&RETVAL->dbp, NULL,0) ;
1068     /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
1069     if (status) {
1070         RETVAL->dbp = NULL ;
1071         return (RETVAL) ;
1072     }
1073     dbp = RETVAL->dbp ;
1074
1075     if (sv)
1076     {
1077         if (! SvROK(sv) )
1078             croak ("type parameter is not a reference") ;
1079
1080         svp  = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
1081         if (svp && SvOK(*svp))
1082             action  = (HV*) SvRV(*svp) ;
1083         else
1084             croak("internal error") ;
1085
1086         if (sv_isa(sv, "DB_File::HASHINFO"))
1087         {
1088
1089             if (!isHASH)
1090                 croak("DB_File can only tie an associative array to a DB_HASH database") ;
1091
1092             RETVAL->type = DB_HASH ;
1093
1094             svp = hv_fetch(action, "hash", 4, FALSE);
1095
1096             if (svp && SvOK(*svp))
1097             {
1098                 (void)dbp->set_h_hash(dbp, hash_cb) ;
1099                 RETVAL->hash = newSVsv(*svp) ;
1100             }
1101
1102            svp = hv_fetch(action, "ffactor", 7, FALSE);
1103            if (svp)
1104                (void)dbp->set_h_ffactor(dbp, SvIV(*svp)) ;
1105
1106            svp = hv_fetch(action, "nelem", 5, FALSE);
1107            if (svp)
1108                (void)dbp->set_h_nelem(dbp, SvIV(*svp)) ;
1109
1110            svp = hv_fetch(action, "bsize", 5, FALSE);
1111            if (svp)
1112                (void)dbp->set_pagesize(dbp, SvIV(*svp));
1113
1114            svp = hv_fetch(action, "cachesize", 9, FALSE);
1115            if (svp)
1116                (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ;
1117
1118            svp = hv_fetch(action, "lorder", 6, FALSE);
1119            if (svp)
1120                (void)dbp->set_lorder(dbp, SvIV(*svp)) ;
1121
1122            PrintHash(info) ;
1123         }
1124         else if (sv_isa(sv, "DB_File::BTREEINFO"))
1125         {
1126             if (!isHASH)
1127                 croak("DB_File can only tie an associative array to a DB_BTREE database");
1128
1129             RETVAL->type = DB_BTREE ;
1130
1131             svp = hv_fetch(action, "compare", 7, FALSE);
1132             if (svp && SvOK(*svp))
1133             {
1134                 (void)dbp->set_bt_compare(dbp, btree_compare) ;
1135                 RETVAL->compare = newSVsv(*svp) ;
1136             }
1137
1138             svp = hv_fetch(action, "prefix", 6, FALSE);
1139             if (svp && SvOK(*svp))
1140             {
1141                 (void)dbp->set_bt_prefix(dbp, btree_prefix) ;
1142                 RETVAL->prefix = newSVsv(*svp) ;
1143             }
1144
1145            svp = hv_fetch(action, "flags", 5, FALSE);
1146            if (svp)
1147                (void)dbp->set_flags(dbp, SvIV(*svp)) ;
1148
1149            svp = hv_fetch(action, "cachesize", 9, FALSE);
1150            if (svp)
1151                (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ;
1152
1153            svp = hv_fetch(action, "psize", 5, FALSE);
1154            if (svp)
1155                (void)dbp->set_pagesize(dbp, SvIV(*svp)) ;
1156
1157            svp = hv_fetch(action, "lorder", 6, FALSE);
1158            if (svp)
1159                (void)dbp->set_lorder(dbp, SvIV(*svp)) ;
1160
1161             PrintBtree(info) ;
1162
1163         }
1164         else if (sv_isa(sv, "DB_File::RECNOINFO"))
1165         {
1166             int fixed = FALSE ;
1167
1168             if (isHASH)
1169                 croak("DB_File can only tie an array to a DB_RECNO database");
1170
1171             RETVAL->type = DB_RECNO ;
1172
1173            svp = hv_fetch(action, "flags", 5, FALSE);
1174            if (svp) {
1175                 int flags = SvIV(*svp) ;
1176                 /* remove FIXDLEN, if present */
1177                 if (flags & DB_FIXEDLEN) {
1178                     fixed = TRUE ;
1179                     flags &= ~DB_FIXEDLEN ;
1180                 }
1181            }
1182
1183            svp = hv_fetch(action, "cachesize", 9, FALSE);
1184            if (svp) {
1185                status = dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ;
1186            }
1187
1188            svp = hv_fetch(action, "psize", 5, FALSE);
1189            if (svp) {
1190                status = dbp->set_pagesize(dbp, SvIV(*svp)) ;
1191             }
1192
1193            svp = hv_fetch(action, "lorder", 6, FALSE);
1194            if (svp) {
1195                status = dbp->set_lorder(dbp, SvIV(*svp)) ;
1196            }
1197
1198             svp = hv_fetch(action, "bval", 4, FALSE);
1199             if (svp && SvOK(*svp))
1200             {
1201                 int value ;
1202                 if (SvPOK(*svp))
1203                     value = (int)*SvPV(*svp, n_a) ;
1204                 else
1205                     value = SvIV(*svp) ;
1206
1207                 if (fixed) {
1208                     status = dbp->set_re_pad(dbp, value) ;
1209                 }
1210                 else {
1211                     status = dbp->set_re_delim(dbp, value) ;
1212                 }
1213
1214             }
1215
1216            if (fixed) {
1217                svp = hv_fetch(action, "reclen", 6, FALSE);
1218                if (svp) {
1219                    u_int32_t len =  (u_int32_t)SvIV(*svp) ;
1220                    status = dbp->set_re_len(dbp, len) ;
1221                }
1222            }
1223
1224             if (name != NULL) {
1225                 status = dbp->set_re_source(dbp, name) ;
1226                 name = NULL ;
1227             }
1228
1229             svp = hv_fetch(action, "bfname", 6, FALSE);
1230             if (svp && SvOK(*svp)) {
1231                 char * ptr = SvPV(*svp,n_a) ;
1232                 name = (char*) n_a ? ptr : NULL ;
1233             }
1234             else
1235                 name = NULL ;
1236
1237
1238             status = dbp->set_flags(dbp, DB_RENUMBER) ;
1239
1240                 if (flags){
1241                     (void)dbp->set_flags(dbp, flags) ;
1242                 }
1243             PrintRecno(info) ;
1244         }
1245         else
1246             croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
1247     }
1248
1249     {
1250         int             Flags = 0 ;
1251         int             status ;
1252
1253         /* Map 1.x flags to 3.x flags */
1254         if ((flags & O_CREAT) == O_CREAT)
1255             Flags |= DB_CREATE ;
1256
1257 #if O_RDONLY == 0
1258         if (flags == O_RDONLY)
1259 #else
1260         if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
1261 #endif
1262             Flags |= DB_RDONLY ;
1263
1264 #ifdef O_TRUNC
1265         if ((flags & O_TRUNC) == O_TRUNC)
1266             Flags |= DB_TRUNCATE ;
1267 #endif
1268
1269         status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type,
1270                                 Flags, mode) ;
1271         /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
1272
1273         if (status == 0)
1274             status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
1275                         0) ;
1276         /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
1277
1278         if (status)
1279             RETVAL->dbp = NULL ;
1280
1281     }
1282
1283     return (RETVAL) ;
1284
1285 #endif /* Berkeley DB Version > 2 */
1286
1287 } /* ParseOpenInfo */
1288
1289
1290 static double
1291 #ifdef CAN_PROTOTYPE
1292 constant(char *name, int arg)
1293 #else
1294 constant(name, arg)
1295 char *name;
1296 int arg;
1297 #endif
1298 {
1299     errno = 0;
1300     switch (*name) {
1301     case 'A':
1302         break;
1303     case 'B':
1304         if (strEQ(name, "BTREEMAGIC"))
1305 #ifdef BTREEMAGIC
1306             return BTREEMAGIC;
1307 #else
1308             goto not_there;
1309 #endif
1310         if (strEQ(name, "BTREEVERSION"))
1311 #ifdef BTREEVERSION
1312             return BTREEVERSION;
1313 #else
1314             goto not_there;
1315 #endif
1316         break;
1317     case 'C':
1318         break;
1319     case 'D':
1320         if (strEQ(name, "DB_LOCK"))
1321 #ifdef DB_LOCK
1322             return DB_LOCK;
1323 #else
1324             goto not_there;
1325 #endif
1326         if (strEQ(name, "DB_SHMEM"))
1327 #ifdef DB_SHMEM
1328             return DB_SHMEM;
1329 #else
1330             goto not_there;
1331 #endif
1332         if (strEQ(name, "DB_TXN"))
1333 #ifdef DB_TXN
1334             return (U32)DB_TXN;
1335 #else
1336             goto not_there;
1337 #endif
1338         break;
1339     case 'E':
1340         break;
1341     case 'F':
1342         break;
1343     case 'G':
1344         break;
1345     case 'H':
1346         if (strEQ(name, "HASHMAGIC"))
1347 #ifdef HASHMAGIC
1348             return HASHMAGIC;
1349 #else
1350             goto not_there;
1351 #endif
1352         if (strEQ(name, "HASHVERSION"))
1353 #ifdef HASHVERSION
1354             return HASHVERSION;
1355 #else
1356             goto not_there;
1357 #endif
1358         break;
1359     case 'I':
1360         break;
1361     case 'J':
1362         break;
1363     case 'K':
1364         break;
1365     case 'L':
1366         break;
1367     case 'M':
1368         if (strEQ(name, "MAX_PAGE_NUMBER"))
1369 #ifdef MAX_PAGE_NUMBER
1370             return (U32)MAX_PAGE_NUMBER;
1371 #else
1372             goto not_there;
1373 #endif
1374         if (strEQ(name, "MAX_PAGE_OFFSET"))
1375 #ifdef MAX_PAGE_OFFSET
1376             return MAX_PAGE_OFFSET;
1377 #else
1378             goto not_there;
1379 #endif
1380         if (strEQ(name, "MAX_REC_NUMBER"))
1381 #ifdef MAX_REC_NUMBER
1382             return (U32)MAX_REC_NUMBER;
1383 #else
1384             goto not_there;
1385 #endif
1386         break;
1387     case 'N':
1388         break;
1389     case 'O':
1390         break;
1391     case 'P':
1392         break;
1393     case 'Q':
1394         break;
1395     case 'R':
1396         if (strEQ(name, "RET_ERROR"))
1397 #ifdef RET_ERROR
1398             return RET_ERROR;
1399 #else
1400             goto not_there;
1401 #endif
1402         if (strEQ(name, "RET_SPECIAL"))
1403 #ifdef RET_SPECIAL
1404             return RET_SPECIAL;
1405 #else
1406             goto not_there;
1407 #endif
1408         if (strEQ(name, "RET_SUCCESS"))
1409 #ifdef RET_SUCCESS
1410             return RET_SUCCESS;
1411 #else
1412             goto not_there;
1413 #endif
1414         if (strEQ(name, "R_CURSOR"))
1415 #ifdef R_CURSOR
1416             return R_CURSOR;
1417 #else
1418             goto not_there;
1419 #endif
1420         if (strEQ(name, "R_DUP"))
1421 #ifdef R_DUP
1422             return R_DUP;
1423 #else
1424             goto not_there;
1425 #endif
1426         if (strEQ(name, "R_FIRST"))
1427 #ifdef R_FIRST
1428             return R_FIRST;
1429 #else
1430             goto not_there;
1431 #endif
1432         if (strEQ(name, "R_FIXEDLEN"))
1433 #ifdef R_FIXEDLEN
1434             return R_FIXEDLEN;
1435 #else
1436             goto not_there;
1437 #endif
1438         if (strEQ(name, "R_IAFTER"))
1439 #ifdef R_IAFTER
1440             return R_IAFTER;
1441 #else
1442             goto not_there;
1443 #endif
1444         if (strEQ(name, "R_IBEFORE"))
1445 #ifdef R_IBEFORE
1446             return R_IBEFORE;
1447 #else
1448             goto not_there;
1449 #endif
1450         if (strEQ(name, "R_LAST"))
1451 #ifdef R_LAST
1452             return R_LAST;
1453 #else
1454             goto not_there;
1455 #endif
1456         if (strEQ(name, "R_NEXT"))
1457 #ifdef R_NEXT
1458             return R_NEXT;
1459 #else
1460             goto not_there;
1461 #endif
1462         if (strEQ(name, "R_NOKEY"))
1463 #ifdef R_NOKEY
1464             return R_NOKEY;
1465 #else
1466             goto not_there;
1467 #endif
1468         if (strEQ(name, "R_NOOVERWRITE"))
1469 #ifdef R_NOOVERWRITE
1470             return R_NOOVERWRITE;
1471 #else
1472             goto not_there;
1473 #endif
1474         if (strEQ(name, "R_PREV"))
1475 #ifdef R_PREV
1476             return R_PREV;
1477 #else
1478             goto not_there;
1479 #endif
1480         if (strEQ(name, "R_RECNOSYNC"))
1481 #ifdef R_RECNOSYNC
1482             return R_RECNOSYNC;
1483 #else
1484             goto not_there;
1485 #endif
1486         if (strEQ(name, "R_SETCURSOR"))
1487 #ifdef R_SETCURSOR
1488             return R_SETCURSOR;
1489 #else
1490             goto not_there;
1491 #endif
1492         if (strEQ(name, "R_SNAPSHOT"))
1493 #ifdef R_SNAPSHOT
1494             return R_SNAPSHOT;
1495 #else
1496             goto not_there;
1497 #endif
1498         break;
1499     case 'S':
1500         break;
1501     case 'T':
1502         break;
1503     case 'U':
1504         break;
1505     case 'V':
1506         break;
1507     case 'W':
1508         break;
1509     case 'X':
1510         break;
1511     case 'Y':
1512         break;
1513     case 'Z':
1514         break;
1515     case '_':
1516         break;
1517     }
1518     errno = EINVAL;
1519     return 0;
1520
1521 not_there:
1522     errno = ENOENT;
1523     return 0;
1524 }
1525
1526 MODULE = DB_File        PACKAGE = DB_File       PREFIX = db_
1527
1528 BOOT:
1529   {
1530     __getBerkeleyDBInfo() ;
1531
1532     DBT_clear(empty) ;
1533     empty.data = &zero ;
1534     empty.size =  sizeof(recno_t) ;
1535   }
1536
1537 double
1538 constant(name,arg)
1539         char *          name
1540         int             arg
1541
1542
1543 DB_File
1544 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1545         int             isHASH
1546         char *          dbtype
1547         int             flags
1548         int             mode
1549         CODE:
1550         {
1551             char *      name = (char *) NULL ;
1552             SV *        sv = (SV *) NULL ;
1553             STRLEN      n_a;
1554
1555             if (items >= 3 && SvOK(ST(2)))
1556                 name = (char*) SvPV(ST(2), n_a) ;
1557
1558             if (items == 6)
1559                 sv = ST(5) ;
1560
1561             RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1562             if (RETVAL->dbp == NULL)
1563                 RETVAL = NULL ;
1564         }
1565         OUTPUT:
1566             RETVAL
1567
1568 int
1569 db_DESTROY(db)
1570         DB_File         db
1571         INIT:
1572           CurrentDB = db ;
1573         CLEANUP:
1574           if (db->hash)
1575             SvREFCNT_dec(db->hash) ;
1576           if (db->compare)
1577             SvREFCNT_dec(db->compare) ;
1578           if (db->prefix)
1579             SvREFCNT_dec(db->prefix) ;
1580 #ifdef DBM_FILTERING
1581           if (db->filter_fetch_key)
1582             SvREFCNT_dec(db->filter_fetch_key) ;
1583           if (db->filter_store_key)
1584             SvREFCNT_dec(db->filter_store_key) ;
1585           if (db->filter_fetch_value)
1586             SvREFCNT_dec(db->filter_fetch_value) ;
1587           if (db->filter_store_value)
1588             SvREFCNT_dec(db->filter_store_value) ;
1589 #endif /* DBM_FILTERING */
1590           safefree(db) ;
1591 #ifdef DB_VERSION_MAJOR
1592           if (RETVAL > 0)
1593             RETVAL = -1 ;
1594 #endif
1595
1596
1597 int
1598 db_DELETE(db, key, flags=0)
1599         DB_File         db
1600         DBTKEY          key
1601         u_int           flags
1602         INIT:
1603           CurrentDB = db ;
1604
1605
1606 int
1607 db_EXISTS(db, key)
1608         DB_File         db
1609         DBTKEY          key
1610         CODE:
1611         {
1612           DBT           value ;
1613
1614           DBT_clear(value) ;
1615           CurrentDB = db ;
1616           RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1617         }
1618         OUTPUT:
1619           RETVAL
1620
1621 int
1622 db_FETCH(db, key, flags=0)
1623         DB_File         db
1624         DBTKEY          key
1625         u_int           flags
1626         CODE:
1627         {
1628             DBT         value ;
1629
1630             DBT_clear(value) ;
1631             CurrentDB = db ;
1632             /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */
1633             RETVAL = db_get(db, key, value, flags) ;
1634             ST(0) = sv_newmortal();
1635             OutputValue(ST(0), value)
1636         }
1637
1638 int
1639 db_STORE(db, key, value, flags=0)
1640         DB_File         db
1641         DBTKEY          key
1642         DBT             value
1643         u_int           flags
1644         INIT:
1645           CurrentDB = db ;
1646
1647
1648 int
1649 db_FIRSTKEY(db)
1650         DB_File         db
1651         CODE:
1652         {
1653             DBTKEY      key ;
1654             DBT         value ;
1655
1656             DBT_clear(key) ;
1657             DBT_clear(value) ;
1658             CurrentDB = db ;
1659             RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1660             ST(0) = sv_newmortal();
1661             OutputKey(ST(0), key) ;
1662         }
1663
1664 int
1665 db_NEXTKEY(db, key)
1666         DB_File         db
1667         DBTKEY          key
1668         CODE:
1669         {
1670             DBT         value ;
1671
1672             DBT_clear(value) ;
1673             CurrentDB = db ;
1674             RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1675             ST(0) = sv_newmortal();
1676             OutputKey(ST(0), key) ;
1677         }
1678
1679 #
1680 # These would be nice for RECNO
1681 #
1682
1683 int
1684 unshift(db, ...)
1685         DB_File         db
1686         ALIAS:          UNSHIFT = 1
1687         CODE:
1688         {
1689             DBTKEY      key ;
1690             DBT         value ;
1691             int         i ;
1692             int         One ;
1693             DB *        Db = db->dbp ;
1694             STRLEN      n_a;
1695
1696             DBT_clear(key) ;
1697             DBT_clear(value) ;
1698             CurrentDB = db ;
1699 #ifdef DB_VERSION_MAJOR
1700             /* get the first value */
1701             RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1702             RETVAL = 0 ;
1703 #else
1704             RETVAL = -1 ;
1705 #endif
1706             for (i = items-1 ; i > 0 ; --i)
1707             {
1708                 value.data = SvPV(ST(i), n_a) ;
1709                 value.size = n_a ;
1710                 One = 1 ;
1711                 key.data = &One ;
1712                 key.size = sizeof(int) ;
1713 #ifdef DB_VERSION_MAJOR
1714                 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1715 #else
1716                 RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
1717 #endif
1718                 if (RETVAL != 0)
1719                     break;
1720             }
1721         }
1722         OUTPUT:
1723             RETVAL
1724
1725 I32
1726 pop(db)
1727         DB_File         db
1728         ALIAS:          POP = 1
1729         CODE:
1730         {
1731             DBTKEY      key ;
1732             DBT         value ;
1733
1734             DBT_clear(key) ;
1735             DBT_clear(value) ;
1736             CurrentDB = db ;
1737
1738             /* First get the final value */
1739             RETVAL = do_SEQ(db, key, value, R_LAST) ;
1740             ST(0) = sv_newmortal();
1741             /* Now delete it */
1742             if (RETVAL == 0)
1743             {
1744                 /* the call to del will trash value, so take a copy now */
1745                 OutputValue(ST(0), value) ;
1746                 RETVAL = db_del(db, key, R_CURSOR) ;
1747                 if (RETVAL != 0)
1748                     sv_setsv(ST(0), &PL_sv_undef);
1749             }
1750         }
1751
1752 I32
1753 shift(db)
1754         DB_File         db
1755         ALIAS:          SHIFT = 1
1756         CODE:
1757         {
1758             DBT         value ;
1759             DBTKEY      key ;
1760
1761             DBT_clear(key) ;
1762             DBT_clear(value) ;
1763             CurrentDB = db ;
1764             /* get the first value */
1765             RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1766             ST(0) = sv_newmortal();
1767             /* Now delete it */
1768             if (RETVAL == 0)
1769             {
1770                 /* the call to del will trash value, so take a copy now */
1771                 OutputValue(ST(0), value) ;
1772                 RETVAL = db_del(db, key, R_CURSOR) ;
1773                 if (RETVAL != 0)
1774                     sv_setsv (ST(0), &PL_sv_undef) ;
1775             }
1776         }
1777
1778
1779 I32
1780 push(db, ...)
1781         DB_File         db
1782         ALIAS:          PUSH = 1
1783         CODE:
1784         {
1785             DBTKEY      key ;
1786             DBT         value ;
1787             DB *        Db = db->dbp ;
1788             int         i ;
1789             STRLEN      n_a;
1790             int         keyval ;
1791
1792             DBT_flags(key) ;
1793             DBT_flags(value) ;
1794             CurrentDB = db ;
1795             /* Set the Cursor to the Last element */
1796             RETVAL = do_SEQ(db, key, value, R_LAST) ;
1797 #ifndef DB_VERSION_MAJOR
1798             if (RETVAL >= 0)
1799 #endif
1800             {
1801                 if (RETVAL == 0)
1802                     keyval = *(int*)key.data ;
1803                 else
1804                     keyval = 0 ;
1805                 for (i = 1 ; i < items ; ++i)
1806                 {
1807                     value.data = SvPV(ST(i), n_a) ;
1808                     value.size = n_a ;
1809                     ++ keyval ;
1810                     key.data = &keyval ;
1811                     key.size = sizeof(int) ;
1812                     RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1813                     if (RETVAL != 0)
1814                         break;
1815                 }
1816             }
1817         }
1818         OUTPUT:
1819             RETVAL
1820
1821 I32
1822 length(db)
1823         DB_File         db
1824         ALIAS:          FETCHSIZE = 1
1825         CODE:
1826             CurrentDB = db ;
1827             RETVAL = GetArrayLength(aTHX_ db) ;
1828         OUTPUT:
1829             RETVAL
1830
1831
1832 #
1833 # Now provide an interface to the rest of the DB functionality
1834 #
1835
1836 int
1837 db_del(db, key, flags=0)
1838         DB_File         db
1839         DBTKEY          key
1840         u_int           flags
1841         CODE:
1842           CurrentDB = db ;
1843           RETVAL = db_del(db, key, flags) ;
1844 #ifdef DB_VERSION_MAJOR
1845           if (RETVAL > 0)
1846             RETVAL = -1 ;
1847           else if (RETVAL == DB_NOTFOUND)
1848             RETVAL = 1 ;
1849 #endif
1850         OUTPUT:
1851           RETVAL
1852
1853
1854 int
1855 db_get(db, key, value, flags=0)
1856         DB_File         db
1857         DBTKEY          key
1858         DBT             value = NO_INIT
1859         u_int           flags
1860         CODE:
1861           CurrentDB = db ;
1862           DBT_clear(value) ;
1863           RETVAL = db_get(db, key, value, flags) ;
1864 #ifdef DB_VERSION_MAJOR
1865           if (RETVAL > 0)
1866             RETVAL = -1 ;
1867           else if (RETVAL == DB_NOTFOUND)
1868             RETVAL = 1 ;
1869 #endif
1870         OUTPUT:
1871           RETVAL
1872           value
1873
1874 int
1875 db_put(db, key, value, flags=0)
1876         DB_File         db
1877         DBTKEY          key
1878         DBT             value
1879         u_int           flags
1880         CODE:
1881           CurrentDB = db ;
1882           RETVAL = db_put(db, key, value, flags) ;
1883 #ifdef DB_VERSION_MAJOR
1884           if (RETVAL > 0)
1885             RETVAL = -1 ;
1886           else if (RETVAL == DB_KEYEXIST)
1887             RETVAL = 1 ;
1888 #endif
1889         OUTPUT:
1890           RETVAL
1891           key           if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1892
1893 int
1894 db_fd(db)
1895         DB_File         db
1896         int             status = 0 ;
1897         CODE:
1898           CurrentDB = db ;
1899 #ifdef DB_VERSION_MAJOR
1900           RETVAL = -1 ;
1901           status = (db->in_memory
1902                 ? -1
1903                 : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1904           if (status != 0)
1905             RETVAL = -1 ;
1906 #else
1907           RETVAL = (db->in_memory
1908                 ? -1
1909                 : ((db->dbp)->fd)(db->dbp) ) ;
1910 #endif
1911         OUTPUT:
1912           RETVAL
1913
1914 int
1915 db_sync(db, flags=0)
1916         DB_File         db
1917         u_int           flags
1918         CODE:
1919           CurrentDB = db ;
1920           RETVAL = db_sync(db, flags) ;
1921 #ifdef DB_VERSION_MAJOR
1922           if (RETVAL > 0)
1923             RETVAL = -1 ;
1924 #endif
1925         OUTPUT:
1926           RETVAL
1927
1928
1929 int
1930 db_seq(db, key, value, flags)
1931         DB_File         db
1932         DBTKEY          key
1933         DBT             value = NO_INIT
1934         u_int           flags
1935         CODE:
1936           CurrentDB = db ;
1937           DBT_clear(value) ;
1938           RETVAL = db_seq(db, key, value, flags);
1939 #ifdef DB_VERSION_MAJOR
1940           if (RETVAL > 0)
1941             RETVAL = -1 ;
1942           else if (RETVAL == DB_NOTFOUND)
1943             RETVAL = 1 ;
1944 #endif
1945         OUTPUT:
1946           RETVAL
1947           key
1948           value
1949
1950 #ifdef DBM_FILTERING
1951
1952 #define setFilter(type)                                 \
1953         {                                               \
1954             if (db->type)                               \
1955                 RETVAL = sv_mortalcopy(db->type) ;      \
1956             ST(0) = RETVAL ;                            \
1957             if (db->type && (code == &PL_sv_undef)) {   \
1958                 SvREFCNT_dec(db->type) ;                \
1959                 db->type = NULL ;                       \
1960             }                                           \
1961             else if (code) {                            \
1962                 if (db->type)                           \
1963                     sv_setsv(db->type, code) ;          \
1964                 else                                    \
1965                     db->type = newSVsv(code) ;          \
1966             }                                           \
1967         }
1968
1969
1970 SV *
1971 filter_fetch_key(db, code)
1972         DB_File         db
1973         SV *            code
1974         SV *            RETVAL = &PL_sv_undef ;
1975         CODE:
1976             setFilter(filter_fetch_key) ;
1977
1978 SV *
1979 filter_store_key(db, code)
1980         DB_File         db
1981         SV *            code
1982         SV *            RETVAL = &PL_sv_undef ;
1983         CODE:
1984             setFilter(filter_store_key) ;
1985
1986 SV *
1987 filter_fetch_value(db, code)
1988         DB_File         db
1989         SV *            code
1990         SV *            RETVAL = &PL_sv_undef ;
1991         CODE:
1992             setFilter(filter_fetch_value) ;
1993
1994 SV *
1995 filter_store_value(db, code)
1996         DB_File         db
1997         SV *            code
1998         SV *            RETVAL = &PL_sv_undef ;
1999         CODE:
2000             setFilter(filter_store_value) ;
2001
2002 #endif /* DBM_FILTERING */