diff options
Diffstat (limited to 'bdb/perl/BerkeleyDB/BerkeleyDB.pm')
| -rw-r--r-- | bdb/perl/BerkeleyDB/BerkeleyDB.pm | 1506 |
1 files changed, 0 insertions, 1506 deletions
diff --git a/bdb/perl/BerkeleyDB/BerkeleyDB.pm b/bdb/perl/BerkeleyDB/BerkeleyDB.pm deleted file mode 100644 index c56390ba71f..00000000000 --- a/bdb/perl/BerkeleyDB/BerkeleyDB.pm +++ /dev/null @@ -1,1506 +0,0 @@ - -package BerkeleyDB; - - -# Copyright (c) 1997-2002 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.004_04 } - -use strict; -use Carp; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD - $use_XSLoader); - -$VERSION = '0.20'; - -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( - 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_AUTO_COMMIT - DB_BEFORE - DB_BROADCAST_EID - DB_BTREE - DB_BTREEMAGIC - DB_BTREEOLDVER - DB_BTREEVERSION - DB_CACHED_COUNTS - DB_CDB_ALLDB - DB_CHECKPOINT - DB_CHKSUM_SHA1 - DB_CLIENT - DB_CL_WRITER - DB_COMMIT - DB_CONSUME - DB_CONSUME_WAIT - DB_CREATE - DB_CURLSN - DB_CURRENT - DB_CXX_NO_EXCEPTIONS - DB_DELETED - DB_DELIMITER - DB_DIRECT - DB_DIRECT_DB - DB_DIRECT_LOG - DB_DIRTY_READ - DB_DONOTINDEX - DB_DUP - DB_DUPCURSOR - DB_DUPSORT - DB_EID_BROADCAST - DB_EID_INVALID - DB_ENCRYPT - DB_ENCRYPT_AES - DB_ENV_APPINIT - DB_ENV_AUTO_COMMIT - DB_ENV_CDB - DB_ENV_CDB_ALLDB - DB_ENV_CREATE - DB_ENV_DBLOCAL - DB_ENV_DIRECT_DB - DB_ENV_DIRECT_LOG - DB_ENV_FATAL - DB_ENV_LOCKDOWN - DB_ENV_LOCKING - DB_ENV_LOGGING - DB_ENV_NOLOCKING - DB_ENV_NOMMAP - DB_ENV_NOPANIC - DB_ENV_OPEN_CALLED - DB_ENV_OVERWRITE - DB_ENV_PANIC_OK - DB_ENV_PRIVATE - 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_TXN - DB_ENV_TXN_NOSYNC - DB_ENV_TXN_WRITE_NOSYNC - DB_ENV_USER_ALLOC - DB_ENV_YIELDCPU - DB_EXCL - DB_EXTENT - DB_FAST_STAT - DB_FCNTL_LOCKING - DB_FILE_ID_LEN - DB_FIRST - DB_FIXEDLEN - DB_FLUSH - DB_FORCE - DB_GETREC - DB_GET_BOTH - DB_GET_BOTHC - DB_GET_BOTH_RANGE - DB_GET_RECNO - DB_HANDLE_LOCK - DB_HASH - DB_HASHMAGIC - DB_HASHOLDVER - DB_HASHVERSION - DB_INCOMPLETE - DB_INIT_CDB - DB_INIT_LOCK - DB_INIT_LOG - DB_INIT_MPOOL - DB_INIT_TXN - DB_INVALID_EID - DB_JAVA_CALLBACK - DB_JOINENV - DB_JOIN_ITEM - DB_JOIN_NOSORT - DB_KEYEMPTY - DB_KEYEXIST - DB_KEYFIRST - DB_KEYLAST - DB_LAST - DB_LOCKDOWN - DB_LOCKMAGIC - DB_LOCKVERSION - 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_INHERIT - DB_LOCK_MAXLOCKS - 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_LOGC_BUF_SIZE - DB_LOGFILEID_INVALID - DB_LOGMAGIC - DB_LOGOLDVER - DB_LOGVERSION - DB_LOG_DISK - DB_LOG_LOCKED - DB_LOG_SILENT_ERR - DB_MAX_PAGES - DB_MAX_RECORDS - DB_MPOOL_CLEAN - DB_MPOOL_CREATE - DB_MPOOL_DIRTY - DB_MPOOL_DISCARD - DB_MPOOL_EXTENT - DB_MPOOL_LAST - DB_MPOOL_NEW - DB_MPOOL_NEW_GROUP - DB_MPOOL_PRIVATE - DB_MULTIPLE - DB_MULTIPLE_KEY - DB_MUTEXDEBUG - DB_MUTEXLOCKS - DB_NEEDSPLIT - DB_NEXT - DB_NEXT_DUP - DB_NEXT_NODUP - DB_NOCOPY - DB_NODUPDATA - 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_ODDFILESIZE - DB_OK_BTREE - DB_OK_HASH - DB_OK_QUEUE - DB_OK_RECNO - DB_OLD_VERSION - DB_OPEN_CALLED - DB_OPFLAGS_MASK - DB_ORDERCHKONLY - DB_OVERWRITE - DB_PAD - DB_PAGEYIELD - DB_PAGE_LOCK - DB_PAGE_NOTFOUND - DB_PANIC_ENVIRONMENT - DB_PERMANENT - DB_POSITION - DB_POSITIONI - DB_PREV - DB_PREV_NODUP - DB_PRINTABLE - DB_PRIORITY_DEFAULT - DB_PRIORITY_HIGH - DB_PRIORITY_LOW - 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_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_REGISTERED - DB_RENAMEMAGIC - DB_RENUMBER - DB_REP_CLIENT - DB_REP_DUPMASTER - DB_REP_HOLDELECTION - DB_REP_LOGSONLY - DB_REP_MASTER - DB_REP_NEWMASTER - DB_REP_NEWSITE - DB_REP_OUTDATED - DB_REP_PERMANENT - DB_REP_UNAVAIL - DB_REVSPLITOFF - DB_RMW - DB_RPC_SERVERPROG - DB_RPC_SERVERVERS - DB_RUNRECOVERY - DB_SALVAGE - DB_SECONDARY_BAD - DB_SEQUENTIAL - DB_SET - DB_SET_LOCK_TIMEOUT - DB_SET_RANGE - DB_SET_RECNO - DB_SET_TXN_NOW - DB_SET_TXN_TIMEOUT - DB_SNAPSHOT - DB_STAT_CLEAR - 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_POSTEXTDELETE - DB_TEST_POSTEXTOPEN - DB_TEST_POSTEXTUNLINK - DB_TEST_POSTLOG - DB_TEST_POSTLOGMETA - DB_TEST_POSTOPEN - DB_TEST_POSTRENAME - DB_TEST_POSTSYNC - DB_TEST_PREDESTROY - DB_TEST_PREEXTDELETE - DB_TEST_PREEXTOPEN - DB_TEST_PREEXTUNLINK - DB_TEST_PREOPEN - DB_TEST_PRERENAME - DB_TEST_SUBDB_LOCKS - DB_THREAD - DB_TIMEOUT - DB_TRUNCATE - DB_TXNMAGIC - DB_TXNVERSION - DB_TXN_ABORT - DB_TXN_APPLY - DB_TXN_BACKWARD_ALLOC - DB_TXN_BACKWARD_ROLL - DB_TXN_CKP - DB_TXN_FORWARD_ROLL - DB_TXN_GETPGNOS - 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_NOSYNC - DB_TXN_NOWAIT - DB_TXN_OPENFILES - DB_TXN_POPENFILES - DB_TXN_PRINT - DB_TXN_REDO - DB_TXN_SYNC - DB_TXN_UNDO - DB_TXN_WRITE_NOSYNC - DB_UNKNOWN - DB_UNRESOLVED_CHILD - DB_UPDATE_SECONDARY - DB_UPGRADE - DB_USE_ENVIRON - DB_USE_ENVIRON_ROOT - DB_VERB_CHKPOINT - DB_VERB_DEADLOCK - DB_VERB_RECOVERY - DB_VERB_REPLICATION - DB_VERB_WAITSFOR - DB_VERIFY - DB_VERIFY_BAD - DB_VERIFY_FATAL - DB_VERSION_MAJOR - DB_VERSION_MINOR - DB_VERSION_PATCH - DB_VERSION_STRING - DB_VRFY_FLAGMASK - DB_WRITECURSOR - DB_WRITELOCK - DB_WRITEOPEN - DB_WRNOSYNC - DB_XA_CREATE - DB_XIDDATASIZE - DB_YIELDCPU - ); - -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) { - %options = @rest ; - } - - 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 ; -} - -use UNIVERSAL qw( isa ) ; - -sub env_remove -{ - # Usage: - # - # $env = new BerkeleyDB::Env - # [ -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, - }, @_) ; - - croak("Must specify a filename") - if ! defined $got->{Filename} ; - - croak("Env not of type BerkeleyDB::Env") - if defined $got->{Env} and ! 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, - }, @_) ; - - croak("Env not of type BerkeleyDB::Env") - if defined $got->{Env} and ! 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 ! isa($got->{Env},'BerkeleyDB::Env'); - - croak("Must specify a filename") - if ! defined $got->{Filename} ; - - return _db_verify($got); -} - -package BerkeleyDB::Env ; - -use UNIVERSAL qw( isa ) ; -use Carp ; -use vars qw( %valid_config_keys ) ; - -sub isaFilehandle -{ - my $fh = shift ; - - return ((isa($fh,'GLOB') or 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 ] - # ; - - my $pkg = shift ; - my $got = BerkeleyDB::ParseParameters({ - Home => undef, - Server => undef, - Mode => 0666, - ErrFile => undef, - ErrPrefix => undef, - Flags => 0, - SetFlags => 0, - Cachesize => 0, - LockDetect => 0, - Verbose => 0, - Config => undef, - }, @_) ; - - if (defined $got->{ErrFile}) { - croak("ErrFile parameter must be a file name") - if ref $got->{ErrFile} ; - #if (!isaFilehandle($got->{ErrFile})) { - # my $handle = new IO::File ">$got->{ErrFile}" -# or croak "Cannot open file $got->{ErrFile}: $!\n" ; -# $got->{ErrFile} = $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->{"Config"} = pack("p*", @BerkeleyDB::a, undef) - if @BerkeleyDB::a ; - } - - my ($addr) = _db_appinit($pkg, $got) ; - 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() ; -} - -package BerkeleyDB::Hash ; - -use vars qw(@ISA) ; -@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; -use UNIVERSAL qw( isa ) ; -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, - - # 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 ! 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 a hash") - if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; - - 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 qw( isa ) ; -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, - - # Btree specific - Minkey => 0, - Compare => undef, - DupCompare => undef, - Prefix => 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 a hash") - if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; - - 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::Recno ; - -use vars qw(@ISA) ; -@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; -use UNIVERSAL qw( isa ) ; -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, - - # 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 ! 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/ ; - - croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") - if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; - - - $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 qw( isa ) ; -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, - - # 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 ! 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/ ; - - croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") - if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; - - $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 qw( isa ) ; -## 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 qw( isa ) ; -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, - - }, @_) ; - - 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 a hash") - if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; - - 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 -{ - my $self = shift ; - my ($key, $value) = (0, 0) ; - my $cursor = $self->db_cursor() ; - while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0) - { $cursor->c_del() } - #1 while $cursor->c_del() == 0 ; - # cursor will self-destruct -} - -#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_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_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_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_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 DESTROY -{ - my $self = shift ; - $self->_DESTROY() ; -} - -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_join -{ - croak 'Usage: $db->BerkeleyDB::Common::db_join([cursors], flags=0)' - if @_ < 2 || @_ > 3 ; - my $db = shift ; - 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::Term ; - -END -{ - close_everything() ; -} - - -package BerkeleyDB ; - - - -# Autoload methods go after =cut, and are processed by the autosplit program. - -1; -__END__ - - |