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