EVOLUTION-MANAGER

Edit File: BerkeleyDB.pm

package BerkeleyDB; # Copyright (c) 1997-2012 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # The documentation for this module is at the bottom of this file, # after the line __END__. BEGIN { require 5.005 } use strict; use Carp; use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $use_XSLoader); $VERSION = '0.51'; require Exporter; #require DynaLoader; require AutoLoader; BEGIN { $use_XSLoader = 1 ; { local $SIG{__DIE__} ; eval { require XSLoader } ; } if ($@) { $use_XSLoader = 0 ; require DynaLoader; @ISA = qw(DynaLoader); } } @ISA = qw(Exporter DynaLoader); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # NOTE -- Do not add to @EXPORT directly. It is written by mkconsts @EXPORT = qw( DB2_AM_EXCL DB2_AM_INTEXCL DB2_AM_NOWAIT DB_AFTER DB_AGGRESSIVE DB_ALREADY_ABORTED DB_APPEND DB_APPLY_LOGREG DB_APP_INIT DB_ARCH_ABS DB_ARCH_DATA DB_ARCH_LOG DB_ARCH_REMOVE DB_ASSOC_CREATE DB_ASSOC_IMMUTABLE_KEY DB_AUTO_COMMIT DB_BACKUP_CLEAN DB_BACKUP_FILES DB_BACKUP_NO_LOGS DB_BACKUP_READ_COUNT DB_BACKUP_READ_SLEEP DB_BACKUP_SINGLE_DIR DB_BACKUP_SIZE DB_BACKUP_UPDATE DB_BACKUP_WRITE_DIRECT DB_BEFORE DB_BOOTSTRAP_HELPER DB_BTREE DB_BTREEMAGIC DB_BTREEOLDVER DB_BTREEVERSION DB_BUFFER_SMALL DB_CACHED_COUNTS DB_CDB_ALLDB DB_CHECKPOINT DB_CHKSUM DB_CHKSUM_SHA1 DB_CKP_INTERNAL DB_CLIENT DB_CL_WRITER DB_COMMIT DB_COMPACT_FLAGS DB_CONSUME DB_CONSUME_WAIT DB_CREATE DB_CURLSN DB_CURRENT DB_CURSOR_BULK DB_CURSOR_TRANSIENT DB_CXX_NO_EXCEPTIONS DB_DATABASE_LOCK DB_DATABASE_LOCKING DB_DEGREE_2 DB_DELETED DB_DELIMITER DB_DIRECT DB_DIRECT_DB DB_DIRECT_LOG DB_DIRTY_READ DB_DONOTINDEX DB_DSYNC_DB DB_DSYNC_LOG DB_DUP DB_DUPCURSOR DB_DUPSORT DB_DURABLE_UNKNOWN DB_EID_BROADCAST DB_EID_INVALID DB_EID_MASTER DB_ENCRYPT DB_ENCRYPT_AES DB_ENV_APPINIT DB_ENV_AUTO_COMMIT DB_ENV_CDB DB_ENV_CDB_ALLDB DB_ENV_CREATE DB_ENV_DATABASE_LOCKING DB_ENV_DBLOCAL DB_ENV_DIRECT_DB DB_ENV_DIRECT_LOG DB_ENV_DSYNC_DB DB_ENV_DSYNC_LOG DB_ENV_FAILCHK DB_ENV_FATAL DB_ENV_HOTBACKUP DB_ENV_LOCKDOWN DB_ENV_LOCKING DB_ENV_LOGGING DB_ENV_LOG_AUTOREMOVE DB_ENV_LOG_INMEMORY DB_ENV_MULTIVERSION DB_ENV_NOFLUSH DB_ENV_NOLOCKING DB_ENV_NOMMAP DB_ENV_NOPANIC DB_ENV_NO_OUTPUT_SET DB_ENV_OPEN_CALLED DB_ENV_OVERWRITE DB_ENV_PRIVATE DB_ENV_RECOVER_FATAL DB_ENV_REF_COUNTED DB_ENV_REGION_INIT DB_ENV_REP_CLIENT DB_ENV_REP_LOGSONLY DB_ENV_REP_MASTER DB_ENV_RPCCLIENT DB_ENV_RPCCLIENT_GIVEN DB_ENV_STANDALONE DB_ENV_SYSTEM_MEM DB_ENV_THREAD DB_ENV_TIME_NOTGRANTED DB_ENV_TXN DB_ENV_TXN_NOSYNC DB_ENV_TXN_NOT_DURABLE DB_ENV_TXN_NOWAIT DB_ENV_TXN_SNAPSHOT DB_ENV_TXN_WRITE_NOSYNC DB_ENV_USER_ALLOC DB_ENV_YIELDCPU DB_EVENT_NOT_HANDLED DB_EVENT_NO_SUCH_EVENT DB_EVENT_PANIC DB_EVENT_REG_ALIVE DB_EVENT_REG_PANIC DB_EVENT_REP_CLIENT DB_EVENT_REP_CONNECT_BROKEN DB_EVENT_REP_CONNECT_ESTD DB_EVENT_REP_CONNECT_TRY_FAILED DB_EVENT_REP_DUPMASTER DB_EVENT_REP_ELECTED DB_EVENT_REP_ELECTION_FAILED DB_EVENT_REP_INIT_DONE DB_EVENT_REP_JOIN_FAILURE DB_EVENT_REP_LOCAL_SITE_REMOVED DB_EVENT_REP_MASTER DB_EVENT_REP_MASTER_FAILURE DB_EVENT_REP_NEWMASTER DB_EVENT_REP_PERM_FAILED DB_EVENT_REP_SITE_ADDED DB_EVENT_REP_SITE_REMOVED DB_EVENT_REP_STARTUPDONE DB_EVENT_REP_WOULD_ROLLBACK DB_EVENT_WRITE_FAILED DB_EXCL DB_EXTENT DB_FAILCHK DB_FAILCHK_ISALIVE DB_FAST_STAT DB_FCNTL_LOCKING DB_FILEOPEN DB_FILE_ID_LEN DB_FIRST DB_FIXEDLEN DB_FLUSH DB_FORCE DB_FORCESYNC DB_FOREIGN_ABORT DB_FOREIGN_CASCADE DB_FOREIGN_CONFLICT DB_FOREIGN_NULLIFY DB_FREELIST_ONLY DB_FREE_SPACE DB_GETREC DB_GET_BOTH DB_GET_BOTHC DB_GET_BOTH_LTE DB_GET_BOTH_RANGE DB_GET_RECNO DB_GID_SIZE DB_GROUP_CREATOR DB_HANDLE_LOCK DB_HASH DB_HASHMAGIC DB_HASHOLDVER DB_HASHVERSION DB_HEAP DB_HEAPMAGIC DB_HEAPOLDVER DB_HEAPVERSION DB_HEAP_FULL DB_HEAP_RID_SZ DB_HOTBACKUP_IN_PROGRESS DB_IGNORE_LEASE DB_IMMUTABLE_KEY DB_INCOMPLETE DB_INIT_CDB DB_INIT_LOCK DB_INIT_LOG DB_INIT_MPOOL DB_INIT_MUTEX DB_INIT_REP DB_INIT_TXN DB_INORDER DB_INTERNAL_DB DB_INTERNAL_PERSISTENT_DB DB_INTERNAL_TEMPORARY_DB DB_JAVA_CALLBACK DB_JOINENV DB_JOIN_ITEM DB_JOIN_NOSORT DB_KEYEMPTY DB_KEYEXIST DB_KEYFIRST DB_KEYLAST DB_LAST DB_LEGACY DB_LOCAL_SITE DB_LOCKDOWN DB_LOCKMAGIC DB_LOCKVERSION DB_LOCK_ABORT DB_LOCK_CHECK DB_LOCK_CONFLICT DB_LOCK_DEADLOCK DB_LOCK_DEFAULT DB_LOCK_DUMP DB_LOCK_EXPIRE DB_LOCK_FREE_LOCKER DB_LOCK_GET DB_LOCK_GET_TIMEOUT DB_LOCK_IGNORE_REC DB_LOCK_INHERIT DB_LOCK_MAXLOCKS DB_LOCK_MAXWRITE DB_LOCK_MINLOCKS DB_LOCK_MINWRITE DB_LOCK_NORUN DB_LOCK_NOTEXIST DB_LOCK_NOTGRANTED DB_LOCK_NOTHELD DB_LOCK_NOWAIT DB_LOCK_OLDEST DB_LOCK_PUT DB_LOCK_PUT_ALL DB_LOCK_PUT_OBJ DB_LOCK_PUT_READ DB_LOCK_RANDOM DB_LOCK_RECORD DB_LOCK_REMOVE DB_LOCK_RIW_N DB_LOCK_RW_N DB_LOCK_SET_TIMEOUT DB_LOCK_SWITCH DB_LOCK_TIMEOUT DB_LOCK_TRADE DB_LOCK_UPGRADE DB_LOCK_UPGRADE_WRITE DB_LOCK_YOUNGEST DB_LOGCHKSUM DB_LOGC_BUF_SIZE DB_LOGFILEID_INVALID DB_LOGMAGIC DB_LOGOLDVER DB_LOGVERSION DB_LOGVERSION_LATCHING DB_LOG_AUTOREMOVE DB_LOG_AUTO_REMOVE DB_LOG_BUFFER_FULL DB_LOG_CHKPNT DB_LOG_COMMIT DB_LOG_DIRECT DB_LOG_DISK DB_LOG_DSYNC DB_LOG_INMEMORY DB_LOG_IN_MEMORY DB_LOG_LOCKED DB_LOG_NOCOPY DB_LOG_NOT_DURABLE DB_LOG_NO_DATA DB_LOG_PERM DB_LOG_RESEND DB_LOG_SILENT_ERR DB_LOG_VERIFY_BAD DB_LOG_VERIFY_CAF DB_LOG_VERIFY_DBFILE DB_LOG_VERIFY_ERR DB_LOG_VERIFY_FORWARD DB_LOG_VERIFY_INTERR DB_LOG_VERIFY_PARTIAL DB_LOG_VERIFY_VERBOSE DB_LOG_VERIFY_WARNING DB_LOG_WRNOSYNC DB_LOG_ZERO DB_MAX_PAGES DB_MAX_RECORDS DB_MEM_LOCK DB_MEM_LOCKER DB_MEM_LOCKOBJECT DB_MEM_LOGID DB_MEM_THREAD DB_MEM_TRANSACTION DB_MPOOL_CLEAN DB_MPOOL_CREATE DB_MPOOL_DIRTY DB_MPOOL_DISCARD DB_MPOOL_EDIT DB_MPOOL_EXTENT DB_MPOOL_FREE DB_MPOOL_LAST DB_MPOOL_NEW DB_MPOOL_NEW_GROUP DB_MPOOL_NOFILE DB_MPOOL_NOLOCK DB_MPOOL_PRIVATE DB_MPOOL_TRY DB_MPOOL_UNLINK DB_MULTIPLE DB_MULTIPLE_KEY DB_MULTIVERSION DB_MUTEXDEBUG DB_MUTEXLOCKS DB_MUTEX_ALLOCATED DB_MUTEX_LOCKED DB_MUTEX_LOGICAL_LOCK DB_MUTEX_PROCESS_ONLY DB_MUTEX_SELF_BLOCK DB_MUTEX_SHARED DB_MUTEX_THREAD DB_NEEDSPLIT DB_NEXT DB_NEXT_DUP DB_NEXT_NODUP DB_NOCOPY DB_NODUPDATA DB_NOERROR DB_NOFLUSH DB_NOLOCKING DB_NOMMAP DB_NOORDERCHK DB_NOOVERWRITE DB_NOPANIC DB_NORECURSE DB_NOSERVER DB_NOSERVER_HOME DB_NOSERVER_ID DB_NOSYNC DB_NOTFOUND DB_NO_AUTO_COMMIT DB_NO_CHECKPOINT DB_ODDFILESIZE DB_OK_BTREE DB_OK_HASH DB_OK_HEAP DB_OK_QUEUE DB_OK_RECNO DB_OLD_VERSION DB_OPEN_CALLED DB_OPFLAGS_MASK DB_ORDERCHKONLY DB_OVERWRITE DB_OVERWRITE_DUP DB_PAD DB_PAGEYIELD DB_PAGE_LOCK DB_PAGE_NOTFOUND DB_PANIC_ENVIRONMENT DB_PERMANENT DB_POSITION DB_POSITIONI DB_PREV DB_PREV_DUP DB_PREV_NODUP DB_PRINTABLE DB_PRIORITY_DEFAULT DB_PRIORITY_HIGH DB_PRIORITY_LOW DB_PRIORITY_UNCHANGED DB_PRIORITY_VERY_HIGH DB_PRIORITY_VERY_LOW DB_PRIVATE DB_PR_HEADERS DB_PR_PAGE DB_PR_RECOVERYTEST DB_QAMMAGIC DB_QAMOLDVER DB_QAMVERSION DB_QUEUE DB_RDONLY DB_RDWRMASTER DB_READ_COMMITTED DB_READ_UNCOMMITTED DB_RECNO DB_RECNUM DB_RECORDCOUNT DB_RECORD_LOCK DB_RECOVER DB_RECOVER_FATAL DB_REGION_ANON DB_REGION_INIT DB_REGION_MAGIC DB_REGION_NAME DB_REGISTER DB_REGISTERED DB_RENAMEMAGIC DB_RENUMBER DB_REPFLAGS_MASK DB_REPMGR_ACKS_ALL DB_REPMGR_ACKS_ALL_AVAILABLE DB_REPMGR_ACKS_ALL_PEERS DB_REPMGR_ACKS_NONE DB_REPMGR_ACKS_ONE DB_REPMGR_ACKS_ONE_PEER DB_REPMGR_ACKS_QUORUM DB_REPMGR_CONF_2SITE_STRICT DB_REPMGR_CONF_ELECTIONS DB_REPMGR_CONNECTED DB_REPMGR_DISCONNECTED DB_REPMGR_ISPEER DB_REPMGR_NEED_RESPONSE DB_REPMGR_PEER DB_REP_ACK_TIMEOUT DB_REP_ANYWHERE DB_REP_BULKOVF DB_REP_CHECKPOINT_DELAY DB_REP_CLIENT DB_REP_CONF_AUTOINIT DB_REP_CONF_AUTOROLLBACK DB_REP_CONF_BULK DB_REP_CONF_DELAYCLIENT DB_REP_CONF_INMEM DB_REP_CONF_LEASE DB_REP_CONF_NOAUTOINIT DB_REP_CONF_NOWAIT DB_REP_CONNECTION_RETRY DB_REP_CREATE DB_REP_DEFAULT_PRIORITY DB_REP_DUPMASTER DB_REP_EGENCHG DB_REP_ELECTION DB_REP_ELECTION_RETRY DB_REP_ELECTION_TIMEOUT DB_REP_FULL_ELECTION DB_REP_FULL_ELECTION_TIMEOUT DB_REP_HANDLE_DEAD DB_REP_HEARTBEAT_MONITOR DB_REP_HEARTBEAT_SEND DB_REP_HOLDELECTION DB_REP_IGNORE DB_REP_ISPERM DB_REP_JOIN_FAILURE DB_REP_LEASE_EXPIRED DB_REP_LEASE_TIMEOUT DB_REP_LOCKOUT DB_REP_LOGREADY DB_REP_LOGSONLY DB_REP_MASTER DB_REP_NEWMASTER DB_REP_NEWSITE DB_REP_NOBUFFER DB_REP_NOTPERM DB_REP_OUTDATED DB_REP_PAGEDONE DB_REP_PAGELOCKED DB_REP_PERMANENT DB_REP_REREQUEST DB_REP_STARTUPDONE DB_REP_UNAVAIL DB_REP_WOULDROLLBACK DB_REVSPLITOFF DB_RMW DB_RPCCLIENT DB_RPC_SERVERPROG DB_RPC_SERVERVERS DB_RUNRECOVERY DB_SALVAGE DB_SA_SKIPFIRSTKEY DB_SA_UNKNOWNKEY DB_SECONDARY_BAD DB_SEQUENCE_OLDVER DB_SEQUENCE_VERSION DB_SEQUENTIAL DB_SEQ_DEC DB_SEQ_INC DB_SEQ_RANGE_SET DB_SEQ_WRAP DB_SEQ_WRAPPED DB_SET DB_SET_LOCK_TIMEOUT DB_SET_LTE DB_SET_RANGE DB_SET_RECNO DB_SET_REG_TIMEOUT DB_SET_TXN_NOW DB_SET_TXN_TIMEOUT DB_SHALLOW_DUP DB_SNAPSHOT DB_SPARE_FLAG DB_STAT_ALL DB_STAT_ALLOC DB_STAT_CLEAR DB_STAT_LOCK_CONF DB_STAT_LOCK_LOCKERS DB_STAT_LOCK_OBJECTS DB_STAT_LOCK_PARAMS DB_STAT_MEMP_HASH DB_STAT_MEMP_NOERROR DB_STAT_NOERROR DB_STAT_SUBSYSTEM DB_STAT_SUMMARY DB_ST_DUPOK DB_ST_DUPSET DB_ST_DUPSORT DB_ST_IS_RECNO DB_ST_OVFL_LEAF DB_ST_RECNUM DB_ST_RELEN DB_ST_TOPLEVEL DB_SURPRISE_KID DB_SWAPBYTES DB_SYSTEM_MEM DB_TEMPORARY DB_TEST_ELECTINIT DB_TEST_ELECTSEND DB_TEST_ELECTVOTE1 DB_TEST_ELECTVOTE2 DB_TEST_ELECTWAIT1 DB_TEST_ELECTWAIT2 DB_TEST_POSTDESTROY DB_TEST_POSTLOG DB_TEST_POSTLOGMETA DB_TEST_POSTOPEN DB_TEST_POSTRENAME DB_TEST_POSTSYNC DB_TEST_PREDESTROY DB_TEST_PREOPEN DB_TEST_PRERENAME DB_TEST_RECYCLE DB_TEST_SUBDB_LOCKS DB_THREAD DB_THREADID_STRLEN DB_TIMEOUT DB_TIME_NOTGRANTED DB_TRUNCATE DB_TXNMAGIC DB_TXNVERSION DB_TXN_ABORT DB_TXN_APPLY DB_TXN_BACKWARD_ROLL DB_TXN_BULK DB_TXN_CKP DB_TXN_FAMILY DB_TXN_FORWARD_ROLL DB_TXN_LOCK DB_TXN_LOCK_2PL DB_TXN_LOCK_MASK DB_TXN_LOCK_OPTIMIST DB_TXN_LOCK_OPTIMISTIC DB_TXN_LOG_MASK DB_TXN_LOG_REDO DB_TXN_LOG_UNDO DB_TXN_LOG_UNDOREDO DB_TXN_LOG_VERIFY DB_TXN_NOSYNC DB_TXN_NOT_DURABLE DB_TXN_NOWAIT DB_TXN_OPENFILES DB_TXN_POPENFILES DB_TXN_PRINT DB_TXN_REDO DB_TXN_SNAPSHOT DB_TXN_SYNC DB_TXN_TOKEN_SIZE DB_TXN_UNDO DB_TXN_WAIT DB_TXN_WRITE_NOSYNC DB_UNKNOWN DB_UNREF DB_UPDATE_SECONDARY DB_UPGRADE DB_USERCOPY_GETDATA DB_USERCOPY_SETDATA DB_USE_ENVIRON DB_USE_ENVIRON_ROOT DB_VERB_BACKUP DB_VERB_CHKPOINT DB_VERB_DEADLOCK DB_VERB_FILEOPS DB_VERB_FILEOPS_ALL DB_VERB_RECOVERY DB_VERB_REGISTER DB_VERB_REPLICATION DB_VERB_REPMGR_CONNFAIL DB_VERB_REPMGR_MISC DB_VERB_REP_ELECT DB_VERB_REP_LEASE DB_VERB_REP_MISC DB_VERB_REP_MSGS DB_VERB_REP_SYNC DB_VERB_REP_SYSTEM DB_VERB_REP_TEST DB_VERB_WAITSFOR DB_VERIFY DB_VERIFY_BAD DB_VERIFY_FATAL DB_VERIFY_PARTITION DB_VERSION_FAMILY DB_VERSION_FULL_STRING DB_VERSION_MAJOR DB_VERSION_MINOR DB_VERSION_MISMATCH DB_VERSION_PATCH DB_VERSION_RELEASE DB_VERSION_STRING DB_VRFY_FLAGMASK DB_WRITECURSOR DB_WRITELOCK DB_WRITEOPEN DB_WRNOSYNC DB_XA_CREATE DB_XIDDATASIZE DB_YIELDCPU DB_debug_FLAG DB_user_BEGIN LOGREC_ARG LOGREC_DATA LOGREC_DB LOGREC_DBOP LOGREC_DBT LOGREC_Done LOGREC_HDR LOGREC_LOCKS LOGREC_OP LOGREC_PGDBT LOGREC_PGDDBT LOGREC_PGLIST LOGREC_POINTER LOGREC_TIME ); sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; my ($error, $val) = constant($constname); Carp::croak $error if $error; no strict 'refs'; *{$AUTOLOAD} = sub { $val }; goto &{$AUTOLOAD}; } #bootstrap BerkeleyDB $VERSION; if ($use_XSLoader) { XSLoader::load("BerkeleyDB", $VERSION)} else { bootstrap BerkeleyDB $VERSION } # Preloaded methods go here. sub ParseParameters($@) { my ($default, @rest) = @_ ; my (%got) = %$default ; my (@Bad) ; my ($key, $value) ; my $sub = (caller(1))[3] ; my %options = () ; local ($Carp::CarpLevel) = 1 ; # allow the options to be passed as a hash reference or # as the complete hash. if (@rest == 1) { croak "$sub: parameter is not a reference to a hash" if ref $rest[0] ne "HASH" ; %options = %{ $rest[0] } ; } elsif (@rest >= 2 && @rest % 2 == 0) { %options = @rest ; } elsif (@rest > 0) { croak "$sub: malformed option list"; } while (($key, $value) = each %options) { $key =~ s/^-// ; if (exists $default->{$key}) { $got{$key} = $value } else { push (@Bad, $key) } } if (@Bad) { my ($bad) = join(", ", @Bad) ; croak "unknown key value(s) $bad" ; } return \%got ; } sub parseEncrypt { my $got = shift ; if (defined $got->{Encrypt}) { croak("Encrypt parameter must be a hash reference") if !ref $got->{Encrypt} || ref $got->{Encrypt} ne 'HASH' ; my %config = %{ $got->{Encrypt} } ; my $p = BerkeleyDB::ParseParameters({ Password => undef, Flags => undef, }, %config); croak("Must specify Password and Flags with Encrypt parameter") if ! (defined $p->{Password} && defined $p->{Flags}); $got->{"Enc_Passwd"} = $p->{Password}; $got->{"Enc_Flags"} = $p->{Flags}; } } use UNIVERSAL ; sub env_remove { # Usage: # # $env = BerkeleyDB::env_remove # [ -Home => $path, ] # [ -Config => { name => value, name => value } # [ -Flags => DB_INIT_LOCK| ] # ; my $got = BerkeleyDB::ParseParameters({ Home => undef, Flags => 0, Config => undef, }, @_) ; if (defined $got->{Config}) { croak("Config parameter must be a hash reference") if ! ref $got->{Config} eq 'HASH' ; @BerkeleyDB::a = () ; my $k = "" ; my $v = "" ; while (($k, $v) = each %{$got->{Config}}) { push @BerkeleyDB::a, "$k\t$v" ; } $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) if @BerkeleyDB::a ; } return _env_remove($got) ; } sub db_remove { my $got = BerkeleyDB::ParseParameters( { Filename => undef, Subname => undef, Flags => 0, Env => undef, Txn => undef, }, @_) ; croak("Must specify a filename") if ! defined $got->{Filename} ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); return _db_remove($got); } sub db_rename { my $got = BerkeleyDB::ParseParameters( { Filename => undef, Subname => undef, Newname => undef, Flags => 0, Env => undef, Txn => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Must specify a filename") if ! defined $got->{Filename} ; #croak("Must specify a Subname") #if ! defined $got->{Subname} ; croak("Must specify a Newname") if ! defined $got->{Newname} ; return _db_rename($got); } sub db_verify { my $got = BerkeleyDB::ParseParameters( { Filename => undef, Subname => undef, Outfile => undef, Flags => 0, Env => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Must specify a filename") if ! defined $got->{Filename} ; return _db_verify($got); } package BerkeleyDB::Env ; use UNIVERSAL ; use Carp ; use IO::File; use vars qw( %valid_config_keys ) ; sub isaFilehandle { my $fh = shift ; return ((UNIVERSAL::isa($fh,'GLOB') or UNIVERSAL::isa(\$fh,'GLOB')) and defined fileno($fh) ) } %valid_config_keys = map { $_, 1 } qw( DB_DATA_DIR DB_LOG_DIR DB_TEMP_DIR DB_TMP_DIR ) ; sub new { # Usage: # # $env = new BerkeleyDB::Env # [ -Home => $path, ] # [ -Mode => mode, ] # [ -Config => { name => value, name => value } # [ -ErrFile => filename, ] # [ -ErrPrefix => "string", ] # [ -Flags => DB_INIT_LOCK| ] # [ -Set_Flags => $flags,] # [ -Cachesize => number ] # [ -LockDetect => ] # [ -Verbose => boolean ] # [ -Encrypt => { Password => string, Flags => value} # # ; my $pkg = shift ; my $got = BerkeleyDB::ParseParameters({ Home => undef, Server => undef, Mode => 0666, ErrFile => undef, MsgFile => undef, ErrPrefix => undef, Flags => 0, SetFlags => 0, Cachesize => 0, LockDetect => 0, TxMax => 0, LogConfig => 0, MaxLockers => 0, MaxLocks => 0, MaxObjects => 0, Verbose => 0, Config => undef, Encrypt => undef, SharedMemKey => undef, Set_Lk_Exclusive => undef, ThreadCount => 0, }, @_) ; my $errfile = $got->{ErrFile} ; if (defined $got->{ErrFile}) { if (!isaFilehandle($got->{ErrFile})) { my $handle = new IO::File ">$got->{ErrFile}" or croak "Cannot open file $got->{ErrFile}: $!\n" ; $errfile = $got->{ErrFile} = $handle ; } } if (defined $got->{MsgFile}) { my $msgfile = $got->{MsgFile} ; if (!isaFilehandle($msgfile)) { my $handle = new IO::File ">$msgfile" or croak "Cannot open file $msgfile: $!\n" ; $got->{MsgFile} = $handle ; } } my %config ; if (defined $got->{Config}) { croak("Config parameter must be a hash reference") if ! ref $got->{Config} eq 'HASH' ; %config = %{ $got->{Config} } ; @BerkeleyDB::a = () ; my $k = "" ; my $v = "" ; while (($k, $v) = each %config) { if ($BerkeleyDB::db_version >= 3.1 && ! $valid_config_keys{$k} ){ $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; croak $BerkeleyDB::Error ; } push @BerkeleyDB::a, "$k\t$v" ; $got->{$k} = $v; } $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) if @BerkeleyDB::a ; } BerkeleyDB::parseEncrypt($got); my ($addr) = _db_appinit($pkg, $got, $errfile); my $obj ; $obj = bless [$addr] , $pkg if $addr ; # if ($obj && $BerkeleyDB::db_version >= 3.1 && keys %config) { # my ($k, $v); # while (($k, $v) = each %config) { # if ($k eq 'DB_DATA_DIR') # { $obj->set_data_dir($v) } # elsif ($k eq 'DB_LOG_DIR') # { $obj->set_lg_dir($v) } # elsif ($k eq 'DB_TEMP_DIR' || $k eq 'DB_TMP_DIR') # { $obj->set_tmp_dir($v) } # else { # $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; # croak $BerkeleyDB::Error # } # } # } return $obj ; } sub TxnMgr { my $env = shift ; my ($addr) = $env->_TxnMgr() ; my $obj ; $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ; return $obj ; } sub txn_begin { my $env = shift ; my ($addr) = $env->_txn_begin(@_) ; my $obj ; $obj = bless [$addr, $env] , "BerkeleyDB::Txn" if $addr ; return $obj ; } sub DESTROY { my $self = shift ; $self->_DESTROY() ; } sub STORABLE_freeze { my $type = ref shift; croak "Cannot freeze $type object\n"; } sub STORABLE_thaw { my $type = ref shift; croak "Cannot thaw $type object\n"; } package BerkeleyDB::Hash ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; use UNIVERSAL ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Hash specific Ffactor => 0, Nelem => 0, Hash => undef, DupCompare => undef, # BerkeleyDB specific ReadKey => undef, WriteKey => undef, ReadValue => undef, WriteValue => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn'); croak("-Tie needs a reference to a hash") if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; BerkeleyDB::parseEncrypt($got); my ($addr) = _db_open_hash($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *TIEHASH = \&new ; package BerkeleyDB::Btree ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; use UNIVERSAL ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Btree specific Minkey => 0, Compare => undef, DupCompare => undef, Prefix => undef, set_bt_compress => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn'); croak("-Tie needs a reference to a hash") if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; # if (defined $got->{set_bt_compress} ) # { # # croak("-set_bt_compress needs a reference to a 2-element array") # if $got->{set_bt_compress} !~ /ARRAY/ || # # croak("-set_bt_compress needs a reference to a 2-element array") # if $got->{set_bt_compress} !~ /ARRAY/ || # @{ $got->{set_bt_compress} } != 2; # # $got->{"_btcompress1"} = $got->{set_bt_compress}[0] # if defined $got->{set_bt_compress}[0]; # # $got->{"_btcompress2"} = $got->{set_bt_compress}[1] # if defined $got->{set_bt_compress}[1]; # } BerkeleyDB::parseEncrypt($got); my ($addr) = _db_open_btree($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *BerkeleyDB::Btree::TIEHASH = \&BerkeleyDB::Btree::new ; package BerkeleyDB::Heap ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; use UNIVERSAL ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, Txn => undef, Encrypt => undef, # Heap specific HeapSize => undef, HeapSizeGb => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn'); # if (defined $got->{HeapSize} ) # { # # croak("-HeapSize needs a reference to a 2-element array") # if $got->{HeapSize} !~ /ARRAY/ || # # croak("-HeapSize needs a reference to a 2-element array") # if $got->{HeapSize} !~ /ARRAY/ || # @{ $got->{set_bt_compress} } != 2; # # $got->{"HeapSize"} = $got->{HeapSize}[0] # if defined $got->{HeapSize}[0]; # # $got->{"HeapSize"} = $got->{HeapSize}[1] # if defined $got->{HeapSize}[1]; # } BerkeleyDB::parseEncrypt($got); my ($addr) = _db_open_heap($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } sub TIEHASH { die "Tied Hash interface not supported with BerkeleyDB::Heap\n" ; } package BerkeleyDB::Recno ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; use UNIVERSAL ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Recno specific Delim => undef, Len => undef, Pad => undef, Source => undef, ArrayBase => 1, # lowest index in array }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn'); croak("Tie needs a reference to an array") if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; BerkeleyDB::parseEncrypt($got); $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; my ($addr) = _db_open_recno($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *BerkeleyDB::Recno::TIEARRAY = \&BerkeleyDB::Recno::new ; *BerkeleyDB::Recno::db_stat = \&BerkeleyDB::Btree::db_stat ; package BerkeleyDB::Queue ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; use UNIVERSAL ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Queue specific Len => undef, Pad => undef, ArrayBase => 1, # lowest index in array ExtentSize => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn'); croak("Tie needs a reference to an array") if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; BerkeleyDB::parseEncrypt($got); $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; my ($addr) = _db_open_queue($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *BerkeleyDB::Queue::TIEARRAY = \&BerkeleyDB::Queue::new ; sub UNSHIFT { my $self = shift; croak "unshift is unsupported with Queue databases"; } ## package BerkeleyDB::Text ; ## ## use vars qw(@ISA) ; ## @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; ## use UNIVERSAL ; ## use Carp ; ## ## sub new ## { ## my $self = shift ; ## my $got = BerkeleyDB::ParseParameters( ## { ## # Generic Stuff ## Filename => undef, ## #Flags => BerkeleyDB::DB_CREATE(), ## Flags => 0, ## Property => 0, ## Mode => 0666, ## Cachesize => 0, ## Lorder => 0, ## Pagesize => 0, ## Env => undef, ## #Tie => undef, ## Txn => undef, ## ## # Recno specific ## Delim => undef, ## Len => undef, ## Pad => undef, ## Btree => undef, ## }, @_) ; ## ## croak("Env not of type BerkeleyDB::Env") ## if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); ## ## croak("Txn not of type BerkeleyDB::Txn") ## if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); ## ## croak("-Tie needs a reference to an array") ## if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; ## ## # rearange for recno ## $got->{Source} = $got->{Filename} if defined $got->{Filename} ; ## delete $got->{Filename} ; ## $got->{Fname} = $got->{Btree} if defined $got->{Btree} ; ## return BerkeleyDB::Recno::_db_open_recno($self, $got); ## } ## ## *BerkeleyDB::Text::TIEARRAY = \&BerkeleyDB::Text::new ; ## *BerkeleyDB::Text::db_stat = \&BerkeleyDB::Btree::db_stat ; package BerkeleyDB::Unknown ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; use UNIVERSAL ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn'); croak("-Tie needs a reference to a hash") if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; BerkeleyDB::parseEncrypt($got); my ($addr, $type) = _db_open_unknown($got); my $obj ; if ($addr) { $obj = bless [$addr], "BerkeleyDB::$type" ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } package BerkeleyDB::_tiedHash ; use Carp ; #sub TIEHASH #{ # my $self = shift ; # my $db_object = shift ; # #print "Tiehash REF=[$self] [" . (ref $self) . "]\n" ; # # return bless { Obj => $db_object}, $self ; #} sub Tie { # Usage: # # $db->Tie \%hash ; # my $self = shift ; #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ; croak("usage \$x->Tie \\%hash\n") unless @_ ; my $ref = shift ; croak("Tie needs a reference to a hash") if defined $ref and $ref !~ /HASH/ ; #tie %{ $ref }, ref($self), $self ; tie %{ $ref }, "BerkeleyDB::_tiedHash", $self ; return undef ; } sub TIEHASH { my $self = shift ; my $db_object = shift ; #return bless $db_object, 'BerkeleyDB::Common' ; return $db_object ; } sub STORE { my $self = shift ; my $key = shift ; my $value = shift ; $self->db_put($key, $value) ; } sub FETCH { my $self = shift ; my $key = shift ; my $value = undef ; $self->db_get($key, $value) ; return $value ; } sub EXISTS { my $self = shift ; my $key = shift ; my $value = undef ; $self->db_get($key, $value) == 0 ; } sub DELETE { my $self = shift ; my $key = shift ; $self->db_del($key) ; } sub CLEAR_old { my $self = shift ; my ($key, $value) = (0, 0) ; my $cursor = $self->_db_write_cursor() ; while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0) { $cursor->c_del() } } sub CLEAR_new { my $self = shift ; $self->truncate(my $count); } *CLEAR = $BerkeleyDB::db_version < 4 ? \&CLEAR_old : \&CLEAR_new ; #sub DESTROY #{ # my $self = shift ; # print "BerkeleyDB::_tieHash::DESTROY\n" ; # $self->{Cursor}->c_close() if $self->{Cursor} ; #} package BerkeleyDB::_tiedArray ; use Carp ; sub Tie { # Usage: # # $db->Tie \@array ; # my $self = shift ; #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ; croak("usage \$x->Tie \\%hash\n") unless @_ ; my $ref = shift ; croak("Tie needs a reference to an array") if defined $ref and $ref !~ /ARRAY/ ; #tie %{ $ref }, ref($self), $self ; tie @{ $ref }, "BerkeleyDB::_tiedArray", $self ; return undef ; } #sub TIEARRAY #{ # my $self = shift ; # my $db_object = shift ; # #print "Tiearray REF=[$self] [" . (ref $self) . "]\n" ; # # return bless { Obj => $db_object}, $self ; #} sub TIEARRAY { my $self = shift ; my $db_object = shift ; #return bless $db_object, 'BerkeleyDB::Common' ; return $db_object ; } sub STORE { my $self = shift ; my $key = shift ; my $value = shift ; $self->db_put($key, $value) ; } sub FETCH { my $self = shift ; my $key = shift ; my $value = undef ; $self->db_get($key, $value) ; return $value ; } *CLEAR = \&BerkeleyDB::_tiedHash::CLEAR ; *FIRSTKEY = \&BerkeleyDB::_tiedHash::FIRSTKEY ; *NEXTKEY = \&BerkeleyDB::_tiedHash::NEXTKEY ; sub EXTEND {} # don't do anything with EXTEND sub SHIFT { my $self = shift; my ($key, $value) = (0, 0) ; my $cursor = $self->_db_write_cursor() ; return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) != 0 ; return undef if $cursor->c_del() != 0 ; return $value ; } sub UNSHIFT { my $self = shift; if (@_) { my ($key, $value) = (0, 0) ; my $cursor = $self->_db_write_cursor() ; my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) ; if ($status == 0) { foreach $value (reverse @_) { $key = 0 ; $cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ; } } elsif ($status == BerkeleyDB::DB_NOTFOUND()) { $key = 0 ; foreach $value (@_) { $self->db_put($key++, $value) ; } } } } sub PUSH { my $self = shift; if (@_) { my ($key, $value) = (-1, 0) ; my $cursor = $self->_db_write_cursor() ; my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) ; if ($status == 0 || $status == BerkeleyDB::DB_NOTFOUND()) { $key = -1 if $status != 0 and $self->type != BerkeleyDB::DB_RECNO() ; foreach $value (@_) { ++ $key ; $status = $self->db_put($key, $value) ; } } # can use this when DB_APPEND is fixed. # foreach $value (@_) # { # my $status = $cursor->c_put($key, $value, BerkeleyDB::DB_AFTER()) ; #print "[$status]\n" ; # } } } sub POP { my $self = shift; my ($key, $value) = (0, 0) ; my $cursor = $self->_db_write_cursor() ; return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) != 0 ; return undef if $cursor->c_del() != 0 ; return $value ; } sub SPLICE { my $self = shift; croak "SPLICE is not implemented yet" ; } *shift = \&SHIFT ; *unshift = \&UNSHIFT ; *push = \&PUSH ; *pop = \&POP ; *clear = \&CLEAR ; *length = \&FETCHSIZE ; sub STORESIZE { croak "STORESIZE is not implemented yet" ; #print "STORESIZE @_\n" ; # my $self = shift; # my $length = shift ; # my $current_length = $self->FETCHSIZE() ; #print "length is $current_length\n"; # # if ($length < $current_length) { #print "Make smaller $length < $current_length\n" ; # my $key ; # for ($key = $current_length - 1 ; $key >= $length ; -- $key) # { $self->db_del($key) } # } # elsif ($length > $current_length) { #print "Make larger $length > $current_length\n" ; # $self->db_put($length-1, "") ; # } # else { print "stay the same\n" } } #sub DESTROY #{ # my $self = shift ; # print "BerkeleyDB::_tieArray::DESTROY\n" ; #} package BerkeleyDB::Common ; use Carp ; sub STORABLE_freeze { my $type = ref shift; croak "Cannot freeze $type object\n"; } sub STORABLE_thaw { my $type = ref shift; croak "Cannot thaw $type object\n"; } sub DESTROY { my $self = shift ; $self->_DESTROY() ; } sub Env { my $self = shift ; $self->[1] ; } sub Txn { my $self = shift ; my $txn = shift ; #print "BerkeleyDB::Common::Txn db [$self] txn [$txn]\n" ; if ($txn) { $self->_Txn($txn) ; push @{ $txn }, $self ; } else { $self->_Txn() ; } #print "end BerkeleyDB::Common::Txn \n"; } sub get_dup { croak "Usage: \$db->get_dup(key [,flag])\n" unless @_ == 2 or @_ == 3 ; my $db = shift ; my $key = shift ; my $flag = shift ; my $value = 0 ; my $origkey = $key ; my $wantarray = wantarray ; my %values = () ; my @values = () ; my $counter = 0 ; my $status = 0 ; my $cursor = $db->db_cursor() ; # iterate through the database until either EOF ($status == 0) # or a different key is encountered ($key ne $origkey). for ($status = $cursor->c_get($key, $value, BerkeleyDB::DB_SET()) ; $status == 0 and $key eq $origkey ; $status = $cursor->c_get($key, $value, BerkeleyDB::DB_NEXT()) ) { # save the value or count number of matches if ($wantarray) { if ($flag) { ++ $values{$value} } else { push (@values, $value) } } else { ++ $counter } } return ($wantarray ? ($flag ? %values : @values) : $counter) ; } sub db_cursor { my $db = shift ; my ($addr) = $db->_db_cursor(@_) ; my $obj ; $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } sub _db_write_cursor { my $db = shift ; my ($addr) = $db->__db_write_cursor(@_) ; my $obj ; $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } sub db_join { croak 'Usage: $db->BerkeleyDB::db_join([cursors], flags=0)' if @_ < 2 || @_ > 3 ; my $db = shift ; croak 'db_join: first parameter is not an array reference' if ! ref $_[0] || ref $_[0] ne 'ARRAY'; my ($addr) = $db->_db_join(@_) ; my $obj ; $obj = bless [$addr, $db, $_[0]] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } package BerkeleyDB::Cursor ; sub c_close { my $cursor = shift ; $cursor->[1] = "" ; return $cursor->_c_close() ; } sub c_dup { my $cursor = shift ; my ($addr) = $cursor->_c_dup(@_) ; my $obj ; $obj = bless [$addr, $cursor->[1]] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } sub DESTROY { my $self = shift ; $self->_DESTROY() ; } package BerkeleyDB::TxnMgr ; sub DESTROY { my $self = shift ; $self->_DESTROY() ; } sub txn_begin { my $txnmgr = shift ; my ($addr) = $txnmgr->_txn_begin(@_) ; my $obj ; $obj = bless [$addr, $txnmgr] , "BerkeleyDB::Txn" if $addr ; return $obj ; } package BerkeleyDB::Txn ; sub Txn { my $self = shift ; my $db ; # keep a reference to each db in the txn object foreach $db (@_) { $db->_Txn($self) ; push @{ $self}, $db ; } } sub txn_commit { my $self = shift ; $self->disassociate() ; my $status = $self->_txn_commit() ; return $status ; } sub txn_abort { my $self = shift ; $self->disassociate() ; my $status = $self->_txn_abort() ; return $status ; } sub disassociate { my $self = shift ; my $db ; while ( @{ $self } > 2) { $db = pop @{ $self } ; $db->Txn() ; } #print "end disassociate\n" ; } sub DESTROY { my $self = shift ; $self->disassociate() ; # first close the close the transaction $self->_DESTROY() ; } package BerkeleyDB::CDS::Lock; use vars qw(%Object %Count); use Carp; sub BerkeleyDB::Common::cds_lock { my $db = shift ; # fatal error if database not opened in CDS mode croak("CDS not enabled for this database\n") if ! $db->cds_enabled(); if ( ! defined $Object{"$db"}) { $Object{"$db"} = $db->_db_write_cursor() || return undef ; } ++ $Count{"$db"} ; return bless [$db, 1], "BerkeleyDB::CDS::Lock" ; } sub cds_unlock { my $self = shift ; my $db = $self->[0] ; if ($self->[1]) { $self->[1] = 0 ; -- $Count{"$db"} if $Count{"$db"} > 0 ; if ($Count{"$db"} == 0) { $Object{"$db"}->c_close() ; undef $Object{"$db"}; } return 1 ; } return undef ; } sub DESTROY { my $self = shift ; $self->cds_unlock() ; } package BerkeleyDB::Term ; END { close_everything() ; } package BerkeleyDB ; # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__