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