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