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