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