ext/DB_File/DB_File.xs

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