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