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