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