ext/DB_File/DB_File.xs

   1 /*
   2
   3  DB_File.xs -- Perl 5 interface to Berkeley DB
   4
   5  written by Paul Marquess <Paul.Marquess@btinternet.com>
   6  last modified 1st September 2002
   7  version 1.805
   8
   9  All comments/suggestions/problems are welcome
  10
  11      Copyright (c) 1995-2002 Paul Marquess. All rights reserved.
  12      This program is free software; you can redistribute it and/or
  13      modify it under the same terms as Perl itself.
  14
  15  Changes:
  16         0.1 -   Initial Release
  17         0.2 -   No longer bombs out if dbopen returns an error.
  18         0.3 -   Added some support for multiple btree compares
  19         1.0 -   Complete support for multiple callbacks added.
  20                 Fixed a problem with pushing a value onto an empty list.
  21         1.01 -  Fixed a SunOS core dump problem.
  22                 The return value from TIEHASH wasn't set to NULL when
  23                 dbopen returned an error.
  24         1.02 -  Use ALIAS to define TIEARRAY.
  25                 Removed some redundant commented code.
  26                 Merged OS2 code into the main distribution.
  27                 Allow negative subscripts with RECNO interface.
  28                 Changed the default flags to O_CREAT|O_RDWR
  29         1.03 -  Added EXISTS
  30         1.04 -  fixed a couple of bugs in hash_cb. Patches supplied by
  31                 Dave Hammen, hammen@gothamcity.jsc.nasa.gov
  32         1.05 -  Added logic to allow prefix & hash types to be specified via
  33                 Makefile.PL
  34         1.06 -  Minor namespace cleanup: Localized PrintBtree.
  35         1.07 -  Fixed bug with RECNO, where bval wasn't defaulting to "\n".
  36         1.08 -  No change to DB_File.xs
  37         1.09 -  Default mode for dbopen changed to 0666
  38         1.10 -  Fixed fd method so that it still returns -1 for
  39                 in-memory files when db 1.86 is used.
  40         1.11 -  No change to DB_File.xs
  41         1.12 -  No change to DB_File.xs
  42         1.13 -  Tidied up a few casts.
  43         1.14 -  Made it illegal to tie an associative array to a RECNO
  44                 database and an ordinary array to a HASH or BTREE database.
  45         1.50 -  Make work with both DB 1.x or DB 2.x
  46         1.51 -  Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
  47         1.52 -  Patch from Gisle Aas <gisle@aas.no> to suppress "use of
  48                 undefined value" warning with db_get and db_seq.
  49         1.53 -  Added DB_RENUMBER to flags for recno.
  50         1.54 -  Fixed bug in the fd method
  51         1.55 -  Fix for AIX from Jarkko Hietaniemi
  52         1.56 -  No change to DB_File.xs
  53         1.57 -  added the #undef op to allow building with Threads support.
  54         1.58 -  Fixed a problem with the use of sv_setpvn. When the
  55                 size is specified as 0, it does a strlen on the data.
  56                 This was ok for DB 1.x, but isn't for DB 2.x.
  57         1.59 -  No change to DB_File.xs
  58         1.60 -  Some code tidy up
  59         1.61 -  added flagSet macro for DB 2.5.x
  60                 fixed typo in O_RDONLY test.
  61         1.62 -  No change to DB_File.xs
  62         1.63 -  Fix to alllow DB 2.6.x to build.
  63         1.64 -  Tidied up the 1.x to 2.x flags mapping code.
  64                 Added a patch from Mark Kettenis <kettenis@wins.uva.nl>
  65                 to fix a flag mapping problem with O_RDONLY on the Hurd
  66         1.65 -  Fixed a bug in the PUSH logic.
  67                 Added BOOT check that using 2.3.4 or greater
  68         1.66 -  Added DBM filter code
  69         1.67 -  Backed off the use of newSVpvn.
  70                 Fixed DBM Filter code for Perl 5.004.
  71                 Fixed a small memory leak in the filter code.
  72         1.68 -  fixed backward compatability bug with R_IAFTER & R_IBEFORE
  73                 merged in the 5.005_58 changes
  74         1.69 -  fixed a bug in push -- DB_APPEND wasn't working properly.
  75                 Fixed the R_SETCURSOR bug introduced in 1.68
  76                 Added a new Perl variable $DB_File::db_ver
  77         1.70 -  Initialise $DB_File::db_ver and $DB_File::db_version with
  78                 GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons.
  79                 Added a BOOT check to test for equivalent versions of db.h &
  80                 libdb.a/so.
  81         1.71 -  Support for Berkeley DB version 3.
  82                 Support for Berkeley DB 2/3's backward compatability mode.
  83                 Rewrote push
  84         1.72 -  No change to DB_File.xs
  85         1.73 -  No change to DB_File.xs
  86         1.74 -  A call to open needed parenthesised to stop it clashing
  87                 with a win32 macro.
  88                 Added Perl core patches 7703 & 7801.
  89         1.75 -  Fixed Perl core patch 7703.
  90                 Added suppport to allow DB_File to be built with
  91                 Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb
  92                 needed to be changed.
  93         1.76 -  No change to DB_File.xs
  94         1.77 -  Tidied up a few types used in calling newSVpvn.
  95         1.78 -  Core patch 10335, 10372, 10534, 10549, 11051 included.
  96         1.79 -  NEXTKEY ignores the input key.
  97                 Added lots of casts
  98         1.800 - Moved backward compatability code into ppport.h.
  99                 Use the new constants code.
 100         1.801 - No change to DB_File.xs
 101         1.802 - No change to DB_File.xs
 102         1.803 - FETCH, STORE & DELETE don't map the flags parameter
 103                 into the equivalent Berkeley DB function anymore.
 104         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
 109 */
 110
 111 #define PERL_NO_GET_CONTEXT
 112 #include "EXTERN.h"
 113 #include "perl.h"
 114 #include "XSUB.h"
 115
 116 #ifdef _NOT_CORE
 117 #  include "ppport.h"
 118 #endif
 119
 120 /* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
 121    DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
 122
 123 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
 124  * shortly #included by the <db.h>) __attribute__ to the possibly
 125  * already defined __attribute__, for example by GNUC or by Perl. */
 126
 127 /* #if DB_VERSION_MAJOR_CFG < 2  */
 128 #ifndef DB_VERSION_MAJOR
 129 #    undef __attribute__
 130 #endif
 131
 132 #ifdef COMPAT185
 133 #    include <db_185.h>
 134 #else
 135 #    include <db.h>
 136 #endif
 137
 138 /* Wall starts with 5.7.x */
 139
 140 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
 141
 142 /* Since we dropped the gccish definition of __attribute__ we will want
 143  * to redefine dNOOP, however (so that dTHX continues to work).  Yes,
 144  * all this means that we can't do attribute checking on the DB_File,
 145  * boo, hiss. */
 146 #  ifndef DB_VERSION_MAJOR
 147
 148 #    undef  dNOOP
 149 #    define dNOOP extern int Perl___notused
 150
 151     /* Ditto for dXSARGS. */
 152 #    undef  dXSARGS
 153 #    define dXSARGS                             \
 154         dSP; dMARK;                     \
 155         I32 ax = mark - PL_stack_base + 1;      \
 156         I32 items = sp - mark
 157
 158 #  endif
 159
 160 /* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
 161 #  undef dXSI32
 162 #  define dXSI32 dNOOP
 163
 164 #endif /* Perl >= 5.7 */
 165
 166 #include <fcntl.h>
 167
 168 /* #define TRACE */
 169
 170 #ifdef TRACE
 171 #    define Trace(x)        printf x
 172 #else
 173 #    define Trace(x)
 174 #endif
 175
 176
 177 #define DBT_clear(x)    Zero(&x, 1, DBT) ;
 178
 179 #ifdef DB_VERSION_MAJOR
 180
 181 #if DB_VERSION_MAJOR == 2
 182 #    define BERKELEY_DB_1_OR_2
 183 #endif
 184
 185 #if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
 186 #    define AT_LEAST_DB_3_2
 187 #endif
 188
 189 #if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
 190 #    define AT_LEAST_DB_4_1
 191 #endif
 192
 193 /* map version 2 features & constants onto their version 1 equivalent */
 194
 195 #ifdef DB_Prefix_t
 196 #    undef DB_Prefix_t
 197 #endif
 198 #define DB_Prefix_t     size_t
 199
 200 #ifdef DB_Hash_t
 201 #    undef DB_Hash_t
 202 #endif
 203 #define DB_Hash_t       u_int32_t
 204
 205 /* DBTYPE stays the same */
 206 /* HASHINFO, RECNOINFO and BTREEINFO  map to DB_INFO */
 207 #if DB_VERSION_MAJOR == 2
 208     typedef DB_INFO     INFO ;
 209 #else /* DB_VERSION_MAJOR > 2 */
 210 #    define DB_FIXEDLEN (0x8000)
 211 #endif /* DB_VERSION_MAJOR == 2 */
 212
 213 /* version 2 has db_recno_t in place of recno_t */
 214 typedef db_recno_t      recno_t;
 215
 216
 217 #define R_CURSOR        DB_SET_RANGE
 218 #define R_FIRST         DB_FIRST
 219 #define R_IAFTER        DB_AFTER
 220 #define R_IBEFORE       DB_BEFORE
 221 #define R_LAST          DB_LAST
 222 #define R_NEXT          DB_NEXT
 223 #define R_NOOVERWRITE   DB_NOOVERWRITE
 224 #define R_PREV          DB_PREV
 225
 226 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
 227 #  define R_SETCURSOR   0x800000
 228 #else
 229 #  define R_SETCURSOR   (-100)
 230 #endif
 231
 232 #define R_RECNOSYNC     0
 233 #define R_FIXEDLEN      DB_FIXEDLEN
 234 #define R_DUP           DB_DUP
 235
 236
 237 #define db_HA_hash      h_hash
 238 #define db_HA_ffactor   h_ffactor
 239 #define db_HA_nelem     h_nelem
 240 #define db_HA_bsize     db_pagesize
 241 #define db_HA_cachesize db_cachesize
 242 #define db_HA_lorder    db_lorder
 243
 244 #define db_BT_compare   bt_compare
 245 #define db_BT_prefix    bt_prefix
 246 #define db_BT_flags     flags
 247 #define db_BT_psize     db_pagesize
 248 #define db_BT_cachesize db_cachesize
 249 #define db_BT_lorder    db_lorder
 250 #define db_BT_maxkeypage
 251 #define db_BT_minkeypage
 252
 253
 254 #define db_RE_reclen    re_len
 255 #define db_RE_flags     flags
 256 #define db_RE_bval      re_pad
 257 #define db_RE_bfname    re_source
 258 #define db_RE_psize     db_pagesize
 259 #define db_RE_cachesize db_cachesize
 260 #define db_RE_lorder    db_lorder
 261
 262 #define TXN     NULL,
 263
 264 #define do_SEQ(db, key, value, flag)    (db->cursor->c_get)(db->cursor, &key, &value, flag)
 265
 266
 267 #define DBT_flags(x)    x.flags = 0
 268 #define DB_flags(x, v)  x |= v
 269
 270 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
 271 #    define flagSet(flags, bitmask)     ((flags) & (bitmask))
 272 #else
 273 #    define flagSet(flags, bitmask)     (((flags) & DB_OPFLAGS_MASK) == (bitmask))
 274 #endif
 275
 276 #else /* db version 1.x */
 277
 278 #define BERKELEY_DB_1
 279 #define BERKELEY_DB_1_OR_2
 280
 281 typedef union INFO {
 282         HASHINFO        hash ;
 283         RECNOINFO       recno ;
 284         BTREEINFO       btree ;
 285       } INFO ;
 286
 287
 288 #ifdef mDB_Prefix_t
 289 #  ifdef DB_Prefix_t
 290 #    undef DB_Prefix_t
 291 #  endif
 292 #  define DB_Prefix_t   mDB_Prefix_t
 293 #endif
 294
 295 #ifdef mDB_Hash_t
 296 #  ifdef DB_Hash_t
 297 #    undef DB_Hash_t
 298 #  endif
 299 #  define DB_Hash_t     mDB_Hash_t
 300 #endif
 301
 302 #define db_HA_hash      hash.hash
 303 #define db_HA_ffactor   hash.ffactor
 304 #define db_HA_nelem     hash.nelem
 305 #define db_HA_bsize     hash.bsize
 306 #define db_HA_cachesize hash.cachesize
 307 #define db_HA_lorder    hash.lorder
 308
 309 #define db_BT_compare   btree.compare
 310 #define db_BT_prefix    btree.prefix
 311 #define db_BT_flags     btree.flags
 312 #define db_BT_psize     btree.psize
 313 #define db_BT_cachesize btree.cachesize
 314 #define db_BT_lorder    btree.lorder
 315 #define db_BT_maxkeypage btree.maxkeypage
 316 #define db_BT_minkeypage btree.minkeypage
 317
 318 #define db_RE_reclen    recno.reclen
 319 #define db_RE_flags     recno.flags
 320 #define db_RE_bval      recno.bval
 321 #define db_RE_bfname    recno.bfname
 322 #define db_RE_psize     recno.psize
 323 #define db_RE_cachesize recno.cachesize
 324 #define db_RE_lorder    recno.lorder
 325
 326 #define TXN
 327
 328 #define do_SEQ(db, key, value, flag)    (db->dbp->seq)(db->dbp, &key, &value, flag)
 329 #define DBT_flags(x)
 330 #define DB_flags(x, v)
 331 #define flagSet(flags, bitmask)        ((flags) & (bitmask))
 332
 333 #endif /* db version 1 */
 334
 335
 336
 337 #define db_DELETE(db, key, flags)       ((db->dbp)->del)(db->dbp, TXN &key, 0)
 338 #define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
 339 #define db_FETCH(db, key, flags)        ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
 340
 341 #define db_sync(db, flags)              ((db->dbp)->sync)(db->dbp, flags)
 342 #define db_get(db, key, value, flags)   ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
 343
 344 #ifdef DB_VERSION_MAJOR
 345 #define db_DESTROY(db)                  (!db->aborted && ( db->cursor->c_close(db->cursor),\
 346                                           (db->dbp->close)(db->dbp, 0) ))
 347 #define db_close(db)                    ((db->dbp)->close)(db->dbp, 0)
 348 #define db_del(db, key, flags)          (flagSet(flags, R_CURSOR)                                       \
 349                                                 ? ((db->cursor)->c_del)(db->cursor, 0)          \
 350                                                 : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
 351
 352 #else /* ! DB_VERSION_MAJOR */
 353
 354 #define db_DESTROY(db)                  (!db->aborted && ((db->dbp)->close)(db->dbp))
 355 #define db_close(db)                    ((db->dbp)->close)(db->dbp)
 356 #define db_del(db, key, flags)          ((db->dbp)->del)(db->dbp, &key, flags)
 357 #define db_put(db, key, value, flags)   ((db->dbp)->put)(db->dbp, &key, &value, flags)
 358
 359 #endif /* ! DB_VERSION_MAJOR */
 360
 361
 362 #define db_seq(db, key, value, flags)   do_SEQ(db, key, value, flags)
 363
 364 typedef struct {
 365         DBTYPE  type ;
 366         DB *    dbp ;
 367         SV *    compare ;
 368         bool    in_compare ;
 369         SV *    prefix ;
 370         bool    in_prefix ;
 371         SV *    hash ;
 372         bool    in_hash ;
 373         bool    aborted ;
 374         int     in_memory ;
 375 #ifdef BERKELEY_DB_1_OR_2
 376         INFO    info ;
 377 #endif
 378 #ifdef DB_VERSION_MAJOR
 379         DBC *   cursor ;
 380 #endif
 381         SV *    filter_fetch_key ;
 382         SV *    filter_store_key ;
 383         SV *    filter_fetch_value ;
 384         SV *    filter_store_value ;
 385         int     filtering ;
 386
 387         } DB_File_type;
 388
 389 typedef DB_File_type * DB_File ;
 390 typedef DBT DBTKEY ;
 391
 392 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
 393
 394 #define OutputValue(arg, name)                                          \
 395         { if (RETVAL == 0) {                                            \
 396               my_sv_setpvn(arg, name.data, name.size) ;                 \
 397               TAINT;                                            \
 398               SvTAINTED_on(arg);                                        \
 399               DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ;      \
 400           }                                                             \
 401         }
 402
 403 #define OutputKey(arg, name)                                            \
 404         { if (RETVAL == 0)                                              \
 405           {                                                             \
 406                 if (db->type != DB_RECNO) {                             \
 407                     my_sv_setpvn(arg, name.data, name.size);            \
 408                 }                                                       \
 409                 else                                                    \
 410                     sv_setiv(arg, (I32)*(I32*)name.data - 1);           \
 411               TAINT;                                            \
 412               SvTAINTED_on(arg);                                        \
 413               DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ;  \
 414           }                                                             \
 415         }
 416
 417 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
 418
 419 #ifdef CAN_PROTOTYPE
 420 extern void __getBerkeleyDBInfo(void);
 421 #endif
 422
 423 /* Internal Global Data */
 424
 425 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION
 426
 427 typedef struct {
 428     recno_t     x_Value;
 429     recno_t     x_zero;
 430     DB_File     x_CurrentDB;
 431     DBTKEY      x_empty;
 432 } my_cxt_t;
 433
 434 START_MY_CXT
 435
 436 #define Value           (MY_CXT.x_Value)
 437 #define zero            (MY_CXT.x_zero)
 438 #define CurrentDB       (MY_CXT.x_CurrentDB)
 439 #define empty           (MY_CXT.x_empty)
 440
 441 #define ERR_BUFF "DB_File::Error"
 442
 443 #ifdef DB_VERSION_MAJOR
 444
 445 static int
 446 #ifdef CAN_PROTOTYPE
 447 db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
 448 #else
 449 db_put(db, key, value, flags)
 450 DB_File         db ;
 451 DBTKEY          key ;
 452 DBT             value ;
 453 u_int           flags ;
 454 #endif
 455 {
 456     int status ;
 457
 458     if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
 459         DBC * temp_cursor ;
 460         DBT l_key, l_value;
 461
 462 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
 463         if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
 464 #else
 465         if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
 466 #endif
 467             return (-1) ;
 468
 469         memset(&l_key, 0, sizeof(l_key));
 470         l_key.data = key.data;
 471         l_key.size = key.size;
 472         memset(&l_value, 0, sizeof(l_value));
 473         l_value.data = value.data;
 474         l_value.size = value.size;
 475
 476         if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
 477             (void)temp_cursor->c_close(temp_cursor);
 478             return (-1);
 479         }
 480
 481         status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
 482         (void)temp_cursor->c_close(temp_cursor);
 483
 484         return (status) ;
 485     }
 486
 487
 488     if (flagSet(flags, R_CURSOR)) {
 489         return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
 490     }
 491
 492     if (flagSet(flags, R_SETCURSOR)) {
 493         if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
 494                 return -1 ;
 495         return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
 496
 497     }
 498
 499     return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
 500
 501 }
 502
 503 #endif /* DB_VERSION_MAJOR */
 504
 505 static void
 506 tidyUp(DB_File db)
 507 {
 508     /* db_DESTROY(db); */
 509     db->aborted = TRUE ;
 510 }
 511
 512
 513 static int
 514 #ifdef AT_LEAST_DB_3_2
 515
 516 #ifdef CAN_PROTOTYPE
 517 btree_compare(DB * db, const DBT *key1, const DBT *key2)
 518 #else
 519 btree_compare(db, key1, key2)
 520 DB * db ;
 521 const DBT * key1 ;
 522 const DBT * key2 ;
 523 #endif /* CAN_PROTOTYPE */
 524
 525 #else /* Berkeley DB < 3.2 */
 526
 527 #ifdef CAN_PROTOTYPE
 528 btree_compare(const DBT *key1, const DBT *key2)
 529 #else
 530 btree_compare(key1, key2)
 531 const DBT * key1 ;
 532 const DBT * key2 ;
 533 #endif
 534
 535 #endif
 536
 537 {
 538 #ifdef dTHX
 539     dTHX;
 540 #endif
 541     dSP ;
 542     dMY_CXT ;
 543     void * data1, * data2 ;
 544     int retval ;
 545     int count ;
 546     DB_File     keep_CurrentDB = CurrentDB;
 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
 571     PUSHMARK(SP) ;
 572     EXTEND(SP,2) ;
 573     PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
 574     PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
 575     PUTBACK ;
 576
 577     CurrentDB->in_compare = TRUE;
 578
 579     count = perl_call_sv(CurrentDB->compare, G_SCALAR);
 580
 581     CurrentDB = keep_CurrentDB;
 582     CurrentDB->in_compare = FALSE;
 583
 584     SPAGAIN ;
 585
 586     if (count != 1){
 587         tidyUp(CurrentDB);
 588         croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
 589     }
 590
 591     retval = POPi ;
 592
 593     PUTBACK ;
 594     FREETMPS ;
 595     LEAVE ;
 596
 597     return (retval) ;
 598
 599 }
 600
 601 static DB_Prefix_t
 602 #ifdef AT_LEAST_DB_3_2
 603
 604 #ifdef CAN_PROTOTYPE
 605 btree_prefix(DB * db, const DBT *key1, const DBT *key2)
 606 #else
 607 btree_prefix(db, key1, key2)
 608 Db * db ;
 609 const DBT * key1 ;
 610 const DBT * key2 ;
 611 #endif
 612
 613 #else /* Berkeley DB < 3.2 */
 614
 615 #ifdef CAN_PROTOTYPE
 616 btree_prefix(const DBT *key1, const DBT *key2)
 617 #else
 618 btree_prefix(key1, key2)
 619 const DBT * key1 ;
 620 const DBT * key2 ;
 621 #endif
 622
 623 #endif
 624 {
 625 #ifdef dTHX
 626     dTHX;
 627 #endif
 628     dSP ;
 629     dMY_CXT ;
 630     char * data1, * data2 ;
 631     int retval ;
 632     int count ;
 633     DB_File     keep_CurrentDB = CurrentDB;
 634
 635     if (CurrentDB->in_prefix){
 636         tidyUp(CurrentDB);
 637         croak ("DB_File btree_prefix: recursion detected\n") ;
 638     }
 639
 640     data1 = (char *) key1->data ;
 641     data2 = (char *) key2->data ;
 642
 643 #ifndef newSVpvn
 644     /* As newSVpv will assume that the data pointer is a null terminated C
 645        string if the size parameter is 0, make sure that data points to an
 646        empty string if the length is 0
 647     */
 648     if (key1->size == 0)
 649         data1 = "" ;
 650     if (key2->size == 0)
 651         data2 = "" ;
 652 #endif
 653
 654     ENTER ;
 655     SAVETMPS;
 656
 657     PUSHMARK(SP) ;
 658     EXTEND(SP,2) ;
 659     PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
 660     PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
 661     PUTBACK ;
 662
 663     CurrentDB->in_prefix = TRUE;
 664
 665     count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
 666
 667     CurrentDB = keep_CurrentDB;
 668     CurrentDB->in_prefix = FALSE;
 669
 670     SPAGAIN ;
 671
 672     if (count != 1){
 673         tidyUp(CurrentDB);
 674         croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
 675     }
 676
 677     retval = POPi ;
 678
 679     PUTBACK ;
 680     FREETMPS ;
 681     LEAVE ;
 682
 683     return (retval) ;
 684 }
 685
 686
 687 #ifdef BERKELEY_DB_1
 688 #    define HASH_CB_SIZE_TYPE size_t
 689 #else
 690 #    define HASH_CB_SIZE_TYPE u_int32_t
 691 #endif
 692
 693 static DB_Hash_t
 694 #ifdef AT_LEAST_DB_3_2
 695
 696 #ifdef CAN_PROTOTYPE
 697 hash_cb(DB * db, const void *data, u_int32_t size)
 698 #else
 699 hash_cb(db, data, size)
 700 DB * db ;
 701 const void * data ;
 702 HASH_CB_SIZE_TYPE size ;
 703 #endif
 704
 705 #else /* Berkeley DB < 3.2 */
 706
 707 #ifdef CAN_PROTOTYPE
 708 hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
 709 #else
 710 hash_cb(data, size)
 711 const void * data ;
 712 HASH_CB_SIZE_TYPE size ;
 713 #endif
 714
 715 #endif
 716 {
 717 #ifdef dTHX
 718     dTHX;
 719 #endif
 720     dSP ;
 721     dMY_CXT;
 722     int retval ;
 723     int count ;
 724     DB_File     keep_CurrentDB = CurrentDB;
 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
 740     PUSHMARK(SP) ;
 741
 742     XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
 743     PUTBACK ;
 744
 745     keep_CurrentDB->in_hash = TRUE;
 746
 747     count = perl_call_sv(CurrentDB->hash, G_SCALAR);
 748
 749     CurrentDB = keep_CurrentDB;
 750     CurrentDB->in_hash = FALSE;
 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 static void
 769 #ifdef CAN_PROTOTYPE
 770 db_errcall_cb(const char * db_errpfx, char * buffer)
 771 #else
 772 db_errcall_cb(db_errpfx, buffer)
 773 const char * db_errpfx;
 774 char * buffer;
 775 #endif
 776 {
 777     dTHX;
 778     SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
 779     if (sv) {
 780         if (db_errpfx)
 781             sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
 782         else
 783             sv_setpv(sv, buffer) ;
 784     }
 785 }
 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    = %ul\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     dTHX;
1460     SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
1461     MY_CXT_INIT;
1462     __getBerkeleyDBInfo() ;
1463
1464     DBT_clear(empty) ;
1465     empty.data = &zero ;
1466     empty.size =  sizeof(recno_t) ;
1467   }
1468
1469
1470
1471 DB_File
1472 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
1473         int             isHASH
1474         char *          dbtype
1475         int             flags
1476         int             mode
1477         CODE:
1478         {
1479             char *      name = (char *) NULL ;
1480             SV *        sv = (SV *) NULL ;
1481             STRLEN      n_a;
1482
1483             if (items >= 3 && SvOK(ST(2)))
1484                 name = (char*) SvPV(ST(2), n_a) ;
1485
1486             if (items == 6)
1487                 sv = ST(5) ;
1488
1489             RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
1490             if (RETVAL->dbp == NULL)
1491                 RETVAL = NULL ;
1492         }
1493         OUTPUT:
1494             RETVAL
1495
1496 int
1497 db_DESTROY(db)
1498         DB_File         db
1499         PREINIT:
1500           dMY_CXT;
1501         INIT:
1502           CurrentDB = db ;
1503           Trace(("DESTROY %p\n", db));
1504         CLEANUP:
1505           Trace(("DESTROY %p done\n", db));
1506           if (db->hash)
1507             SvREFCNT_dec(db->hash) ;
1508           if (db->compare)
1509             SvREFCNT_dec(db->compare) ;
1510           if (db->prefix)
1511             SvREFCNT_dec(db->prefix) ;
1512           if (db->filter_fetch_key)
1513             SvREFCNT_dec(db->filter_fetch_key) ;
1514           if (db->filter_store_key)
1515             SvREFCNT_dec(db->filter_store_key) ;
1516           if (db->filter_fetch_value)
1517             SvREFCNT_dec(db->filter_fetch_value) ;
1518           if (db->filter_store_value)
1519             SvREFCNT_dec(db->filter_store_value) ;
1520           safefree(db) ;
1521 #ifdef DB_VERSION_MAJOR
1522           if (RETVAL > 0)
1523             RETVAL = -1 ;
1524 #endif
1525
1526
1527 int
1528 db_DELETE(db, key, flags=0)
1529         DB_File         db
1530         DBTKEY          key
1531         u_int           flags
1532         PREINIT:
1533           dMY_CXT;
1534         INIT:
1535           CurrentDB = db ;
1536
1537
1538 int
1539 db_EXISTS(db, key)
1540         DB_File         db
1541         DBTKEY          key
1542         PREINIT:
1543           dMY_CXT;
1544         CODE:
1545         {
1546           DBT           value ;
1547
1548           DBT_clear(value) ;
1549           CurrentDB = db ;
1550           RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
1551         }
1552         OUTPUT:
1553           RETVAL
1554
1555 void
1556 db_FETCH(db, key, flags=0)
1557         DB_File         db
1558         DBTKEY          key
1559         u_int           flags
1560         PREINIT:
1561           dMY_CXT ;
1562           int RETVAL ;
1563         CODE:
1564         {
1565             DBT         value ;
1566
1567             DBT_clear(value) ;
1568             CurrentDB = db ;
1569             RETVAL = db_get(db, key, value, flags) ;
1570             ST(0) = sv_newmortal();
1571             OutputValue(ST(0), value)
1572         }
1573
1574 int
1575 db_STORE(db, key, value, flags=0)
1576         DB_File         db
1577         DBTKEY          key
1578         DBT             value
1579         u_int           flags
1580         PREINIT:
1581           dMY_CXT;
1582         INIT:
1583           CurrentDB = db ;
1584
1585
1586 void
1587 db_FIRSTKEY(db)
1588         DB_File         db
1589         PREINIT:
1590           dMY_CXT ;
1591           int RETVAL ;
1592         CODE:
1593         {
1594             DBTKEY      key ;
1595             DBT         value ;
1596
1597             DBT_clear(key) ;
1598             DBT_clear(value) ;
1599             CurrentDB = db ;
1600             RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1601             ST(0) = sv_newmortal();
1602             OutputKey(ST(0), key) ;
1603         }
1604
1605 void
1606 db_NEXTKEY(db, key)
1607         DB_File         db
1608         DBTKEY          key = NO_INIT
1609         PREINIT:
1610           dMY_CXT ;
1611           int RETVAL ;
1612         CODE:
1613         {
1614             DBT         value ;
1615
1616             DBT_clear(key) ;
1617             DBT_clear(value) ;
1618             CurrentDB = db ;
1619             RETVAL = do_SEQ(db, key, value, R_NEXT) ;
1620             ST(0) = sv_newmortal();
1621             OutputKey(ST(0), key) ;
1622         }
1623
1624 #
1625 # These would be nice for RECNO
1626 #
1627
1628 int
1629 unshift(db, ...)
1630         DB_File         db
1631         ALIAS:          UNSHIFT = 1
1632         PREINIT:
1633           dMY_CXT;
1634         CODE:
1635         {
1636             DBTKEY      key ;
1637             DBT         value ;
1638             int         i ;
1639             int         One ;
1640             STRLEN      n_a;
1641
1642             DBT_clear(key) ;
1643             DBT_clear(value) ;
1644             CurrentDB = db ;
1645 #ifdef DB_VERSION_MAJOR
1646             /* get the first value */
1647             RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
1648             RETVAL = 0 ;
1649 #else
1650             RETVAL = -1 ;
1651 #endif
1652             for (i = items-1 ; i > 0 ; --i)
1653             {
1654                 value.data = SvPV(ST(i), n_a) ;
1655                 value.size = n_a ;
1656                 One = 1 ;
1657                 key.data = &One ;
1658                 key.size = sizeof(int) ;
1659 #ifdef DB_VERSION_MAJOR
1660                 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
1661 #else
1662                 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
1663 #endif
1664                 if (RETVAL != 0)
1665                     break;
1666             }
1667         }
1668         OUTPUT:
1669             RETVAL
1670
1671 void
1672 pop(db)
1673         DB_File         db
1674         PREINIT:
1675           dMY_CXT;
1676         ALIAS:          POP = 1
1677         PREINIT:
1678           I32 RETVAL;
1679         CODE:
1680         {
1681             DBTKEY      key ;
1682             DBT         value ;
1683
1684             DBT_clear(key) ;
1685             DBT_clear(value) ;
1686             CurrentDB = db ;
1687
1688             /* First get the final value */
1689             RETVAL = do_SEQ(db, key, value, R_LAST) ;
1690             ST(0) = sv_newmortal();
1691             /* Now delete it */
1692             if (RETVAL == 0)
1693             {
1694                 /* the call to del will trash value, so take a copy now */
1695                 OutputValue(ST(0), value) ;
1696                 RETVAL = db_del(db, key, R_CURSOR) ;
1697                 if (RETVAL != 0)
1698                     sv_setsv(ST(0), &PL_sv_undef);
1699             }
1700         }
1701
1702 void
1703 shift(db)
1704         DB_File         db
1705         PREINIT:
1706           dMY_CXT;
1707         ALIAS:          SHIFT = 1
1708         PREINIT:
1709           I32 RETVAL;
1710         CODE:
1711         {
1712             DBT         value ;
1713             DBTKEY      key ;
1714
1715             DBT_clear(key) ;
1716             DBT_clear(value) ;
1717             CurrentDB = db ;
1718             /* get the first value */
1719             RETVAL = do_SEQ(db, key, value, R_FIRST) ;
1720             ST(0) = sv_newmortal();
1721             /* Now delete it */
1722             if (RETVAL == 0)
1723             {
1724                 /* the call to del will trash value, so take a copy now */
1725                 OutputValue(ST(0), value) ;
1726                 RETVAL = db_del(db, key, R_CURSOR) ;
1727                 if (RETVAL != 0)
1728                     sv_setsv (ST(0), &PL_sv_undef) ;
1729             }
1730         }
1731
1732
1733 I32
1734 push(db, ...)
1735         DB_File         db
1736         PREINIT:
1737           dMY_CXT;
1738         ALIAS:          PUSH = 1
1739         CODE:
1740         {
1741             DBTKEY      key ;
1742             DBT         value ;
1743             DB *        Db = db->dbp ;
1744             int         i ;
1745             STRLEN      n_a;
1746             int         keyval ;
1747
1748             DBT_flags(key) ;
1749             DBT_flags(value) ;
1750             CurrentDB = db ;
1751             /* Set the Cursor to the Last element */
1752             RETVAL = do_SEQ(db, key, value, R_LAST) ;
1753 #ifndef DB_VERSION_MAJOR
1754             if (RETVAL >= 0)
1755 #endif
1756             {
1757                 if (RETVAL == 0)
1758                     keyval = *(int*)key.data ;
1759                 else
1760                     keyval = 0 ;
1761                 for (i = 1 ; i < items ; ++i)
1762                 {
1763                     value.data = SvPV(ST(i), n_a) ;
1764                     value.size = n_a ;
1765                     ++ keyval ;
1766                     key.data = &keyval ;
1767                     key.size = sizeof(int) ;
1768                     RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
1769                     if (RETVAL != 0)
1770                         break;
1771                 }
1772             }
1773         }
1774         OUTPUT:
1775             RETVAL
1776
1777 I32
1778 length(db)
1779         DB_File         db
1780         PREINIT:
1781           dMY_CXT;
1782         ALIAS:          FETCHSIZE = 1
1783         CODE:
1784             CurrentDB = db ;
1785             RETVAL = GetArrayLength(aTHX_ db) ;
1786         OUTPUT:
1787             RETVAL
1788
1789
1790 #
1791 # Now provide an interface to the rest of the DB functionality
1792 #
1793
1794 int
1795 db_del(db, key, flags=0)
1796         DB_File         db
1797         DBTKEY          key
1798         u_int           flags
1799         PREINIT:
1800           dMY_CXT;
1801         CODE:
1802           CurrentDB = db ;
1803           RETVAL = db_del(db, key, flags) ;
1804 #ifdef DB_VERSION_MAJOR
1805           if (RETVAL > 0)
1806             RETVAL = -1 ;
1807           else if (RETVAL == DB_NOTFOUND)
1808             RETVAL = 1 ;
1809 #endif
1810         OUTPUT:
1811           RETVAL
1812
1813
1814 int
1815 db_get(db, key, value, flags=0)
1816         DB_File         db
1817         DBTKEY          key
1818         DBT             value = NO_INIT
1819         u_int           flags
1820         PREINIT:
1821           dMY_CXT;
1822         CODE:
1823           CurrentDB = db ;
1824           DBT_clear(value) ;
1825           RETVAL = db_get(db, key, value, flags) ;
1826 #ifdef DB_VERSION_MAJOR
1827           if (RETVAL > 0)
1828             RETVAL = -1 ;
1829           else if (RETVAL == DB_NOTFOUND)
1830             RETVAL = 1 ;
1831 #endif
1832         OUTPUT:
1833           RETVAL
1834           value
1835
1836 int
1837 db_put(db, key, value, flags=0)
1838         DB_File         db
1839         DBTKEY          key
1840         DBT             value
1841         u_int           flags
1842         PREINIT:
1843           dMY_CXT;
1844         CODE:
1845           CurrentDB = db ;
1846           RETVAL = db_put(db, key, value, flags) ;
1847 #ifdef DB_VERSION_MAJOR
1848           if (RETVAL > 0)
1849             RETVAL = -1 ;
1850           else if (RETVAL == DB_KEYEXIST)
1851             RETVAL = 1 ;
1852 #endif
1853         OUTPUT:
1854           RETVAL
1855           key           if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
1856
1857 int
1858 db_fd(db)
1859         DB_File         db
1860         PREINIT:
1861           dMY_CXT ;
1862         CODE:
1863           CurrentDB = db ;
1864 #ifdef DB_VERSION_MAJOR
1865           RETVAL = -1 ;
1866           {
1867             int status = 0 ;
1868             status = (db->in_memory
1869                       ? -1
1870                       : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
1871             if (status != 0)
1872               RETVAL = -1 ;
1873           }
1874 #else
1875           RETVAL = (db->in_memory
1876                 ? -1
1877                 : ((db->dbp)->fd)(db->dbp) ) ;
1878 #endif
1879         OUTPUT:
1880           RETVAL
1881
1882 int
1883 db_sync(db, flags=0)
1884         DB_File         db
1885         u_int           flags
1886         PREINIT:
1887           dMY_CXT;
1888         CODE:
1889           CurrentDB = db ;
1890           RETVAL = db_sync(db, flags) ;
1891 #ifdef DB_VERSION_MAJOR
1892           if (RETVAL > 0)
1893             RETVAL = -1 ;
1894 #endif
1895         OUTPUT:
1896           RETVAL
1897
1898
1899 int
1900 db_seq(db, key, value, flags)
1901         DB_File         db
1902         DBTKEY          key
1903         DBT             value = NO_INIT
1904         u_int           flags
1905         PREINIT:
1906           dMY_CXT;
1907         CODE:
1908           CurrentDB = db ;
1909           DBT_clear(value) ;
1910           RETVAL = db_seq(db, key, value, flags);
1911 #ifdef DB_VERSION_MAJOR
1912           if (RETVAL > 0)
1913             RETVAL = -1 ;
1914           else if (RETVAL == DB_NOTFOUND)
1915             RETVAL = 1 ;
1916 #endif
1917         OUTPUT:
1918           RETVAL
1919           key
1920           value
1921
1922 SV *
1923 filter_fetch_key(db, code)
1924         DB_File         db
1925         SV *            code
1926         SV *            RETVAL = &PL_sv_undef ;
1927         CODE:
1928             DBM_setFilter(db->filter_fetch_key, code) ;
1929
1930 SV *
1931 filter_store_key(db, code)
1932         DB_File         db
1933         SV *            code
1934         SV *            RETVAL = &PL_sv_undef ;
1935         CODE:
1936             DBM_setFilter(db->filter_store_key, code) ;
1937
1938 SV *
1939 filter_fetch_value(db, code)
1940         DB_File         db
1941         SV *            code
1942         SV *            RETVAL = &PL_sv_undef ;
1943         CODE:
1944             DBM_setFilter(db->filter_fetch_value, code) ;
1945
1946 SV *
1947 filter_store_value(db, code)
1948         DB_File         db
1949         SV *            code
1950         SV *            RETVAL = &PL_sv_undef ;
1951         CODE:
1952             DBM_setFilter(db->filter_store_value, code) ;
1953