1 2package BerkeleyDB; 3 4 5# Copyright (c) 1997-2008 Paul Marquess. All rights reserved. 6# This program is free software; you can redistribute it and/or 7# modify it under the same terms as Perl itself. 8# 9 10# The documentation for this module is at the bottom of this file, 11# after the line __END__. 12 13BEGIN { require 5.004_04 } 14 15use strict; 16use Carp; 17use vars qw($VERSION @ISA @EXPORT $AUTOLOAD 18 $use_XSLoader); 19 20$VERSION = '0.34'; 21 22require Exporter; 23#require DynaLoader; 24require AutoLoader; 25 26BEGIN { 27 $use_XSLoader = 1 ; 28 { local $SIG{__DIE__} ; eval { require XSLoader } ; } 29 30 if ($@) { 31 $use_XSLoader = 0 ; 32 require DynaLoader; 33 @ISA = qw(DynaLoader); 34 } 35} 36 37@ISA = qw(Exporter DynaLoader); 38# Items to export into callers namespace by default. Note: do not export 39# names by default without a very good reason. Use EXPORT_OK instead. 40# Do not simply export all your public functions/methods/constants. 41 42# NOTE -- Do not add to @EXPORT directly. It is written by mkconsts 43@EXPORT = qw( 44 DB_AFTER 45 DB_AGGRESSIVE 46 DB_ALREADY_ABORTED 47 DB_APPEND 48 DB_APPLY_LOGREG 49 DB_APP_INIT 50 DB_ARCH_ABS 51 DB_ARCH_DATA 52 DB_ARCH_LOG 53 DB_ARCH_REMOVE 54 DB_ASSOC_IMMUTABLE_KEY 55 DB_AUTO_COMMIT 56 DB_BEFORE 57 DB_BTREE 58 DB_BTREEMAGIC 59 DB_BTREEOLDVER 60 DB_BTREEVERSION 61 DB_BUFFER_SMALL 62 DB_CACHED_COUNTS 63 DB_CDB_ALLDB 64 DB_CHECKPOINT 65 DB_CHKSUM 66 DB_CHKSUM_SHA1 67 DB_CKP_INTERNAL 68 DB_CLIENT 69 DB_CL_WRITER 70 DB_COMMIT 71 DB_COMPACT_FLAGS 72 DB_CONSUME 73 DB_CONSUME_WAIT 74 DB_CREATE 75 DB_CURLSN 76 DB_CURRENT 77 DB_CXX_NO_EXCEPTIONS 78 DB_DEGREE_2 79 DB_DELETED 80 DB_DELIMITER 81 DB_DIRECT 82 DB_DIRECT_DB 83 DB_DIRECT_LOG 84 DB_DIRTY_READ 85 DB_DONOTINDEX 86 DB_DSYNC_DB 87 DB_DSYNC_LOG 88 DB_DUP 89 DB_DUPCURSOR 90 DB_DUPSORT 91 DB_DURABLE_UNKNOWN 92 DB_EID_BROADCAST 93 DB_EID_INVALID 94 DB_ENCRYPT 95 DB_ENCRYPT_AES 96 DB_ENV_APPINIT 97 DB_ENV_AUTO_COMMIT 98 DB_ENV_CDB 99 DB_ENV_CDB_ALLDB 100 DB_ENV_CREATE 101 DB_ENV_DBLOCAL 102 DB_ENV_DIRECT_DB 103 DB_ENV_DIRECT_LOG 104 DB_ENV_DSYNC_DB 105 DB_ENV_DSYNC_LOG 106 DB_ENV_FATAL 107 DB_ENV_LOCKDOWN 108 DB_ENV_LOCKING 109 DB_ENV_LOGGING 110 DB_ENV_LOG_AUTOREMOVE 111 DB_ENV_LOG_INMEMORY 112 DB_ENV_MULTIVERSION 113 DB_ENV_NOLOCKING 114 DB_ENV_NOMMAP 115 DB_ENV_NOPANIC 116 DB_ENV_NO_OUTPUT_SET 117 DB_ENV_OPEN_CALLED 118 DB_ENV_OVERWRITE 119 DB_ENV_PANIC_OK 120 DB_ENV_PRIVATE 121 DB_ENV_RECOVER_FATAL 122 DB_ENV_REF_COUNTED 123 DB_ENV_REGION_INIT 124 DB_ENV_REP_CLIENT 125 DB_ENV_REP_LOGSONLY 126 DB_ENV_REP_MASTER 127 DB_ENV_RPCCLIENT 128 DB_ENV_RPCCLIENT_GIVEN 129 DB_ENV_STANDALONE 130 DB_ENV_SYSTEM_MEM 131 DB_ENV_THREAD 132 DB_ENV_TIME_NOTGRANTED 133 DB_ENV_TXN 134 DB_ENV_TXN_NOSYNC 135 DB_ENV_TXN_NOT_DURABLE 136 DB_ENV_TXN_NOWAIT 137 DB_ENV_TXN_SNAPSHOT 138 DB_ENV_TXN_WRITE_NOSYNC 139 DB_ENV_USER_ALLOC 140 DB_ENV_YIELDCPU 141 DB_EVENT_NOT_HANDLED 142 DB_EVENT_NO_SUCH_EVENT 143 DB_EVENT_PANIC 144 DB_EVENT_REP_CLIENT 145 DB_EVENT_REP_ELECTED 146 DB_EVENT_REP_MASTER 147 DB_EVENT_REP_NEWMASTER 148 DB_EVENT_REP_PERM_FAILED 149 DB_EVENT_REP_STARTUPDONE 150 DB_EVENT_WRITE_FAILED 151 DB_EXCL 152 DB_EXTENT 153 DB_FAST_STAT 154 DB_FCNTL_LOCKING 155 DB_FILEOPEN 156 DB_FILE_ID_LEN 157 DB_FIRST 158 DB_FIXEDLEN 159 DB_FLUSH 160 DB_FORCE 161 DB_FOREIGN_ABORT 162 DB_FOREIGN_CASCADE 163 DB_FOREIGN_CONFLICT 164 DB_FOREIGN_NULLIFY 165 DB_FREELIST_ONLY 166 DB_FREE_SPACE 167 DB_GETREC 168 DB_GET_BOTH 169 DB_GET_BOTHC 170 DB_GET_BOTH_RANGE 171 DB_GET_RECNO 172 DB_HANDLE_LOCK 173 DB_HASH 174 DB_HASHMAGIC 175 DB_HASHOLDVER 176 DB_HASHVERSION 177 DB_IGNORE_LEASE 178 DB_IMMUTABLE_KEY 179 DB_INCOMPLETE 180 DB_INIT_CDB 181 DB_INIT_LOCK 182 DB_INIT_LOG 183 DB_INIT_MPOOL 184 DB_INIT_REP 185 DB_INIT_TXN 186 DB_INORDER 187 DB_JAVA_CALLBACK 188 DB_JOINENV 189 DB_JOIN_ITEM 190 DB_JOIN_NOSORT 191 DB_KEYEMPTY 192 DB_KEYEXIST 193 DB_KEYFIRST 194 DB_KEYLAST 195 DB_LAST 196 DB_LOCKDOWN 197 DB_LOCKMAGIC 198 DB_LOCKVERSION 199 DB_LOCK_ABORT 200 DB_LOCK_CONFLICT 201 DB_LOCK_DEADLOCK 202 DB_LOCK_DEFAULT 203 DB_LOCK_DUMP 204 DB_LOCK_EXPIRE 205 DB_LOCK_FREE_LOCKER 206 DB_LOCK_GET 207 DB_LOCK_GET_TIMEOUT 208 DB_LOCK_INHERIT 209 DB_LOCK_MAXLOCKS 210 DB_LOCK_MAXWRITE 211 DB_LOCK_MINLOCKS 212 DB_LOCK_MINWRITE 213 DB_LOCK_NORUN 214 DB_LOCK_NOTEXIST 215 DB_LOCK_NOTGRANTED 216 DB_LOCK_NOTHELD 217 DB_LOCK_NOWAIT 218 DB_LOCK_OLDEST 219 DB_LOCK_PUT 220 DB_LOCK_PUT_ALL 221 DB_LOCK_PUT_OBJ 222 DB_LOCK_PUT_READ 223 DB_LOCK_RANDOM 224 DB_LOCK_RECORD 225 DB_LOCK_REMOVE 226 DB_LOCK_RIW_N 227 DB_LOCK_RW_N 228 DB_LOCK_SET_TIMEOUT 229 DB_LOCK_SWITCH 230 DB_LOCK_TIMEOUT 231 DB_LOCK_TRADE 232 DB_LOCK_UPGRADE 233 DB_LOCK_UPGRADE_WRITE 234 DB_LOCK_YOUNGEST 235 DB_LOGC_BUF_SIZE 236 DB_LOGFILEID_INVALID 237 DB_LOGMAGIC 238 DB_LOGOLDVER 239 DB_LOGVERSION 240 DB_LOG_AUTOREMOVE 241 DB_LOG_AUTO_REMOVE 242 DB_LOG_BUFFER_FULL 243 DB_LOG_CHKPNT 244 DB_LOG_COMMIT 245 DB_LOG_DIRECT 246 DB_LOG_DISK 247 DB_LOG_DSYNC 248 DB_LOG_INMEMORY 249 DB_LOG_IN_MEMORY 250 DB_LOG_LOCKED 251 DB_LOG_NOCOPY 252 DB_LOG_NOT_DURABLE 253 DB_LOG_PERM 254 DB_LOG_RESEND 255 DB_LOG_SILENT_ERR 256 DB_LOG_WRNOSYNC 257 DB_LOG_ZERO 258 DB_MAX_PAGES 259 DB_MAX_RECORDS 260 DB_MPOOL_CLEAN 261 DB_MPOOL_CREATE 262 DB_MPOOL_DIRTY 263 DB_MPOOL_DISCARD 264 DB_MPOOL_EDIT 265 DB_MPOOL_EXTENT 266 DB_MPOOL_FREE 267 DB_MPOOL_LAST 268 DB_MPOOL_NEW 269 DB_MPOOL_NEW_GROUP 270 DB_MPOOL_NOFILE 271 DB_MPOOL_NOLOCK 272 DB_MPOOL_PRIVATE 273 DB_MPOOL_UNLINK 274 DB_MULTIPLE 275 DB_MULTIPLE_KEY 276 DB_MULTIVERSION 277 DB_MUTEXDEBUG 278 DB_MUTEXLOCKS 279 DB_MUTEX_ALLOCATED 280 DB_MUTEX_LOCKED 281 DB_MUTEX_LOGICAL_LOCK 282 DB_MUTEX_PROCESS_ONLY 283 DB_MUTEX_SELF_BLOCK 284 DB_MUTEX_THREAD 285 DB_NEEDSPLIT 286 DB_NEXT 287 DB_NEXT_DUP 288 DB_NEXT_NODUP 289 DB_NOCOPY 290 DB_NODUPDATA 291 DB_NOLOCKING 292 DB_NOMMAP 293 DB_NOORDERCHK 294 DB_NOOVERWRITE 295 DB_NOPANIC 296 DB_NORECURSE 297 DB_NOSERVER 298 DB_NOSERVER_HOME 299 DB_NOSERVER_ID 300 DB_NOSYNC 301 DB_NOTFOUND 302 DB_NO_AUTO_COMMIT 303 DB_ODDFILESIZE 304 DB_OK_BTREE 305 DB_OK_HASH 306 DB_OK_QUEUE 307 DB_OK_RECNO 308 DB_OLD_VERSION 309 DB_OPEN_CALLED 310 DB_OPFLAGS_MASK 311 DB_ORDERCHKONLY 312 DB_OVERWRITE 313 DB_PAD 314 DB_PAGEYIELD 315 DB_PAGE_LOCK 316 DB_PAGE_NOTFOUND 317 DB_PANIC_ENVIRONMENT 318 DB_PERMANENT 319 DB_POSITION 320 DB_POSITIONI 321 DB_PREV 322 DB_PREV_DUP 323 DB_PREV_NODUP 324 DB_PRINTABLE 325 DB_PRIORITY_DEFAULT 326 DB_PRIORITY_HIGH 327 DB_PRIORITY_LOW 328 DB_PRIORITY_UNCHANGED 329 DB_PRIORITY_VERY_HIGH 330 DB_PRIORITY_VERY_LOW 331 DB_PRIVATE 332 DB_PR_HEADERS 333 DB_PR_PAGE 334 DB_PR_RECOVERYTEST 335 DB_QAMMAGIC 336 DB_QAMOLDVER 337 DB_QAMVERSION 338 DB_QUEUE 339 DB_RDONLY 340 DB_RDWRMASTER 341 DB_READ_COMMITTED 342 DB_READ_UNCOMMITTED 343 DB_RECNO 344 DB_RECNUM 345 DB_RECORDCOUNT 346 DB_RECORD_LOCK 347 DB_RECOVER 348 DB_RECOVER_FATAL 349 DB_REGION_ANON 350 DB_REGION_INIT 351 DB_REGION_MAGIC 352 DB_REGION_NAME 353 DB_REGISTER 354 DB_REGISTERED 355 DB_RENAMEMAGIC 356 DB_RENUMBER 357 DB_REPFLAGS_MASK 358 DB_REPMGR_ACKS_ALL 359 DB_REPMGR_ACKS_ALL_PEERS 360 DB_REPMGR_ACKS_NONE 361 DB_REPMGR_ACKS_ONE 362 DB_REPMGR_ACKS_ONE_PEER 363 DB_REPMGR_ACKS_QUORUM 364 DB_REPMGR_CONF_2SITE_STRICT 365 DB_REPMGR_CONNECTED 366 DB_REPMGR_DISCONNECTED 367 DB_REPMGR_PEER 368 DB_REP_ACK_TIMEOUT 369 DB_REP_ANYWHERE 370 DB_REP_BULKOVF 371 DB_REP_CHECKPOINT_DELAY 372 DB_REP_CLIENT 373 DB_REP_CONF_BULK 374 DB_REP_CONF_DELAYCLIENT 375 DB_REP_CONF_LEASE 376 DB_REP_CONF_NOAUTOINIT 377 DB_REP_CONF_NOWAIT 378 DB_REP_CONNECTION_RETRY 379 DB_REP_CREATE 380 DB_REP_DEFAULT_PRIORITY 381 DB_REP_DUPMASTER 382 DB_REP_EGENCHG 383 DB_REP_ELECTION 384 DB_REP_ELECTION_RETRY 385 DB_REP_ELECTION_TIMEOUT 386 DB_REP_FULL_ELECTION 387 DB_REP_FULL_ELECTION_TIMEOUT 388 DB_REP_HANDLE_DEAD 389 DB_REP_HEARTBEAT_MONITOR 390 DB_REP_HEARTBEAT_SEND 391 DB_REP_HOLDELECTION 392 DB_REP_IGNORE 393 DB_REP_ISPERM 394 DB_REP_JOIN_FAILURE 395 DB_REP_LEASE_EXPIRED 396 DB_REP_LEASE_TIMEOUT 397 DB_REP_LOCKOUT 398 DB_REP_LOGREADY 399 DB_REP_LOGSONLY 400 DB_REP_MASTER 401 DB_REP_NEWMASTER 402 DB_REP_NEWSITE 403 DB_REP_NOBUFFER 404 DB_REP_NOTPERM 405 DB_REP_OUTDATED 406 DB_REP_PAGEDONE 407 DB_REP_PERMANENT 408 DB_REP_REREQUEST 409 DB_REP_STARTUPDONE 410 DB_REP_UNAVAIL 411 DB_REVSPLITOFF 412 DB_RMW 413 DB_RPCCLIENT 414 DB_RPC_SERVERPROG 415 DB_RPC_SERVERVERS 416 DB_RUNRECOVERY 417 DB_SALVAGE 418 DB_SA_SKIPFIRSTKEY 419 DB_SECONDARY_BAD 420 DB_SEQUENCE_OLDVER 421 DB_SEQUENCE_VERSION 422 DB_SEQUENTIAL 423 DB_SEQ_DEC 424 DB_SEQ_INC 425 DB_SEQ_RANGE_SET 426 DB_SEQ_WRAP 427 DB_SEQ_WRAPPED 428 DB_SET 429 DB_SET_LOCK_TIMEOUT 430 DB_SET_RANGE 431 DB_SET_RECNO 432 DB_SET_TXN_NOW 433 DB_SET_TXN_TIMEOUT 434 DB_SNAPSHOT 435 DB_SPARE_FLAG 436 DB_STAT_ALL 437 DB_STAT_CLEAR 438 DB_STAT_LOCK_CONF 439 DB_STAT_LOCK_LOCKERS 440 DB_STAT_LOCK_OBJECTS 441 DB_STAT_LOCK_PARAMS 442 DB_STAT_MEMP_HASH 443 DB_STAT_MEMP_NOERROR 444 DB_STAT_NOERROR 445 DB_STAT_SUBSYSTEM 446 DB_ST_DUPOK 447 DB_ST_DUPSET 448 DB_ST_DUPSORT 449 DB_ST_IS_RECNO 450 DB_ST_OVFL_LEAF 451 DB_ST_RECNUM 452 DB_ST_RELEN 453 DB_ST_TOPLEVEL 454 DB_SURPRISE_KID 455 DB_SWAPBYTES 456 DB_SYSTEM_MEM 457 DB_TEMPORARY 458 DB_TEST_ELECTINIT 459 DB_TEST_ELECTSEND 460 DB_TEST_ELECTVOTE1 461 DB_TEST_ELECTVOTE2 462 DB_TEST_ELECTWAIT1 463 DB_TEST_ELECTWAIT2 464 DB_TEST_POSTDESTROY 465 DB_TEST_POSTLOG 466 DB_TEST_POSTLOGMETA 467 DB_TEST_POSTOPEN 468 DB_TEST_POSTRENAME 469 DB_TEST_POSTSYNC 470 DB_TEST_PREDESTROY 471 DB_TEST_PREOPEN 472 DB_TEST_PRERENAME 473 DB_TEST_RECYCLE 474 DB_TEST_SUBDB_LOCKS 475 DB_THREAD 476 DB_THREADID_STRLEN 477 DB_TIMEOUT 478 DB_TIME_NOTGRANTED 479 DB_TRUNCATE 480 DB_TXNMAGIC 481 DB_TXNVERSION 482 DB_TXN_ABORT 483 DB_TXN_APPLY 484 DB_TXN_BACKWARD_ROLL 485 DB_TXN_CKP 486 DB_TXN_FORWARD_ROLL 487 DB_TXN_LOCK 488 DB_TXN_LOCK_2PL 489 DB_TXN_LOCK_MASK 490 DB_TXN_LOCK_OPTIMIST 491 DB_TXN_LOCK_OPTIMISTIC 492 DB_TXN_LOG_MASK 493 DB_TXN_LOG_REDO 494 DB_TXN_LOG_UNDO 495 DB_TXN_LOG_UNDOREDO 496 DB_TXN_NOSYNC 497 DB_TXN_NOT_DURABLE 498 DB_TXN_NOWAIT 499 DB_TXN_OPENFILES 500 DB_TXN_POPENFILES 501 DB_TXN_PRINT 502 DB_TXN_REDO 503 DB_TXN_SNAPSHOT 504 DB_TXN_SYNC 505 DB_TXN_UNDO 506 DB_TXN_WAIT 507 DB_TXN_WRITE_NOSYNC 508 DB_UNKNOWN 509 DB_UNREF 510 DB_UPDATE_SECONDARY 511 DB_UPGRADE 512 DB_USERCOPY_GETDATA 513 DB_USERCOPY_SETDATA 514 DB_USE_ENVIRON 515 DB_USE_ENVIRON_ROOT 516 DB_VERB_CHKPOINT 517 DB_VERB_DEADLOCK 518 DB_VERB_FILEOPS 519 DB_VERB_FILEOPS_ALL 520 DB_VERB_RECOVERY 521 DB_VERB_REGISTER 522 DB_VERB_REPLICATION 523 DB_VERB_REPMGR_CONNFAIL 524 DB_VERB_REPMGR_MISC 525 DB_VERB_REP_ELECT 526 DB_VERB_REP_LEASE 527 DB_VERB_REP_MISC 528 DB_VERB_REP_MSGS 529 DB_VERB_REP_SYNC 530 DB_VERB_WAITSFOR 531 DB_VERIFY 532 DB_VERIFY_BAD 533 DB_VERIFY_FATAL 534 DB_VERSION_MAJOR 535 DB_VERSION_MINOR 536 DB_VERSION_MISMATCH 537 DB_VERSION_PATCH 538 DB_VERSION_STRING 539 DB_VRFY_FLAGMASK 540 DB_WRITECURSOR 541 DB_WRITELOCK 542 DB_WRITEOPEN 543 DB_WRNOSYNC 544 DB_XA_CREATE 545 DB_XIDDATASIZE 546 DB_YIELDCPU 547 DB_debug_FLAG 548 DB_user_BEGIN 549 ); 550 551sub AUTOLOAD { 552 my($constname); 553 ($constname = $AUTOLOAD) =~ s/.*:://; 554 my ($error, $val) = constant($constname); 555 Carp::croak $error if $error; 556 no strict 'refs'; 557 *{$AUTOLOAD} = sub { $val }; 558 goto &{$AUTOLOAD}; 559} 560 561#bootstrap BerkeleyDB $VERSION; 562if ($use_XSLoader) 563 { XSLoader::load("BerkeleyDB", $VERSION)} 564else 565 { bootstrap BerkeleyDB $VERSION } 566 567# Preloaded methods go here. 568 569 570sub ParseParameters($@) 571{ 572 my ($default, @rest) = @_ ; 573 my (%got) = %$default ; 574 my (@Bad) ; 575 my ($key, $value) ; 576 my $sub = (caller(1))[3] ; 577 my %options = () ; 578 local ($Carp::CarpLevel) = 1 ; 579 580 # allow the options to be passed as a hash reference or 581 # as the complete hash. 582 if (@rest == 1) { 583 584 croak "$sub: parameter is not a reference to a hash" 585 if ref $rest[0] ne "HASH" ; 586 587 %options = %{ $rest[0] } ; 588 } 589 elsif (@rest >= 2 && @rest % 2 == 0) { 590 %options = @rest ; 591 } 592 elsif (@rest > 0) { 593 croak "$sub: malformed option list"; 594 } 595 596 while (($key, $value) = each %options) 597 { 598 $key =~ s/^-// ; 599 600 if (exists $default->{$key}) 601 { $got{$key} = $value } 602 else 603 { push (@Bad, $key) } 604 } 605 606 if (@Bad) { 607 my ($bad) = join(", ", @Bad) ; 608 croak "unknown key value(s) $bad" ; 609 } 610 611 return \%got ; 612} 613 614sub parseEncrypt 615{ 616 my $got = shift ; 617 618 619 if (defined $got->{Encrypt}) { 620 croak("Encrypt parameter must be a hash reference") 621 if !ref $got->{Encrypt} || ref $got->{Encrypt} ne 'HASH' ; 622 623 my %config = %{ $got->{Encrypt} } ; 624 625 my $p = BerkeleyDB::ParseParameters({ 626 Password => undef, 627 Flags => undef, 628 }, %config); 629 630 croak("Must specify Password and Flags with Encrypt parameter") 631 if ! (defined $p->{Password} && defined $p->{Flags}); 632 633 $got->{"Enc_Passwd"} = $p->{Password}; 634 $got->{"Enc_Flags"} = $p->{Flags}; 635 } 636} 637 638use UNIVERSAL qw( isa ) ; 639 640sub env_remove 641{ 642 # Usage: 643 # 644 # $env = BerkeleyDB::env_remove 645 # [ -Home => $path, ] 646 # [ -Config => { name => value, name => value } 647 # [ -Flags => DB_INIT_LOCK| ] 648 # ; 649 650 my $got = BerkeleyDB::ParseParameters({ 651 Home => undef, 652 Flags => 0, 653 Config => undef, 654 }, @_) ; 655 656 if (defined $got->{Config}) { 657 croak("Config parameter must be a hash reference") 658 if ! ref $got->{Config} eq 'HASH' ; 659 660 @BerkeleyDB::a = () ; 661 my $k = "" ; my $v = "" ; 662 while (($k, $v) = each %{$got->{Config}}) { 663 push @BerkeleyDB::a, "$k\t$v" ; 664 } 665 666 $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) 667 if @BerkeleyDB::a ; 668 } 669 670 return _env_remove($got) ; 671} 672 673sub db_remove 674{ 675 my $got = BerkeleyDB::ParseParameters( 676 { 677 Filename => undef, 678 Subname => undef, 679 Flags => 0, 680 Env => undef, 681 Txn => undef, 682 }, @_) ; 683 684 croak("Must specify a filename") 685 if ! defined $got->{Filename} ; 686 687 croak("Env not of type BerkeleyDB::Env") 688 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 689 690 return _db_remove($got); 691} 692 693sub db_rename 694{ 695 my $got = BerkeleyDB::ParseParameters( 696 { 697 Filename => undef, 698 Subname => undef, 699 Newname => undef, 700 Flags => 0, 701 Env => undef, 702 Txn => undef, 703 }, @_) ; 704 705 croak("Env not of type BerkeleyDB::Env") 706 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 707 708 croak("Must specify a filename") 709 if ! defined $got->{Filename} ; 710 711 #croak("Must specify a Subname") 712 #if ! defined $got->{Subname} ; 713 714 croak("Must specify a Newname") 715 if ! defined $got->{Newname} ; 716 717 return _db_rename($got); 718} 719 720sub db_verify 721{ 722 my $got = BerkeleyDB::ParseParameters( 723 { 724 Filename => undef, 725 Subname => undef, 726 Outfile => undef, 727 Flags => 0, 728 Env => undef, 729 }, @_) ; 730 731 croak("Env not of type BerkeleyDB::Env") 732 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 733 734 croak("Must specify a filename") 735 if ! defined $got->{Filename} ; 736 737 return _db_verify($got); 738} 739 740package BerkeleyDB::Env ; 741 742use UNIVERSAL qw( isa ) ; 743use Carp ; 744use IO::File; 745use vars qw( %valid_config_keys ) ; 746 747sub isaFilehandle 748{ 749 my $fh = shift ; 750 751 return ((isa($fh,'GLOB') or isa(\$fh,'GLOB')) and defined fileno($fh) ) 752 753} 754 755%valid_config_keys = map { $_, 1 } qw( DB_DATA_DIR DB_LOG_DIR DB_TEMP_DIR 756DB_TMP_DIR ) ; 757 758sub new 759{ 760 # Usage: 761 # 762 # $env = new BerkeleyDB::Env 763 # [ -Home => $path, ] 764 # [ -Mode => mode, ] 765 # [ -Config => { name => value, name => value } 766 # [ -ErrFile => filename, ] 767 # [ -ErrPrefix => "string", ] 768 # [ -Flags => DB_INIT_LOCK| ] 769 # [ -Set_Flags => $flags,] 770 # [ -Cachesize => number ] 771 # [ -LockDetect => ] 772 # [ -Verbose => boolean ] 773 # [ -Encrypt => { Password => string, Flags => value} 774 # 775 # ; 776 777 my $pkg = shift ; 778 my $got = BerkeleyDB::ParseParameters({ 779 Home => undef, 780 Server => undef, 781 Mode => 0666, 782 ErrFile => undef, 783 ErrPrefix => undef, 784 Flags => 0, 785 SetFlags => 0, 786 Cachesize => 0, 787 LockDetect => 0, 788 Verbose => 0, 789 Config => undef, 790 Encrypt => undef, 791 SharedMemKey => undef, 792 ThreadCount => 0, 793 }, @_) ; 794 795 my $errfile = $got->{ErrFile} ; 796 if (defined $got->{ErrFile}) { 797 if (!isaFilehandle($got->{ErrFile})) { 798 my $handle = new IO::File ">$got->{ErrFile}" 799 or croak "Cannot open file $got->{ErrFile}: $!\n" ; 800 $errfile = $got->{ErrFile} = $handle ; 801 } 802 } 803 804 my %config ; 805 if (defined $got->{Config}) { 806 croak("Config parameter must be a hash reference") 807 if ! ref $got->{Config} eq 'HASH' ; 808 809 %config = %{ $got->{Config} } ; 810 @BerkeleyDB::a = () ; 811 my $k = "" ; my $v = "" ; 812 while (($k, $v) = each %config) { 813 if ($BerkeleyDB::db_version >= 3.1 && ! $valid_config_keys{$k} ){ 814 $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; 815 croak $BerkeleyDB::Error ; 816 } 817 push @BerkeleyDB::a, "$k\t$v" ; 818 } 819 820 $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) 821 if @BerkeleyDB::a ; 822 } 823 824 BerkeleyDB::parseEncrypt($got); 825 826 my ($addr) = _db_appinit($pkg, $got, $errfile) ; 827 my $obj ; 828 $obj = bless [$addr] , $pkg if $addr ; 829 if ($obj && $BerkeleyDB::db_version >= 3.1 && keys %config) { 830 my ($k, $v); 831 while (($k, $v) = each %config) { 832 if ($k eq 'DB_DATA_DIR') 833 { $obj->set_data_dir($v) } 834 elsif ($k eq 'DB_LOG_DIR') 835 { $obj->set_lg_dir($v) } 836 elsif ($k eq 'DB_TEMP_DIR' || $k eq 'DB_TMP_DIR') 837 { $obj->set_tmp_dir($v) } 838 else { 839 $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; 840 croak $BerkeleyDB::Error 841 } 842 } 843 } 844 return $obj ; 845} 846 847 848sub TxnMgr 849{ 850 my $env = shift ; 851 my ($addr) = $env->_TxnMgr() ; 852 my $obj ; 853 $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ; 854 return $obj ; 855} 856 857sub txn_begin 858{ 859 my $env = shift ; 860 my ($addr) = $env->_txn_begin(@_) ; 861 my $obj ; 862 $obj = bless [$addr, $env] , "BerkeleyDB::Txn" if $addr ; 863 return $obj ; 864} 865 866sub DESTROY 867{ 868 my $self = shift ; 869 $self->_DESTROY() ; 870} 871 872package BerkeleyDB::Hash ; 873 874use vars qw(@ISA) ; 875@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; 876use UNIVERSAL qw( isa ) ; 877use Carp ; 878 879sub new 880{ 881 my $self = shift ; 882 my $got = BerkeleyDB::ParseParameters( 883 { 884 # Generic Stuff 885 Filename => undef, 886 Subname => undef, 887 #Flags => BerkeleyDB::DB_CREATE(), 888 Flags => 0, 889 Property => 0, 890 Mode => 0666, 891 Cachesize => 0, 892 Lorder => 0, 893 Pagesize => 0, 894 Env => undef, 895 #Tie => undef, 896 Txn => undef, 897 Encrypt => undef, 898 899 # Hash specific 900 Ffactor => 0, 901 Nelem => 0, 902 Hash => undef, 903 DupCompare => undef, 904 905 # BerkeleyDB specific 906 ReadKey => undef, 907 WriteKey => undef, 908 ReadValue => undef, 909 WriteValue => undef, 910 }, @_) ; 911 912 croak("Env not of type BerkeleyDB::Env") 913 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 914 915 croak("Txn not of type BerkeleyDB::Txn") 916 if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); 917 918 croak("-Tie needs a reference to a hash") 919 if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; 920 921 BerkeleyDB::parseEncrypt($got); 922 923 my ($addr) = _db_open_hash($self, $got); 924 my $obj ; 925 if ($addr) { 926 $obj = bless [$addr] , $self ; 927 push @{ $obj }, $got->{Env} if $got->{Env} ; 928 $obj->Txn($got->{Txn}) 929 if $got->{Txn} ; 930 } 931 return $obj ; 932} 933 934*TIEHASH = \&new ; 935 936 937package BerkeleyDB::Btree ; 938 939use vars qw(@ISA) ; 940@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; 941use UNIVERSAL qw( isa ) ; 942use Carp ; 943 944sub new 945{ 946 my $self = shift ; 947 my $got = BerkeleyDB::ParseParameters( 948 { 949 # Generic Stuff 950 Filename => undef, 951 Subname => undef, 952 #Flags => BerkeleyDB::DB_CREATE(), 953 Flags => 0, 954 Property => 0, 955 Mode => 0666, 956 Cachesize => 0, 957 Lorder => 0, 958 Pagesize => 0, 959 Env => undef, 960 #Tie => undef, 961 Txn => undef, 962 Encrypt => undef, 963 964 # Btree specific 965 Minkey => 0, 966 Compare => undef, 967 DupCompare => undef, 968 Prefix => undef, 969 }, @_) ; 970 971 croak("Env not of type BerkeleyDB::Env") 972 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 973 974 croak("Txn not of type BerkeleyDB::Txn") 975 if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); 976 977 croak("-Tie needs a reference to a hash") 978 if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; 979 980 BerkeleyDB::parseEncrypt($got); 981 982 my ($addr) = _db_open_btree($self, $got); 983 my $obj ; 984 if ($addr) { 985 $obj = bless [$addr] , $self ; 986 push @{ $obj }, $got->{Env} if $got->{Env} ; 987 $obj->Txn($got->{Txn}) 988 if $got->{Txn} ; 989 } 990 return $obj ; 991} 992 993*BerkeleyDB::Btree::TIEHASH = \&BerkeleyDB::Btree::new ; 994 995 996package BerkeleyDB::Recno ; 997 998use vars qw(@ISA) ; 999@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; 1000use UNIVERSAL qw( isa ) ; 1001use Carp ; 1002 1003sub new 1004{ 1005 my $self = shift ; 1006 my $got = BerkeleyDB::ParseParameters( 1007 { 1008 # Generic Stuff 1009 Filename => undef, 1010 Subname => undef, 1011 #Flags => BerkeleyDB::DB_CREATE(), 1012 Flags => 0, 1013 Property => 0, 1014 Mode => 0666, 1015 Cachesize => 0, 1016 Lorder => 0, 1017 Pagesize => 0, 1018 Env => undef, 1019 #Tie => undef, 1020 Txn => undef, 1021 Encrypt => undef, 1022 1023 # Recno specific 1024 Delim => undef, 1025 Len => undef, 1026 Pad => undef, 1027 Source => undef, 1028 ArrayBase => 1, # lowest index in array 1029 }, @_) ; 1030 1031 croak("Env not of type BerkeleyDB::Env") 1032 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 1033 1034 croak("Txn not of type BerkeleyDB::Txn") 1035 if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); 1036 1037 croak("Tie needs a reference to an array") 1038 if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; 1039 1040 croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") 1041 if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; 1042 1043 1044 BerkeleyDB::parseEncrypt($got); 1045 1046 $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; 1047 1048 my ($addr) = _db_open_recno($self, $got); 1049 my $obj ; 1050 if ($addr) { 1051 $obj = bless [$addr] , $self ; 1052 push @{ $obj }, $got->{Env} if $got->{Env} ; 1053 $obj->Txn($got->{Txn}) 1054 if $got->{Txn} ; 1055 } 1056 return $obj ; 1057} 1058 1059*BerkeleyDB::Recno::TIEARRAY = \&BerkeleyDB::Recno::new ; 1060*BerkeleyDB::Recno::db_stat = \&BerkeleyDB::Btree::db_stat ; 1061 1062package BerkeleyDB::Queue ; 1063 1064use vars qw(@ISA) ; 1065@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; 1066use UNIVERSAL qw( isa ) ; 1067use Carp ; 1068 1069sub new 1070{ 1071 my $self = shift ; 1072 my $got = BerkeleyDB::ParseParameters( 1073 { 1074 # Generic Stuff 1075 Filename => undef, 1076 Subname => undef, 1077 #Flags => BerkeleyDB::DB_CREATE(), 1078 Flags => 0, 1079 Property => 0, 1080 Mode => 0666, 1081 Cachesize => 0, 1082 Lorder => 0, 1083 Pagesize => 0, 1084 Env => undef, 1085 #Tie => undef, 1086 Txn => undef, 1087 Encrypt => undef, 1088 1089 # Queue specific 1090 Len => undef, 1091 Pad => undef, 1092 ArrayBase => 1, # lowest index in array 1093 ExtentSize => undef, 1094 }, @_) ; 1095 1096 croak("Env not of type BerkeleyDB::Env") 1097 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 1098 1099 croak("Txn not of type BerkeleyDB::Txn") 1100 if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); 1101 1102 croak("Tie needs a reference to an array") 1103 if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; 1104 1105 croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") 1106 if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; 1107 1108 BerkeleyDB::parseEncrypt($got); 1109 1110 $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; 1111 1112 my ($addr) = _db_open_queue($self, $got); 1113 my $obj ; 1114 if ($addr) { 1115 $obj = bless [$addr] , $self ; 1116 push @{ $obj }, $got->{Env} if $got->{Env} ; 1117 $obj->Txn($got->{Txn}) 1118 if $got->{Txn} ; 1119 } 1120 return $obj ; 1121} 1122 1123*BerkeleyDB::Queue::TIEARRAY = \&BerkeleyDB::Queue::new ; 1124 1125sub UNSHIFT 1126{ 1127 my $self = shift; 1128 croak "unshift is unsupported with Queue databases"; 1129} 1130 1131## package BerkeleyDB::Text ; 1132## 1133## use vars qw(@ISA) ; 1134## @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; 1135## use UNIVERSAL qw( isa ) ; 1136## use Carp ; 1137## 1138## sub new 1139## { 1140## my $self = shift ; 1141## my $got = BerkeleyDB::ParseParameters( 1142## { 1143## # Generic Stuff 1144## Filename => undef, 1145## #Flags => BerkeleyDB::DB_CREATE(), 1146## Flags => 0, 1147## Property => 0, 1148## Mode => 0666, 1149## Cachesize => 0, 1150## Lorder => 0, 1151## Pagesize => 0, 1152## Env => undef, 1153## #Tie => undef, 1154## Txn => undef, 1155## 1156## # Recno specific 1157## Delim => undef, 1158## Len => undef, 1159## Pad => undef, 1160## Btree => undef, 1161## }, @_) ; 1162## 1163## croak("Env not of type BerkeleyDB::Env") 1164## if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 1165## 1166## croak("Txn not of type BerkeleyDB::Txn") 1167## if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); 1168## 1169## croak("-Tie needs a reference to an array") 1170## if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; 1171## 1172## # rearange for recno 1173## $got->{Source} = $got->{Filename} if defined $got->{Filename} ; 1174## delete $got->{Filename} ; 1175## $got->{Fname} = $got->{Btree} if defined $got->{Btree} ; 1176## return BerkeleyDB::Recno::_db_open_recno($self, $got); 1177## } 1178## 1179## *BerkeleyDB::Text::TIEARRAY = \&BerkeleyDB::Text::new ; 1180## *BerkeleyDB::Text::db_stat = \&BerkeleyDB::Btree::db_stat ; 1181 1182package BerkeleyDB::Unknown ; 1183 1184use vars qw(@ISA) ; 1185@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; 1186use UNIVERSAL qw( isa ) ; 1187use Carp ; 1188 1189sub new 1190{ 1191 my $self = shift ; 1192 my $got = BerkeleyDB::ParseParameters( 1193 { 1194 # Generic Stuff 1195 Filename => undef, 1196 Subname => undef, 1197 #Flags => BerkeleyDB::DB_CREATE(), 1198 Flags => 0, 1199 Property => 0, 1200 Mode => 0666, 1201 Cachesize => 0, 1202 Lorder => 0, 1203 Pagesize => 0, 1204 Env => undef, 1205 #Tie => undef, 1206 Txn => undef, 1207 Encrypt => undef, 1208 1209 }, @_) ; 1210 1211 croak("Env not of type BerkeleyDB::Env") 1212 if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); 1213 1214 croak("Txn not of type BerkeleyDB::Txn") 1215 if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); 1216 1217 croak("-Tie needs a reference to a hash") 1218 if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; 1219 1220 BerkeleyDB::parseEncrypt($got); 1221 1222 my ($addr, $type) = _db_open_unknown($got); 1223 my $obj ; 1224 if ($addr) { 1225 $obj = bless [$addr], "BerkeleyDB::$type" ; 1226 push @{ $obj }, $got->{Env} if $got->{Env} ; 1227 $obj->Txn($got->{Txn}) 1228 if $got->{Txn} ; 1229 } 1230 return $obj ; 1231} 1232 1233 1234package BerkeleyDB::_tiedHash ; 1235 1236use Carp ; 1237 1238#sub TIEHASH 1239#{ 1240# my $self = shift ; 1241# my $db_object = shift ; 1242# 1243#print "Tiehash REF=[$self] [" . (ref $self) . "]\n" ; 1244# 1245# return bless { Obj => $db_object}, $self ; 1246#} 1247 1248sub Tie 1249{ 1250 # Usage: 1251 # 1252 # $db->Tie \%hash ; 1253 # 1254 1255 my $self = shift ; 1256 1257 #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ; 1258 1259 croak("usage \$x->Tie \\%hash\n") unless @_ ; 1260 my $ref = shift ; 1261 1262 croak("Tie needs a reference to a hash") 1263 if defined $ref and $ref !~ /HASH/ ; 1264 1265 #tie %{ $ref }, ref($self), $self ; 1266 tie %{ $ref }, "BerkeleyDB::_tiedHash", $self ; 1267 return undef ; 1268} 1269 1270 1271sub TIEHASH 1272{ 1273 my $self = shift ; 1274 my $db_object = shift ; 1275 #return bless $db_object, 'BerkeleyDB::Common' ; 1276 return $db_object ; 1277} 1278 1279sub STORE 1280{ 1281 my $self = shift ; 1282 my $key = shift ; 1283 my $value = shift ; 1284 1285 $self->db_put($key, $value) ; 1286} 1287 1288sub FETCH 1289{ 1290 my $self = shift ; 1291 my $key = shift ; 1292 my $value = undef ; 1293 $self->db_get($key, $value) ; 1294 1295 return $value ; 1296} 1297 1298sub EXISTS 1299{ 1300 my $self = shift ; 1301 my $key = shift ; 1302 my $value = undef ; 1303 $self->db_get($key, $value) == 0 ; 1304} 1305 1306sub DELETE 1307{ 1308 my $self = shift ; 1309 my $key = shift ; 1310 $self->db_del($key) ; 1311} 1312 1313sub CLEAR 1314{ 1315 my $self = shift ; 1316 my ($key, $value) = (0, 0) ; 1317 my $cursor = $self->_db_write_cursor() ; 1318 while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0) 1319 { $cursor->c_del() } 1320} 1321 1322#sub DESTROY 1323#{ 1324# my $self = shift ; 1325# print "BerkeleyDB::_tieHash::DESTROY\n" ; 1326# $self->{Cursor}->c_close() if $self->{Cursor} ; 1327#} 1328 1329package BerkeleyDB::_tiedArray ; 1330 1331use Carp ; 1332 1333sub Tie 1334{ 1335 # Usage: 1336 # 1337 # $db->Tie \@array ; 1338 # 1339 1340 my $self = shift ; 1341 1342 #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ; 1343 1344 croak("usage \$x->Tie \\%hash\n") unless @_ ; 1345 my $ref = shift ; 1346 1347 croak("Tie needs a reference to an array") 1348 if defined $ref and $ref !~ /ARRAY/ ; 1349 1350 #tie %{ $ref }, ref($self), $self ; 1351 tie @{ $ref }, "BerkeleyDB::_tiedArray", $self ; 1352 return undef ; 1353} 1354 1355 1356#sub TIEARRAY 1357#{ 1358# my $self = shift ; 1359# my $db_object = shift ; 1360# 1361#print "Tiearray REF=[$self] [" . (ref $self) . "]\n" ; 1362# 1363# return bless { Obj => $db_object}, $self ; 1364#} 1365 1366sub TIEARRAY 1367{ 1368 my $self = shift ; 1369 my $db_object = shift ; 1370 #return bless $db_object, 'BerkeleyDB::Common' ; 1371 return $db_object ; 1372} 1373 1374sub STORE 1375{ 1376 my $self = shift ; 1377 my $key = shift ; 1378 my $value = shift ; 1379 1380 $self->db_put($key, $value) ; 1381} 1382 1383sub FETCH 1384{ 1385 my $self = shift ; 1386 my $key = shift ; 1387 my $value = undef ; 1388 $self->db_get($key, $value) ; 1389 1390 return $value ; 1391} 1392 1393*CLEAR = \&BerkeleyDB::_tiedHash::CLEAR ; 1394*FIRSTKEY = \&BerkeleyDB::_tiedHash::FIRSTKEY ; 1395*NEXTKEY = \&BerkeleyDB::_tiedHash::NEXTKEY ; 1396 1397sub EXTEND {} # don't do anything with EXTEND 1398 1399 1400sub SHIFT 1401{ 1402 my $self = shift; 1403 my ($key, $value) = (0, 0) ; 1404 my $cursor = $self->_db_write_cursor() ; 1405 return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) != 0 ; 1406 return undef if $cursor->c_del() != 0 ; 1407 1408 return $value ; 1409} 1410 1411 1412sub UNSHIFT 1413{ 1414 my $self = shift; 1415 if (@_) 1416 { 1417 my ($key, $value) = (0, 0) ; 1418 my $cursor = $self->_db_write_cursor() ; 1419 my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) ; 1420 if ($status == 0) 1421 { 1422 foreach $value (reverse @_) 1423 { 1424 $key = 0 ; 1425 $cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ; 1426 } 1427 } 1428 elsif ($status == BerkeleyDB::DB_NOTFOUND()) 1429 { 1430 $key = 0 ; 1431 foreach $value (@_) 1432 { 1433 $self->db_put($key++, $value) ; 1434 } 1435 } 1436 } 1437} 1438 1439sub PUSH 1440{ 1441 my $self = shift; 1442 if (@_) 1443 { 1444 my ($key, $value) = (-1, 0) ; 1445 my $cursor = $self->_db_write_cursor() ; 1446 my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) ; 1447 if ($status == 0 || $status == BerkeleyDB::DB_NOTFOUND()) 1448 { 1449 $key = -1 if $status != 0 and $self->type != BerkeleyDB::DB_RECNO() ; 1450 foreach $value (@_) 1451 { 1452 ++ $key ; 1453 $status = $self->db_put($key, $value) ; 1454 } 1455 } 1456 1457# can use this when DB_APPEND is fixed. 1458# foreach $value (@_) 1459# { 1460# my $status = $cursor->c_put($key, $value, BerkeleyDB::DB_AFTER()) ; 1461#print "[$status]\n" ; 1462# } 1463 } 1464} 1465 1466sub POP 1467{ 1468 my $self = shift; 1469 my ($key, $value) = (0, 0) ; 1470 my $cursor = $self->_db_write_cursor() ; 1471 return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) != 0 ; 1472 return undef if $cursor->c_del() != 0 ; 1473 1474 return $value ; 1475} 1476 1477sub SPLICE 1478{ 1479 my $self = shift; 1480 croak "SPLICE is not implemented yet" ; 1481} 1482 1483*shift = \&SHIFT ; 1484*unshift = \&UNSHIFT ; 1485*push = \&PUSH ; 1486*pop = \&POP ; 1487*clear = \&CLEAR ; 1488*length = \&FETCHSIZE ; 1489 1490sub STORESIZE 1491{ 1492 croak "STORESIZE is not implemented yet" ; 1493#print "STORESIZE @_\n" ; 1494# my $self = shift; 1495# my $length = shift ; 1496# my $current_length = $self->FETCHSIZE() ; 1497#print "length is $current_length\n"; 1498# 1499# if ($length < $current_length) { 1500#print "Make smaller $length < $current_length\n" ; 1501# my $key ; 1502# for ($key = $current_length - 1 ; $key >= $length ; -- $key) 1503# { $self->db_del($key) } 1504# } 1505# elsif ($length > $current_length) { 1506#print "Make larger $length > $current_length\n" ; 1507# $self->db_put($length-1, "") ; 1508# } 1509# else { print "stay the same\n" } 1510 1511} 1512 1513 1514 1515#sub DESTROY 1516#{ 1517# my $self = shift ; 1518# print "BerkeleyDB::_tieArray::DESTROY\n" ; 1519#} 1520 1521 1522package BerkeleyDB::Common ; 1523 1524 1525use Carp ; 1526 1527sub DESTROY 1528{ 1529 my $self = shift ; 1530 $self->_DESTROY() ; 1531} 1532 1533sub Txn 1534{ 1535 my $self = shift ; 1536 my $txn = shift ; 1537 #print "BerkeleyDB::Common::Txn db [$self] txn [$txn]\n" ; 1538 if ($txn) { 1539 $self->_Txn($txn) ; 1540 push @{ $txn }, $self ; 1541 } 1542 else { 1543 $self->_Txn() ; 1544 } 1545 #print "end BerkeleyDB::Common::Txn \n"; 1546} 1547 1548 1549sub get_dup 1550{ 1551 croak "Usage: \$db->get_dup(key [,flag])\n" 1552 unless @_ == 2 or @_ == 3 ; 1553 1554 my $db = shift ; 1555 my $key = shift ; 1556 my $flag = shift ; 1557 my $value = 0 ; 1558 my $origkey = $key ; 1559 my $wantarray = wantarray ; 1560 my %values = () ; 1561 my @values = () ; 1562 my $counter = 0 ; 1563 my $status = 0 ; 1564 my $cursor = $db->db_cursor() ; 1565 1566 # iterate through the database until either EOF ($status == 0) 1567 # or a different key is encountered ($key ne $origkey). 1568 for ($status = $cursor->c_get($key, $value, BerkeleyDB::DB_SET()) ; 1569 $status == 0 and $key eq $origkey ; 1570 $status = $cursor->c_get($key, $value, BerkeleyDB::DB_NEXT()) ) { 1571 # save the value or count number of matches 1572 if ($wantarray) { 1573 if ($flag) 1574 { ++ $values{$value} } 1575 else 1576 { push (@values, $value) } 1577 } 1578 else 1579 { ++ $counter } 1580 1581 } 1582 1583 return ($wantarray ? ($flag ? %values : @values) : $counter) ; 1584} 1585 1586sub db_cursor 1587{ 1588 my $db = shift ; 1589 my ($addr) = $db->_db_cursor(@_) ; 1590 my $obj ; 1591 $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ; 1592 return $obj ; 1593} 1594 1595sub _db_write_cursor 1596{ 1597 my $db = shift ; 1598 my ($addr) = $db->__db_write_cursor(@_) ; 1599 my $obj ; 1600 $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ; 1601 return $obj ; 1602} 1603 1604sub db_join 1605{ 1606 croak 'Usage: $db->BerkeleyDB::db_join([cursors], flags=0)' 1607 if @_ < 2 || @_ > 3 ; 1608 my $db = shift ; 1609 croak 'db_join: first parameter is not an array reference' 1610 if ! ref $_[0] || ref $_[0] ne 'ARRAY'; 1611 my ($addr) = $db->_db_join(@_) ; 1612 my $obj ; 1613 $obj = bless [$addr, $db, $_[0]] , "BerkeleyDB::Cursor" if $addr ; 1614 return $obj ; 1615} 1616 1617package BerkeleyDB::Cursor ; 1618 1619sub c_close 1620{ 1621 my $cursor = shift ; 1622 $cursor->[1] = "" ; 1623 return $cursor->_c_close() ; 1624} 1625 1626sub c_dup 1627{ 1628 my $cursor = shift ; 1629 my ($addr) = $cursor->_c_dup(@_) ; 1630 my $obj ; 1631 $obj = bless [$addr, $cursor->[1]] , "BerkeleyDB::Cursor" if $addr ; 1632 return $obj ; 1633} 1634 1635sub DESTROY 1636{ 1637 my $self = shift ; 1638 $self->_DESTROY() ; 1639} 1640 1641package BerkeleyDB::TxnMgr ; 1642 1643sub DESTROY 1644{ 1645 my $self = shift ; 1646 $self->_DESTROY() ; 1647} 1648 1649sub txn_begin 1650{ 1651 my $txnmgr = shift ; 1652 my ($addr) = $txnmgr->_txn_begin(@_) ; 1653 my $obj ; 1654 $obj = bless [$addr, $txnmgr] , "BerkeleyDB::Txn" if $addr ; 1655 return $obj ; 1656} 1657 1658package BerkeleyDB::Txn ; 1659 1660sub Txn 1661{ 1662 my $self = shift ; 1663 my $db ; 1664 # keep a reference to each db in the txn object 1665 foreach $db (@_) { 1666 $db->_Txn($self) ; 1667 push @{ $self}, $db ; 1668 } 1669} 1670 1671sub txn_commit 1672{ 1673 my $self = shift ; 1674 $self->disassociate() ; 1675 my $status = $self->_txn_commit() ; 1676 return $status ; 1677} 1678 1679sub txn_abort 1680{ 1681 my $self = shift ; 1682 $self->disassociate() ; 1683 my $status = $self->_txn_abort() ; 1684 return $status ; 1685} 1686 1687sub disassociate 1688{ 1689 my $self = shift ; 1690 my $db ; 1691 while ( @{ $self } > 2) { 1692 $db = pop @{ $self } ; 1693 $db->Txn() ; 1694 } 1695 #print "end disassociate\n" ; 1696} 1697 1698 1699sub DESTROY 1700{ 1701 my $self = shift ; 1702 1703 $self->disassociate() ; 1704 # first close the close the transaction 1705 $self->_DESTROY() ; 1706} 1707 1708package BerkeleyDB::CDS::Lock; 1709 1710use vars qw(%Object %Count); 1711use Carp; 1712 1713sub BerkeleyDB::Common::cds_lock 1714{ 1715 my $db = shift ; 1716 1717 # fatal error if database not opened in CDS mode 1718 croak("CDS not enabled for this database\n") 1719 if ! $db->cds_enabled(); 1720 1721 if ( ! defined $Object{"$db"}) 1722 { 1723 $Object{"$db"} = $db->_db_write_cursor() 1724 || return undef ; 1725 } 1726 1727 ++ $Count{"$db"} ; 1728 1729 return bless [$db, 1], "BerkeleyDB::CDS::Lock" ; 1730} 1731 1732sub cds_unlock 1733{ 1734 my $self = shift ; 1735 my $db = $self->[0] ; 1736 1737 if ($self->[1]) 1738 { 1739 $self->[1] = 0 ; 1740 -- $Count{"$db"} if $Count{"$db"} > 0 ; 1741 1742 if ($Count{"$db"} == 0) 1743 { 1744 $Object{"$db"}->c_close() ; 1745 undef $Object{"$db"}; 1746 } 1747 1748 return 1 ; 1749 } 1750 1751 return undef ; 1752} 1753 1754sub DESTROY 1755{ 1756 my $self = shift ; 1757 $self->cds_unlock() ; 1758} 1759 1760package BerkeleyDB::Term ; 1761 1762END 1763{ 1764 close_everything() ; 1765} 1766 1767 1768package BerkeleyDB ; 1769 1770 1771 1772# Autoload methods go after =cut, and are processed by the autosplit program. 1773 17741; 1775__END__ 1776 1777 1778 1779