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