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