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-2018 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 128 int 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 */ 258 typedef 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 325 typedef 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 408 typedef 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 433 typedef DB_File_type * DB_File ; 434 typedef 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 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv)) 466 467 #ifdef CAN_PROTOTYPE 468 extern void __getBerkeleyDBInfo(void); 469 #endif 470 471 /* Internal Global Data */ 472 473 #define MY_CXT_KEY "DB_File::_guts" XS_VERSION 474 475 typedef struct { 476 recno_t x_Value; 477 recno_t x_zero; 478 DB_File x_CurrentDB; 479 DBTKEY x_empty; 480 } my_cxt_t; 481 482 START_MY_CXT 483 484 #define Value (MY_CXT.x_Value) 485 #define zero (MY_CXT.x_zero) 486 #define CurrentDB (MY_CXT.x_CurrentDB) 487 #define empty (MY_CXT.x_empty) 488 489 #define ERR_BUFF "DB_File::Error" 490 491 #ifdef DB_VERSION_MAJOR 492 493 static int 494 #ifdef CAN_PROTOTYPE 495 db_put(DB_File db, DBTKEY key, DBT value, u_int flags) 496 #else 497 db_put(db, key, value, flags) 498 DB_File db ; 499 DBTKEY key ; 500 DBT value ; 501 u_int flags ; 502 #endif 503 { 504 int status ; 505 506 if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { 507 DBC * temp_cursor ; 508 DBT l_key, l_value; 509 510 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 511 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) 512 #else 513 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) 514 #endif 515 return (-1) ; 516 517 memset(&l_key, 0, sizeof(l_key)); 518 l_key.data = key.data; 519 l_key.size = key.size; 520 memset(&l_value, 0, sizeof(l_value)); 521 l_value.data = value.data; 522 l_value.size = value.size; 523 524 if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { 525 (void)temp_cursor->c_close(temp_cursor); 526 return (-1); 527 } 528 529 status = temp_cursor->c_put(temp_cursor, &key, &value, flags); 530 (void)temp_cursor->c_close(temp_cursor); 531 532 return (status) ; 533 } 534 535 536 if (flagSet(flags, R_CURSOR)) { 537 return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); 538 } 539 if (flagSet(flags, R_SETCURSOR)) { 540 if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) 541 return -1 ; 542 return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); 543 544 } 545 546 return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; 547 548 } 549 550 #endif /* DB_VERSION_MAJOR */ 551 552 static void 553 tidyUp(DB_File db) 554 { 555 db->aborted = TRUE ; 556 } 557 558 559 static int 560 561 #ifdef AT_LEAST_DB_6_0 562 #ifdef CAN_PROTOTYPE 563 btree_compare(DB * db, const DBT *key1, const DBT *key2, size_t* locp) 564 #else 565 btree_compare(db, key1, key2, locp) 566 DB * db ; 567 const DBT * key1 ; 568 const DBT * key2 ; 569 size_t* locp; 570 #endif /* CAN_PROTOTYPE */ 571 572 #else /* Berkeley DB < 6.0 */ 573 #ifdef AT_LEAST_DB_3_2 574 575 #ifdef CAN_PROTOTYPE 576 btree_compare(DB * db, const DBT *key1, const DBT *key2) 577 #else 578 btree_compare(db, key1, key2) 579 DB * db ; 580 const DBT * key1 ; 581 const DBT * key2 ; 582 #endif /* CAN_PROTOTYPE */ 583 584 #else /* Berkeley DB < 3.2 */ 585 586 #ifdef CAN_PROTOTYPE 587 btree_compare(const DBT *key1, const DBT *key2) 588 #else 589 btree_compare(key1, key2) 590 const DBT * key1 ; 591 const DBT * key2 ; 592 #endif 593 594 #endif 595 #endif 596 597 { 598 #ifdef dTHX 599 dTHX; 600 #endif 601 dSP ; 602 dMY_CXT ; 603 void * data1, * data2 ; 604 int retval ; 605 int count ; 606 607 #ifdef AT_LEAST_DB_3_2 608 PERL_UNUSED_ARG(db); 609 #endif 610 #ifdef AT_LEAST_DB_6_0 611 PERL_UNUSED_ARG(locp); 612 #endif 613 614 if (CurrentDB->in_compare) { 615 tidyUp(CurrentDB); 616 croak ("DB_File btree_compare: recursion detected\n") ; 617 } 618 619 data1 = (char *) key1->data ; 620 data2 = (char *) key2->data ; 621 622 #ifndef newSVpvn 623 /* As newSVpv will assume that the data pointer is a null terminated C 624 string if the size parameter is 0, make sure that data points to an 625 empty string if the length is 0 626 */ 627 if (key1->size == 0) 628 data1 = "" ; 629 if (key2->size == 0) 630 data2 = "" ; 631 #endif 632 633 ENTER ; 634 SAVETMPS; 635 SAVESPTR(CurrentDB); 636 CurrentDB->in_compare = FALSE; 637 SAVEINT(CurrentDB->in_compare); 638 CurrentDB->in_compare = TRUE; 639 640 PUSHMARK(SP) ; 641 EXTEND(SP,2) ; 642 PUSHs(sv_2mortal(newSVpvn((const char*)data1,key1->size))); 643 PUSHs(sv_2mortal(newSVpvn((const char*)data2,key2->size))); 644 PUTBACK ; 645 646 count = perl_call_sv(CurrentDB->compare, G_SCALAR); 647 648 SPAGAIN ; 649 650 if (count != 1){ 651 tidyUp(CurrentDB); 652 croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; 653 } 654 655 retval = POPi ; 656 657 PUTBACK ; 658 FREETMPS ; 659 LEAVE ; 660 661 return (retval) ; 662 663 } 664 665 static DB_Prefix_t 666 #ifdef AT_LEAST_DB_3_2 667 668 #ifdef CAN_PROTOTYPE 669 btree_prefix(DB * db, const DBT *key1, const DBT *key2) 670 #else 671 btree_prefix(db, key1, key2) 672 Db * db ; 673 const DBT * key1 ; 674 const DBT * key2 ; 675 #endif 676 677 #else /* Berkeley DB < 3.2 */ 678 679 #ifdef CAN_PROTOTYPE 680 btree_prefix(const DBT *key1, const DBT *key2) 681 #else 682 btree_prefix(key1, key2) 683 const DBT * key1 ; 684 const DBT * key2 ; 685 #endif 686 687 #endif 688 { 689 #ifdef dTHX 690 dTHX; 691 #endif 692 dSP ; 693 dMY_CXT ; 694 char * data1, * data2 ; 695 int retval ; 696 int count ; 697 698 #ifdef AT_LEAST_DB_3_2 699 PERL_UNUSED_ARG(db); 700 #endif 701 702 if (CurrentDB->in_prefix){ 703 tidyUp(CurrentDB); 704 croak ("DB_File btree_prefix: recursion detected\n") ; 705 } 706 707 data1 = (char *) key1->data ; 708 data2 = (char *) key2->data ; 709 710 #ifndef newSVpvn 711 /* As newSVpv will assume that the data pointer is a null terminated C 712 string if the size parameter is 0, make sure that data points to an 713 empty string if the length is 0 714 */ 715 if (key1->size == 0) 716 data1 = "" ; 717 if (key2->size == 0) 718 data2 = "" ; 719 #endif 720 721 ENTER ; 722 SAVETMPS; 723 SAVESPTR(CurrentDB); 724 CurrentDB->in_prefix = FALSE; 725 SAVEINT(CurrentDB->in_prefix); 726 CurrentDB->in_prefix = TRUE; 727 728 PUSHMARK(SP) ; 729 EXTEND(SP,2) ; 730 PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); 731 PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); 732 PUTBACK ; 733 734 count = perl_call_sv(CurrentDB->prefix, G_SCALAR); 735 736 SPAGAIN ; 737 738 if (count != 1){ 739 tidyUp(CurrentDB); 740 croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; 741 } 742 743 retval = POPi ; 744 745 PUTBACK ; 746 FREETMPS ; 747 LEAVE ; 748 749 return (retval) ; 750 } 751 752 753 #ifdef BERKELEY_DB_1 754 # define HASH_CB_SIZE_TYPE size_t 755 #else 756 # define HASH_CB_SIZE_TYPE u_int32_t 757 #endif 758 759 static DB_Hash_t 760 #ifdef AT_LEAST_DB_3_2 761 762 #ifdef CAN_PROTOTYPE 763 hash_cb(DB * db, const void *data, u_int32_t size) 764 #else 765 hash_cb(db, data, size) 766 DB * db ; 767 const void * data ; 768 HASH_CB_SIZE_TYPE size ; 769 #endif 770 771 #else /* Berkeley DB < 3.2 */ 772 773 #ifdef CAN_PROTOTYPE 774 hash_cb(const void *data, HASH_CB_SIZE_TYPE size) 775 #else 776 hash_cb(data, size) 777 const void * data ; 778 HASH_CB_SIZE_TYPE size ; 779 #endif 780 781 #endif 782 { 783 #ifdef dTHX 784 dTHX; 785 #endif 786 dSP ; 787 dMY_CXT; 788 int retval = 0; 789 int count ; 790 791 #ifdef AT_LEAST_DB_3_2 792 PERL_UNUSED_ARG(db); 793 #endif 794 795 if (CurrentDB->in_hash){ 796 tidyUp(CurrentDB); 797 croak ("DB_File hash callback: recursion detected\n") ; 798 } 799 800 #ifndef newSVpvn 801 if (size == 0) 802 data = "" ; 803 #endif 804 805 /* DGH - Next two lines added to fix corrupted stack problem */ 806 ENTER ; 807 SAVETMPS; 808 SAVESPTR(CurrentDB); 809 CurrentDB->in_hash = FALSE; 810 SAVEINT(CurrentDB->in_hash); 811 CurrentDB->in_hash = TRUE; 812 813 PUSHMARK(SP) ; 814 815 816 XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); 817 PUTBACK ; 818 819 count = perl_call_sv(CurrentDB->hash, G_SCALAR); 820 821 SPAGAIN ; 822 823 if (count != 1){ 824 tidyUp(CurrentDB); 825 croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; 826 } 827 828 retval = POPi ; 829 830 PUTBACK ; 831 FREETMPS ; 832 LEAVE ; 833 834 return (retval) ; 835 } 836 837 #ifdef WANT_ERROR 838 839 static void 840 #ifdef AT_LEAST_DB_4_3 841 db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer) 842 #else 843 db_errcall_cb(const char * db_errpfx, char * buffer) 844 #endif 845 { 846 #ifdef dTHX 847 dTHX; 848 #endif 849 SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; 850 #ifdef AT_LEAST_DB_4_3 851 PERL_UNUSED_ARG(dbenv); 852 #endif 853 if (sv) { 854 if (db_errpfx) 855 sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ; 856 else 857 sv_setpv(sv, buffer) ; 858 } 859 } 860 #endif 861 862 #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) 863 864 static void 865 #ifdef CAN_PROTOTYPE 866 PrintHash(INFO *hash) 867 #else 868 PrintHash(hash) 869 INFO * hash ; 870 #endif 871 { 872 printf ("HASH Info\n") ; 873 printf (" hash = %s\n", 874 (hash->db_HA_hash != NULL ? "redefined" : "default")) ; 875 printf (" bsize = %d\n", hash->db_HA_bsize) ; 876 printf (" ffactor = %d\n", hash->db_HA_ffactor) ; 877 printf (" nelem = %d\n", hash->db_HA_nelem) ; 878 printf (" cachesize = %d\n", hash->db_HA_cachesize) ; 879 printf (" lorder = %d\n", hash->db_HA_lorder) ; 880 881 } 882 883 static void 884 #ifdef CAN_PROTOTYPE 885 PrintRecno(INFO *recno) 886 #else 887 PrintRecno(recno) 888 INFO * recno ; 889 #endif 890 { 891 printf ("RECNO Info\n") ; 892 printf (" flags = %d\n", recno->db_RE_flags) ; 893 printf (" cachesize = %d\n", recno->db_RE_cachesize) ; 894 printf (" psize = %d\n", recno->db_RE_psize) ; 895 printf (" lorder = %d\n", recno->db_RE_lorder) ; 896 printf (" reclen = %lu\n", (unsigned long)recno->db_RE_reclen) ; 897 printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ; 898 printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ; 899 } 900 901 static void 902 #ifdef CAN_PROTOTYPE 903 PrintBtree(INFO *btree) 904 #else 905 PrintBtree(btree) 906 INFO * btree ; 907 #endif 908 { 909 printf ("BTREE Info\n") ; 910 printf (" compare = %s\n", 911 (btree->db_BT_compare ? "redefined" : "default")) ; 912 printf (" prefix = %s\n", 913 (btree->db_BT_prefix ? "redefined" : "default")) ; 914 printf (" flags = %d\n", btree->db_BT_flags) ; 915 printf (" cachesize = %d\n", btree->db_BT_cachesize) ; 916 printf (" psize = %d\n", btree->db_BT_psize) ; 917 #ifndef DB_VERSION_MAJOR 918 printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ; 919 printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ; 920 #endif 921 printf (" lorder = %d\n", btree->db_BT_lorder) ; 922 } 923 924 #else 925 926 #define PrintRecno(recno) 927 #define PrintHash(hash) 928 #define PrintBtree(btree) 929 930 #endif /* TRACE */ 931 932 933 static I32 934 #ifdef CAN_PROTOTYPE 935 GetArrayLength(pTHX_ DB_File db) 936 #else 937 GetArrayLength(db) 938 DB_File db ; 939 #endif 940 { 941 DBT key ; 942 DBT value ; 943 int RETVAL ; 944 945 DBT_clear(key) ; 946 DBT_clear(value) ; 947 RETVAL = do_SEQ(db, key, value, R_LAST) ; 948 if (RETVAL == 0) 949 RETVAL = *(I32 *)key.data ; 950 else /* No key means empty file */ 951 RETVAL = 0 ; 952 953 return ((I32)RETVAL) ; 954 } 955 956 static recno_t 957 #ifdef CAN_PROTOTYPE 958 GetRecnoKey(pTHX_ DB_File db, I32 value) 959 #else 960 GetRecnoKey(db, value) 961 DB_File db ; 962 I32 value ; 963 #endif 964 { 965 if (value < 0) { 966 /* Get the length of the array */ 967 I32 length = GetArrayLength(aTHX_ db) ; 968 969 /* check for attempt to write before start of array */ 970 if (length + value + 1 <= 0) { 971 tidyUp(db); 972 croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; 973 } 974 975 value = length + value + 1 ; 976 } 977 else 978 ++ value ; 979 980 return value ; 981 } 982 983 984 static DB_File 985 #ifdef CAN_PROTOTYPE 986 ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) 987 #else 988 ParseOpenInfo(isHASH, name, flags, mode, sv) 989 int isHASH ; 990 char * name ; 991 int flags ; 992 int mode ; 993 SV * sv ; 994 #endif 995 { 996 997 #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ 998 999 SV ** svp; 1000 HV * action ; 1001 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; 1002 void * openinfo = NULL ; 1003 INFO * info = &RETVAL->info ; 1004 STRLEN n_a; 1005 dMY_CXT; 1006 1007 #ifdef TRACE 1008 printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n", 1009 name, flags, mode, sv == NULL) ; 1010 #endif 1011 Zero(RETVAL, 1, DB_File_type) ; 1012 1013 /* Default to HASH */ 1014 RETVAL->filtering = 0 ; 1015 RETVAL->filter_fetch_key = RETVAL->filter_store_key = 1016 RETVAL->filter_fetch_value = RETVAL->filter_store_value = 1017 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; 1018 RETVAL->type = DB_HASH ; 1019 1020 /* DGH - Next line added to avoid SEGV on existing hash DB */ 1021 CurrentDB = RETVAL; 1022 1023 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ 1024 RETVAL->in_memory = (name == NULL) ; 1025 1026 if (sv) 1027 { 1028 if (! SvROK(sv) ) 1029 croak ("type parameter is not a reference") ; 1030 1031 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; 1032 if (svp && SvOK(*svp)) 1033 action = (HV*) SvRV(*svp) ; 1034 else 1035 croak("internal error") ; 1036 1037 if (sv_isa(sv, "DB_File::HASHINFO")) 1038 { 1039 1040 if (!isHASH) 1041 croak("DB_File can only tie an associative array to a DB_HASH database") ; 1042 1043 RETVAL->type = DB_HASH ; 1044 openinfo = (void*)info ; 1045 1046 svp = hv_fetch(action, "hash", 4, FALSE); 1047 1048 if (svp && SvOK(*svp)) 1049 { 1050 info->db_HA_hash = hash_cb ; 1051 RETVAL->hash = newSVsv(*svp) ; 1052 } 1053 else 1054 info->db_HA_hash = NULL ; 1055 1056 svp = hv_fetch(action, "ffactor", 7, FALSE); 1057 info->db_HA_ffactor = svp ? SvIV(*svp) : 0; 1058 1059 svp = hv_fetch(action, "nelem", 5, FALSE); 1060 info->db_HA_nelem = svp ? SvIV(*svp) : 0; 1061 1062 svp = hv_fetch(action, "bsize", 5, FALSE); 1063 info->db_HA_bsize = svp ? SvIV(*svp) : 0; 1064 1065 svp = hv_fetch(action, "cachesize", 9, FALSE); 1066 info->db_HA_cachesize = svp ? SvIV(*svp) : 0; 1067 1068 svp = hv_fetch(action, "lorder", 6, FALSE); 1069 info->db_HA_lorder = svp ? SvIV(*svp) : 0; 1070 1071 PrintHash(info) ; 1072 } 1073 else if (sv_isa(sv, "DB_File::BTREEINFO")) 1074 { 1075 if (!isHASH) 1076 croak("DB_File can only tie an associative array to a DB_BTREE database"); 1077 1078 RETVAL->type = DB_BTREE ; 1079 openinfo = (void*)info ; 1080 1081 svp = hv_fetch(action, "compare", 7, FALSE); 1082 if (svp && SvOK(*svp)) 1083 { 1084 info->db_BT_compare = btree_compare ; 1085 RETVAL->compare = newSVsv(*svp) ; 1086 } 1087 else 1088 info->db_BT_compare = NULL ; 1089 1090 svp = hv_fetch(action, "prefix", 6, FALSE); 1091 if (svp && SvOK(*svp)) 1092 { 1093 info->db_BT_prefix = btree_prefix ; 1094 RETVAL->prefix = newSVsv(*svp) ; 1095 } 1096 else 1097 info->db_BT_prefix = NULL ; 1098 1099 svp = hv_fetch(action, "flags", 5, FALSE); 1100 info->db_BT_flags = svp ? SvIV(*svp) : 0; 1101 1102 svp = hv_fetch(action, "cachesize", 9, FALSE); 1103 info->db_BT_cachesize = svp ? SvIV(*svp) : 0; 1104 1105 #ifndef DB_VERSION_MAJOR 1106 svp = hv_fetch(action, "minkeypage", 10, FALSE); 1107 info->btree.minkeypage = svp ? SvIV(*svp) : 0; 1108 1109 svp = hv_fetch(action, "maxkeypage", 10, FALSE); 1110 info->btree.maxkeypage = svp ? SvIV(*svp) : 0; 1111 #endif 1112 1113 svp = hv_fetch(action, "psize", 5, FALSE); 1114 info->db_BT_psize = svp ? SvIV(*svp) : 0; 1115 1116 svp = hv_fetch(action, "lorder", 6, FALSE); 1117 info->db_BT_lorder = svp ? SvIV(*svp) : 0; 1118 1119 PrintBtree(info) ; 1120 1121 } 1122 else if (sv_isa(sv, "DB_File::RECNOINFO")) 1123 { 1124 if (isHASH) 1125 croak("DB_File can only tie an array to a DB_RECNO database"); 1126 1127 RETVAL->type = DB_RECNO ; 1128 openinfo = (void *)info ; 1129 1130 info->db_RE_flags = 0 ; 1131 1132 svp = hv_fetch(action, "flags", 5, FALSE); 1133 info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); 1134 1135 svp = hv_fetch(action, "reclen", 6, FALSE); 1136 info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); 1137 1138 svp = hv_fetch(action, "cachesize", 9, FALSE); 1139 info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); 1140 1141 svp = hv_fetch(action, "psize", 5, FALSE); 1142 info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); 1143 1144 svp = hv_fetch(action, "lorder", 6, FALSE); 1145 info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); 1146 1147 #ifdef DB_VERSION_MAJOR 1148 info->re_source = name ; 1149 name = NULL ; 1150 #endif 1151 svp = hv_fetch(action, "bfname", 6, FALSE); 1152 if (svp && SvOK(*svp)) { 1153 char * ptr = SvPV(*svp,n_a) ; 1154 #ifdef DB_VERSION_MAJOR 1155 name = (char*) n_a ? ptr : NULL ; 1156 #else 1157 info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; 1158 #endif 1159 } 1160 else 1161 #ifdef DB_VERSION_MAJOR 1162 name = NULL ; 1163 #else 1164 info->db_RE_bfname = NULL ; 1165 #endif 1166 1167 svp = hv_fetch(action, "bval", 4, FALSE); 1168 #ifdef DB_VERSION_MAJOR 1169 if (svp && SvOK(*svp)) 1170 { 1171 int value ; 1172 if (SvPOK(*svp)) 1173 value = (int)*SvPV(*svp, n_a) ; 1174 else 1175 value = SvIV(*svp) ; 1176 1177 if (info->flags & DB_FIXEDLEN) { 1178 info->re_pad = value ; 1179 info->flags |= DB_PAD ; 1180 } 1181 else { 1182 info->re_delim = value ; 1183 info->flags |= DB_DELIMITER ; 1184 } 1185 1186 } 1187 #else 1188 if (svp && SvOK(*svp)) 1189 { 1190 if (SvPOK(*svp)) 1191 info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; 1192 else 1193 info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; 1194 DB_flags(info->flags, DB_DELIMITER) ; 1195 1196 } 1197 else 1198 { 1199 if (info->db_RE_flags & R_FIXEDLEN) 1200 info->db_RE_bval = (u_char) ' ' ; 1201 else 1202 info->db_RE_bval = (u_char) '\n' ; 1203 DB_flags(info->flags, DB_DELIMITER) ; 1204 } 1205 #endif 1206 1207 #ifdef DB_RENUMBER 1208 info->flags |= DB_RENUMBER ; 1209 #endif 1210 1211 PrintRecno(info) ; 1212 } 1213 else 1214 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); 1215 } 1216 1217 1218 /* OS2 Specific Code */ 1219 #ifdef OS2 1220 #ifdef __EMX__ 1221 flags |= O_BINARY; 1222 #endif /* __EMX__ */ 1223 #endif /* OS2 */ 1224 1225 #ifdef DB_VERSION_MAJOR 1226 1227 { 1228 int Flags = 0 ; 1229 int status ; 1230 1231 /* Map 1.x flags to 2.x flags */ 1232 if ((flags & O_CREAT) == O_CREAT) 1233 Flags |= DB_CREATE ; 1234 1235 #if O_RDONLY == 0 1236 if (flags == O_RDONLY) 1237 #else 1238 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) 1239 #endif 1240 Flags |= DB_RDONLY ; 1241 1242 #ifdef O_TRUNC 1243 if ((flags & O_TRUNC) == O_TRUNC) 1244 Flags |= DB_TRUNCATE ; 1245 #endif 1246 1247 status = db_open(name, RETVAL->type, Flags, mode, NULL, (DB_INFO*)openinfo, &RETVAL->dbp) ; 1248 if (status == 0) 1249 #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 1250 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; 1251 #else 1252 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, 1253 0) ; 1254 #endif 1255 1256 if (status) 1257 RETVAL->dbp = NULL ; 1258 1259 } 1260 #else 1261 1262 #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 1263 RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; 1264 #else 1265 RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; 1266 #endif /* DB_LIBRARY_COMPATIBILITY_API */ 1267 1268 #endif 1269 1270 return (RETVAL) ; 1271 1272 #else /* Berkeley DB Version > 2 */ 1273 1274 SV ** svp; 1275 HV * action ; 1276 DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; 1277 DB * dbp ; 1278 STRLEN n_a; 1279 int status ; 1280 dMY_CXT; 1281 1282 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ 1283 Zero(RETVAL, 1, DB_File_type) ; 1284 1285 /* Default to HASH */ 1286 RETVAL->filtering = 0 ; 1287 RETVAL->filter_fetch_key = RETVAL->filter_store_key = 1288 RETVAL->filter_fetch_value = RETVAL->filter_store_value = 1289 RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; 1290 RETVAL->type = DB_HASH ; 1291 1292 /* DGH - Next line added to avoid SEGV on existing hash DB */ 1293 CurrentDB = RETVAL; 1294 1295 /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ 1296 RETVAL->in_memory = (name == NULL) ; 1297 1298 status = db_create(&RETVAL->dbp, NULL,0) ; 1299 /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ 1300 if (status) { 1301 RETVAL->dbp = NULL ; 1302 return (RETVAL) ; 1303 } 1304 dbp = RETVAL->dbp ; 1305 1306 #ifdef WANT_ERROR 1307 RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ; 1308 #endif 1309 if (sv) 1310 { 1311 if (! SvROK(sv) ) 1312 croak ("type parameter is not a reference") ; 1313 1314 svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; 1315 if (svp && SvOK(*svp)) 1316 action = (HV*) SvRV(*svp) ; 1317 else 1318 croak("internal error") ; 1319 1320 if (sv_isa(sv, "DB_File::HASHINFO")) 1321 { 1322 1323 if (!isHASH) 1324 croak("DB_File can only tie an associative array to a DB_HASH database") ; 1325 1326 RETVAL->type = DB_HASH ; 1327 1328 svp = hv_fetch(action, "hash", 4, FALSE); 1329 1330 if (svp && SvOK(*svp)) 1331 { 1332 (void)dbp->set_h_hash(dbp, hash_cb) ; 1333 RETVAL->hash = newSVsv(*svp) ; 1334 } 1335 1336 svp = hv_fetch(action, "ffactor", 7, FALSE); 1337 if (svp) 1338 (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ; 1339 1340 svp = hv_fetch(action, "nelem", 5, FALSE); 1341 if (svp) 1342 (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ; 1343 1344 svp = hv_fetch(action, "bsize", 5, FALSE); 1345 if (svp) 1346 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)); 1347 1348 svp = hv_fetch(action, "cachesize", 9, FALSE); 1349 if (svp) 1350 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; 1351 1352 svp = hv_fetch(action, "lorder", 6, FALSE); 1353 if (svp) 1354 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; 1355 1356 PrintHash(info) ; 1357 } 1358 else if (sv_isa(sv, "DB_File::BTREEINFO")) 1359 { 1360 if (!isHASH) 1361 croak("DB_File can only tie an associative array to a DB_BTREE database"); 1362 1363 RETVAL->type = DB_BTREE ; 1364 1365 svp = hv_fetch(action, "compare", 7, FALSE); 1366 if (svp && SvOK(*svp)) 1367 { 1368 (void)dbp->set_bt_compare(dbp, btree_compare) ; 1369 RETVAL->compare = newSVsv(*svp) ; 1370 } 1371 1372 svp = hv_fetch(action, "prefix", 6, FALSE); 1373 if (svp && SvOK(*svp)) 1374 { 1375 (void)dbp->set_bt_prefix(dbp, btree_prefix) ; 1376 RETVAL->prefix = newSVsv(*svp) ; 1377 } 1378 1379 svp = hv_fetch(action, "flags", 5, FALSE); 1380 if (svp) 1381 (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ; 1382 1383 svp = hv_fetch(action, "cachesize", 9, FALSE); 1384 if (svp) 1385 (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; 1386 1387 svp = hv_fetch(action, "psize", 5, FALSE); 1388 if (svp) 1389 (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; 1390 1391 svp = hv_fetch(action, "lorder", 6, FALSE); 1392 if (svp) 1393 (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; 1394 1395 PrintBtree(info) ; 1396 1397 } 1398 else if (sv_isa(sv, "DB_File::RECNOINFO")) 1399 { 1400 int fixed = FALSE ; 1401 1402 if (isHASH) 1403 croak("DB_File can only tie an array to a DB_RECNO database"); 1404 1405 RETVAL->type = DB_RECNO ; 1406 1407 svp = hv_fetch(action, "flags", 5, FALSE); 1408 if (svp) { 1409 int flags = SvIV(*svp) ; 1410 /* remove FIXDLEN, if present */ 1411 if (flags & DB_FIXEDLEN) { 1412 fixed = TRUE ; 1413 flags &= ~DB_FIXEDLEN ; 1414 } 1415 } 1416 1417 svp = hv_fetch(action, "cachesize", 9, FALSE); 1418 if (svp) { 1419 status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; 1420 } 1421 1422 svp = hv_fetch(action, "psize", 5, FALSE); 1423 if (svp) { 1424 status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; 1425 } 1426 1427 svp = hv_fetch(action, "lorder", 6, FALSE); 1428 if (svp) { 1429 status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ; 1430 } 1431 1432 svp = hv_fetch(action, "bval", 4, FALSE); 1433 if (svp && SvOK(*svp)) 1434 { 1435 int value ; 1436 if (SvPOK(*svp)) 1437 value = (int)*SvPV(*svp, n_a) ; 1438 else 1439 value = (int)SvIV(*svp) ; 1440 1441 if (fixed) { 1442 (void)dbp->set_re_pad(dbp, value) ; 1443 } 1444 else { 1445 (void)dbp->set_re_delim(dbp, value) ; 1446 } 1447 1448 } 1449 1450 if (fixed) { 1451 svp = hv_fetch(action, "reclen", 6, FALSE); 1452 if (svp) { 1453 u_int32_t len = my_SvUV32(*svp) ; 1454 (void)dbp->set_re_len(dbp, len) ; 1455 } 1456 } 1457 1458 if (name != NULL) { 1459 (void)dbp->set_re_source(dbp, name) ; 1460 name = NULL ; 1461 } 1462 1463 svp = hv_fetch(action, "bfname", 6, FALSE); 1464 if (svp && SvOK(*svp)) { 1465 char * ptr = SvPV(*svp,n_a) ; 1466 name = (char*) n_a ? ptr : NULL ; 1467 } 1468 else 1469 name = NULL ; 1470 1471 1472 (void)dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ; 1473 1474 if (flags){ 1475 (void)dbp->set_flags(dbp, (u_int32_t)flags) ; 1476 } 1477 PrintRecno(info) ; 1478 } 1479 else 1480 croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); 1481 } 1482 1483 { 1484 u_int32_t Flags = 0 ; 1485 int status ; 1486 1487 /* Map 1.x flags to 3.x flags */ 1488 if ((flags & O_CREAT) == O_CREAT) 1489 Flags |= DB_CREATE ; 1490 1491 #if O_RDONLY == 0 1492 if (flags == O_RDONLY) 1493 #else 1494 if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) 1495 #endif 1496 Flags |= DB_RDONLY ; 1497 1498 #ifdef O_TRUNC 1499 if ((flags & O_TRUNC) == O_TRUNC) 1500 Flags |= DB_TRUNCATE ; 1501 #endif 1502 1503 #ifdef AT_LEAST_DB_4_4 1504 /* need this for recno */ 1505 if ((flags & O_TRUNC) == O_TRUNC) 1506 Flags |= DB_CREATE ; 1507 #endif 1508 1509 #ifdef AT_LEAST_DB_4_1 1510 status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, 1511 Flags, mode) ; 1512 #else 1513 status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, 1514 Flags, mode) ; 1515 #endif 1516 /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ 1517 1518 if (status == 0) { 1519 1520 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, 1521 0) ; 1522 /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ 1523 } 1524 1525 if (status) 1526 { 1527 db_close(RETVAL); /* close **dbp handle to prevent mem.leak */ 1528 RETVAL->dbp = NULL ; 1529 } 1530 1531 } 1532 1533 return (RETVAL) ; 1534 1535 #endif /* Berkeley DB Version > 2 */ 1536 1537 } /* ParseOpenInfo */ 1538 1539 1540 #include "constants.h" 1541 1542 MODULE = DB_File PACKAGE = DB_File PREFIX = db_ 1543 1544 INCLUDE: constants.xs 1545 1546 BOOT: 1547 { 1548 #ifdef dTHX 1549 dTHX; 1550 #endif 1551 #ifdef WANT_ERROR 1552 SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; 1553 #endif 1554 MY_CXT_INIT; 1555 #ifdef WANT_ERROR 1556 PERL_UNUSED_VAR(sv_err); /* huh? we just retrieved it... */ 1557 #endif 1558 __getBerkeleyDBInfo() ; 1559 1560 DBT_clear(empty) ; 1561 empty.data = &zero ; 1562 empty.size = sizeof(recno_t) ; 1563 } 1564 1565 1566 1567 DB_File 1568 db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) 1569 int isHASH 1570 char * dbtype 1571 int flags 1572 int mode 1573 CODE: 1574 { 1575 char * name = (char *) NULL ; 1576 SV * sv = (SV *) NULL ; 1577 STRLEN n_a; 1578 1579 if (items >= 3 && SvOK(ST(2))) 1580 name = (char*) SvPV(ST(2), n_a) ; 1581 1582 if (items == 6) 1583 sv = ST(5) ; 1584 1585 RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; 1586 Trace(("db_DoTie_ %p\n", RETVAL)); 1587 if (RETVAL->dbp == NULL) { 1588 Safefree(RETVAL); 1589 RETVAL = NULL ; 1590 } 1591 } 1592 OUTPUT: 1593 RETVAL 1594 1595 int 1596 db_DESTROY(db) 1597 DB_File db 1598 PREINIT: 1599 dMY_CXT; 1600 INIT: 1601 CurrentDB = db ; 1602 Trace(("DESTROY %p\n", db)); 1603 CLEANUP: 1604 Trace(("DESTROY %p done\n", db)); 1605 if (db->hash) 1606 SvREFCNT_dec(db->hash) ; 1607 if (db->compare) 1608 SvREFCNT_dec(db->compare) ; 1609 if (db->prefix) 1610 SvREFCNT_dec(db->prefix) ; 1611 if (db->filter_fetch_key) 1612 SvREFCNT_dec(db->filter_fetch_key) ; 1613 if (db->filter_store_key) 1614 SvREFCNT_dec(db->filter_store_key) ; 1615 if (db->filter_fetch_value) 1616 SvREFCNT_dec(db->filter_fetch_value) ; 1617 if (db->filter_store_value) 1618 SvREFCNT_dec(db->filter_store_value) ; 1619 safefree(db) ; 1620 #ifdef DB_VERSION_MAJOR 1621 if (RETVAL > 0) 1622 RETVAL = -1 ; 1623 #endif 1624 1625 1626 int 1627 db_DELETE(db, key, flags=0) 1628 DB_File db 1629 DBTKEY key 1630 u_int flags 1631 PREINIT: 1632 dMY_CXT; 1633 INIT: 1634 (void)flags; 1635 CurrentDB = db ; 1636 1637 1638 int 1639 db_EXISTS(db, key) 1640 DB_File db 1641 DBTKEY key 1642 PREINIT: 1643 dMY_CXT; 1644 CODE: 1645 { 1646 DBT value ; 1647 1648 DBT_clear(value) ; 1649 CurrentDB = db ; 1650 RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; 1651 } 1652 OUTPUT: 1653 RETVAL 1654 1655 void 1656 db_FETCH(db, key, flags=0) 1657 DB_File db 1658 DBTKEY key 1659 u_int flags 1660 PREINIT: 1661 dMY_CXT ; 1662 int RETVAL ; 1663 CODE: 1664 { 1665 DBT value ; 1666 1667 DBT_clear(value) ; 1668 CurrentDB = db ; 1669 RETVAL = db_get(db, key, value, flags) ; 1670 ST(0) = sv_newmortal(); 1671 OutputValue(ST(0), value) 1672 } 1673 1674 int 1675 db_STORE(db, key, value, flags=0) 1676 DB_File db 1677 DBTKEY key 1678 DBT value 1679 u_int flags 1680 PREINIT: 1681 dMY_CXT; 1682 INIT: 1683 (void)flags; 1684 CurrentDB = db ; 1685 1686 1687 void 1688 db_FIRSTKEY(db) 1689 DB_File db 1690 PREINIT: 1691 dMY_CXT ; 1692 int RETVAL ; 1693 CODE: 1694 { 1695 DBTKEY key ; 1696 DBT value ; 1697 1698 DBT_clear(key) ; 1699 DBT_clear(value) ; 1700 CurrentDB = db ; 1701 RETVAL = do_SEQ(db, key, value, R_FIRST) ; 1702 ST(0) = sv_newmortal(); 1703 OutputKey(ST(0), key) ; 1704 } 1705 1706 void 1707 db_NEXTKEY(db, key) 1708 DB_File db 1709 DBTKEY key = NO_INIT 1710 PREINIT: 1711 dMY_CXT ; 1712 int RETVAL ; 1713 CODE: 1714 { 1715 DBT value ; 1716 1717 DBT_clear(key) ; 1718 DBT_clear(value) ; 1719 CurrentDB = db ; 1720 RETVAL = do_SEQ(db, key, value, R_NEXT) ; 1721 ST(0) = sv_newmortal(); 1722 OutputKey(ST(0), key) ; 1723 } 1724 1725 # 1726 # These would be nice for RECNO 1727 # 1728 1729 int 1730 unshift(db, ...) 1731 DB_File db 1732 ALIAS: UNSHIFT = 1 1733 PREINIT: 1734 dMY_CXT; 1735 CODE: 1736 { 1737 DBTKEY key ; 1738 DBT value ; 1739 int i ; 1740 int One ; 1741 STRLEN n_a; 1742 1743 DBT_clear(key) ; 1744 DBT_clear(value) ; 1745 CurrentDB = db ; 1746 #ifdef DB_VERSION_MAJOR 1747 /* get the first value */ 1748 RETVAL = do_SEQ(db, key, value, DB_FIRST) ; 1749 RETVAL = 0 ; 1750 #else 1751 RETVAL = -1 ; 1752 #endif 1753 for (i = items-1 ; i > 0 ; --i) 1754 { 1755 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value"); 1756 value.data = SvPVbyte(ST(i), n_a) ; 1757 value.size = n_a ; 1758 One = 1 ; 1759 key.data = &One ; 1760 key.size = sizeof(int) ; 1761 #ifdef DB_VERSION_MAJOR 1762 RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; 1763 #else 1764 RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ; 1765 #endif 1766 if (RETVAL != 0) 1767 break; 1768 } 1769 } 1770 OUTPUT: 1771 RETVAL 1772 1773 void 1774 pop(db) 1775 DB_File db 1776 PREINIT: 1777 dMY_CXT; 1778 ALIAS: POP = 1 1779 PREINIT: 1780 I32 RETVAL; 1781 CODE: 1782 { 1783 DBTKEY key ; 1784 DBT value ; 1785 1786 DBT_clear(key) ; 1787 DBT_clear(value) ; 1788 CurrentDB = db ; 1789 1790 /* First get the final value */ 1791 RETVAL = do_SEQ(db, key, value, R_LAST) ; 1792 ST(0) = sv_newmortal(); 1793 /* Now delete it */ 1794 if (RETVAL == 0) 1795 { 1796 /* the call to del will trash value, so take a copy now */ 1797 OutputValue(ST(0), value) ; 1798 RETVAL = db_del(db, key, R_CURSOR) ; 1799 if (RETVAL != 0) 1800 sv_setsv(ST(0), &PL_sv_undef); 1801 } 1802 } 1803 1804 void 1805 shift(db) 1806 DB_File db 1807 PREINIT: 1808 dMY_CXT; 1809 ALIAS: SHIFT = 1 1810 PREINIT: 1811 I32 RETVAL; 1812 CODE: 1813 { 1814 DBT value ; 1815 DBTKEY key ; 1816 1817 DBT_clear(key) ; 1818 DBT_clear(value) ; 1819 CurrentDB = db ; 1820 /* get the first value */ 1821 RETVAL = do_SEQ(db, key, value, R_FIRST) ; 1822 ST(0) = sv_newmortal(); 1823 /* Now delete it */ 1824 if (RETVAL == 0) 1825 { 1826 /* the call to del will trash value, so take a copy now */ 1827 OutputValue(ST(0), value) ; 1828 RETVAL = db_del(db, key, R_CURSOR) ; 1829 if (RETVAL != 0) 1830 sv_setsv (ST(0), &PL_sv_undef) ; 1831 } 1832 } 1833 1834 1835 I32 1836 push(db, ...) 1837 DB_File db 1838 PREINIT: 1839 dMY_CXT; 1840 ALIAS: PUSH = 1 1841 CODE: 1842 { 1843 DBTKEY key ; 1844 DBT value ; 1845 DB * Db = db->dbp ; 1846 int i ; 1847 STRLEN n_a; 1848 int keyval ; 1849 1850 DBT_flags(key) ; 1851 DBT_flags(value) ; 1852 CurrentDB = db ; 1853 /* Set the Cursor to the Last element */ 1854 RETVAL = do_SEQ(db, key, value, R_LAST) ; 1855 #ifndef DB_VERSION_MAJOR 1856 if (RETVAL >= 0) 1857 #endif 1858 { 1859 if (RETVAL == 0) 1860 keyval = *(int*)key.data ; 1861 else 1862 keyval = 0 ; 1863 for (i = 1 ; i < items ; ++i) 1864 { 1865 DBM_ckFilter(ST(i), filter_store_value, "filter_store_value"); 1866 value.data = SvPVbyte(ST(i), n_a) ; 1867 value.size = n_a ; 1868 ++ keyval ; 1869 key.data = &keyval ; 1870 key.size = sizeof(int) ; 1871 RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; 1872 if (RETVAL != 0) 1873 break; 1874 } 1875 } 1876 } 1877 OUTPUT: 1878 RETVAL 1879 1880 I32 1881 length(db) 1882 DB_File db 1883 PREINIT: 1884 dMY_CXT; 1885 ALIAS: FETCHSIZE = 1 1886 CODE: 1887 CurrentDB = db ; 1888 RETVAL = GetArrayLength(aTHX_ db) ; 1889 OUTPUT: 1890 RETVAL 1891 1892 1893 # 1894 # Now provide an interface to the rest of the DB functionality 1895 # 1896 1897 int 1898 db_del(db, key, flags=0) 1899 DB_File db 1900 DBTKEY key 1901 u_int flags 1902 PREINIT: 1903 dMY_CXT; 1904 CODE: 1905 CurrentDB = db ; 1906 RETVAL = db_del(db, key, flags) ; 1907 #ifdef DB_VERSION_MAJOR 1908 if (RETVAL > 0) 1909 RETVAL = -1 ; 1910 else if (RETVAL == DB_NOTFOUND) 1911 RETVAL = 1 ; 1912 #endif 1913 OUTPUT: 1914 RETVAL 1915 1916 1917 int 1918 db_get(db, key, value, flags=0) 1919 DB_File db 1920 DBTKEY key 1921 DBT value = NO_INIT 1922 u_int flags 1923 PREINIT: 1924 dMY_CXT; 1925 CODE: 1926 CurrentDB = db ; 1927 DBT_clear(value) ; 1928 RETVAL = db_get(db, key, value, flags) ; 1929 #ifdef DB_VERSION_MAJOR 1930 if (RETVAL > 0) 1931 RETVAL = -1 ; 1932 else if (RETVAL == DB_NOTFOUND) 1933 RETVAL = 1 ; 1934 #endif 1935 OUTPUT: 1936 RETVAL 1937 value 1938 1939 int 1940 db_put(db, key, value, flags=0) 1941 DB_File db 1942 DBTKEY key 1943 DBT value 1944 u_int flags 1945 PREINIT: 1946 dMY_CXT; 1947 CODE: 1948 CurrentDB = db ; 1949 RETVAL = db_put(db, key, value, flags) ; 1950 #ifdef DB_VERSION_MAJOR 1951 if (RETVAL > 0) 1952 RETVAL = -1 ; 1953 else if (RETVAL == DB_KEYEXIST) 1954 RETVAL = 1 ; 1955 #endif 1956 OUTPUT: 1957 RETVAL 1958 key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); 1959 1960 int 1961 db_fd(db) 1962 DB_File db 1963 PREINIT: 1964 dMY_CXT ; 1965 CODE: 1966 CurrentDB = db ; 1967 #ifdef DB_VERSION_MAJOR 1968 RETVAL = -1 ; 1969 { 1970 int status = 0 ; 1971 status = (db->in_memory 1972 ? -1 1973 : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; 1974 if (status != 0) 1975 RETVAL = -1 ; 1976 } 1977 #else 1978 RETVAL = (db->in_memory 1979 ? -1 1980 : ((db->dbp)->fd)(db->dbp) ) ; 1981 #endif 1982 OUTPUT: 1983 RETVAL 1984 1985 int 1986 db_sync(db, flags=0) 1987 DB_File db 1988 u_int flags 1989 PREINIT: 1990 dMY_CXT; 1991 CODE: 1992 CurrentDB = db ; 1993 RETVAL = db_sync(db, flags) ; 1994 #ifdef DB_VERSION_MAJOR 1995 if (RETVAL > 0) 1996 RETVAL = -1 ; 1997 #endif 1998 OUTPUT: 1999 RETVAL 2000 2001 2002 int 2003 db_seq(db, key, value, flags) 2004 DB_File db 2005 DBTKEY key 2006 DBT value = NO_INIT 2007 u_int flags 2008 PREINIT: 2009 dMY_CXT; 2010 CODE: 2011 CurrentDB = db ; 2012 DBT_clear(value) ; 2013 RETVAL = db_seq(db, key, value, flags); 2014 #ifdef DB_VERSION_MAJOR 2015 if (RETVAL > 0) 2016 RETVAL = -1 ; 2017 else if (RETVAL == DB_NOTFOUND) 2018 RETVAL = 1 ; 2019 #endif 2020 OUTPUT: 2021 RETVAL 2022 key 2023 value 2024 2025 SV * 2026 filter_fetch_key(db, code) 2027 DB_File db 2028 SV * code 2029 SV * RETVAL = &PL_sv_undef ; 2030 CODE: 2031 DBM_setFilter(db->filter_fetch_key, code) ; 2032 2033 SV * 2034 filter_store_key(db, code) 2035 DB_File db 2036 SV * code 2037 SV * RETVAL = &PL_sv_undef ; 2038 CODE: 2039 DBM_setFilter(db->filter_store_key, code) ; 2040 2041 SV * 2042 filter_fetch_value(db, code) 2043 DB_File db 2044 SV * code 2045 SV * RETVAL = &PL_sv_undef ; 2046 CODE: 2047 DBM_setFilter(db->filter_fetch_value, code) ; 2048 2049 SV * 2050 filter_store_value(db, code) 2051 DB_File db 2052 SV * code 2053 SV * RETVAL = &PL_sv_undef ; 2054 CODE: 2055 DBM_setFilter(db->filter_store_value, code) ; 2056 2057