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