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