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