diff options
Diffstat (limited to 'bdb/perl')
82 files changed, 37222 insertions, 0 deletions
diff --git a/bdb/perl/BerkeleyDB/BerkeleyDB.pm b/bdb/perl/BerkeleyDB/BerkeleyDB.pm new file mode 100644 index 00000000000..c56390ba71f --- /dev/null +++ b/bdb/perl/BerkeleyDB/BerkeleyDB.pm @@ -0,0 +1,1506 @@ + +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__ + + diff --git a/bdb/perl/BerkeleyDB/BerkeleyDB.pod b/bdb/perl/BerkeleyDB/BerkeleyDB.pod new file mode 100644 index 00000000000..60f30e2abfb --- /dev/null +++ b/bdb/perl/BerkeleyDB/BerkeleyDB.pod @@ -0,0 +1,1792 @@ +=head1 NAME + +BerkeleyDB - Perl extension for Berkeley DB version 2, 3 or 4 + +=head1 SYNOPSIS + + use BerkeleyDB; + + $env = new BerkeleyDB::Env [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Hash', [OPTIONS] ; + $db = new BerkeleyDB::Hash [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Btree', [OPTIONS] ; + $db = new BerkeleyDB::Btree [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Recno', [OPTIONS] ; + $db = new BerkeleyDB::Recno [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Queue', [OPTIONS] ; + $db = new BerkeleyDB::Queue [OPTIONS] ; + + $db = new BerkeleyDB::Unknown [OPTIONS] ; + + $status = BerkeleyDB::db_remove [OPTIONS] + $status = BerkeleyDB::db_rename [OPTIONS] + $status = BerkeleyDB::db_verify [OPTIONS] + + $hash{$key} = $value ; + $value = $hash{$key} ; + each %hash ; + keys %hash ; + values %hash ; + + $status = $db->db_get() + $status = $db->db_put() ; + $status = $db->db_del() ; + $status = $db->db_sync() ; + $status = $db->db_close() ; + $status = $db->db_close() ; + $status = $db->db_pget() + $hash_ref = $db->db_stat() ; + $status = $db->db_key_range(); + $type = $db->type() ; + $status = $db->status() ; + $boolean = $db->byteswapped() ; + $status = $db->truncate($count) ; + + ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ; + ($flag, $old_offset, $old_length) = $db->partial_clear() ; + + $cursor = $db->db_cursor([$flags]) ; + $newcursor = $cursor->c_dup([$flags]); + $status = $cursor->c_get() ; + $status = $cursor->c_put() ; + $status = $cursor->c_del() ; + $status = $cursor->c_count() ; + $status = $cursor->c_pget() ; + $status = $cursor->status() ; + $status = $cursor->c_close() ; + + $cursor = $db->db_join() ; + $status = $cursor->c_get() ; + $status = $cursor->c_close() ; + + $status = $env->txn_checkpoint() + $hash_ref = $env->txn_stat() + $status = $env->setmutexlocks() + $status = $env->set_flags() + + $txn = $env->txn_begin() ; + $db->Txn($txn); + $txn->Txn($db1, $db2,...); + $status = $txn->txn_prepare() + $status = $txn->txn_commit() + $status = $txn->txn_abort() + $status = $txn->txn_id() + $status = $txn->txn_discard() + + $status = $env->set_lg_dir(); + $status = $env->set_lg_bsize(); + $status = $env->set_lg_max(); + + $status = $env->set_data_dir() ; + $status = $env->set_tmp_dir() ; + $status = $env->set_verbose() ; + + $BerkeleyDB::Error + $BerkeleyDB::db_version + + # DBM Filters + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; + + # deprecated, but supported + $txn_mgr = $env->TxnMgr(); + $status = $txn_mgr->txn_checkpoint() + $hash_ref = $txn_mgr->txn_stat() + $txn = $txn_mgr->txn_begin() ; + +=head1 DESCRIPTION + +B<NOTE: This document is still under construction. Expect it to be +incomplete in places.> + +This Perl module provides an interface to most of the functionality +available in Berkeley DB versions 2, 3 and 4. In general it is safe to assume +that the interface provided here to be identical to the Berkeley DB +interface. The main changes have been to make the Berkeley DB API work +in a Perl way. Note that if you are using Berkeley DB 2.x, the new +features available in Berkeley DB 3.x or DB 4.x are not available via +this module. + +The reader is expected to be familiar with the Berkeley DB +documentation. Where the interface provided here is identical to the +Berkeley DB library and the... TODO + +The B<db_appinit>, B<db_cursor>, B<db_open> and B<db_txn> man pages are +particularly relevant. + +The interface to Berkeley DB is implemented with a number of Perl +classes. + +=head1 ENV CLASS + +The B<BerkeleyDB::Env> class provides an interface to the Berkeley DB +function B<db_appinit> in Berkeley DB 2.x or B<db_env_create> and +B<DBENV-E<gt>open> in Berkeley DB 3.x/4.x. Its purpose is to initialise a +number of sub-systems that can then be used in a consistent way in all +the databases you make use of the environment. + +If you don't intend using transactions, locking or logging, then you +shouldn't need to make use of B<BerkeleyDB::Env>. + +=head2 Synopsis + + $env = new BerkeleyDB::Env + [ -Home => $path, ] + [ -Server => $name, ] + [ -CacheSize => $number, ] + [ -Config => { name => value, name => value }, ] + [ -ErrFile => filename, ] + [ -ErrPrefix => "string", ] + [ -Flags => number, ] + [ -SetFlags => bitmask, ] + [ -LockDetect => number, ] + [ -Verbose => boolean, ] + +=over 5 + +All the parameters to the BerkeleyDB::Env constructor are optional. + +=item -Home + +If present, this parameter should point to an existing directory. Any +files that I<aren't> specified with an absolute path in the sub-systems +that are initialised by the BerkeleyDB::Env class will be assumed to +live in the B<Home> directory. + +For example, in the code fragment below the database "fred.db" will be +opened in the directory "/home/databases" because it was specified as a +relative path, but "joe.db" will be opened in "/other" because it was +part of an absolute path. + + $env = new BerkeleyDB::Env + -Home => "/home/databases" + ... + + $db1 = new BerkeleyDB::Hash + -Filename = "fred.db", + -Env => $env + ... + + $db2 = new BerkeleyDB::Hash + -Filename = "/other/joe.db", + -Env => $env + ... + +=item -Server + +If present, this parameter should be the hostname of a server that is running +the Berkeley DB RPC server. All databases will be accessed via the RPC server. + +=item -Cachesize + +If present, this parameter sets the size of the environments shared memory +buffer pool. + +=item -Config + +This is a variation on the C<-Home> parameter, but it allows finer +control of where specific types of files will be stored. + +The parameter expects a reference to a hash. Valid keys are: +B<DB_DATA_DIR>, B<DB_LOG_DIR> and B<DB_TMP_DIR> + +The code below shows an example of how it can be used. + + $env = new BerkeleyDB::Env + -Config => { DB_DATA_DIR => "/home/databases", + DB_LOG_DIR => "/home/logs", + DB_TMP_DIR => "/home/tmp" + } + ... + +=item -ErrFile + +Expects a filenme. Any errors generated internally by Berkeley DB will +be logged to this file. + +=item -ErrPrefix + +Allows a prefix to be added to the error messages before they are sent +to B<-ErrFile>. + +=item -Flags + +The B<Flags> parameter specifies both which sub-systems to initialise, +as well as a number of environment-wide options. +See the Berkeley DB documentation for more details of these options. + +Any of the following can be specified by OR'ing them: + +B<DB_CREATE> + +If any of the files specified do not already exist, create them. + +B<DB_INIT_CDB> + +Initialise the Concurrent Access Methods + +B<DB_INIT_LOCK> + +Initialise the Locking sub-system. + +B<DB_INIT_LOG> + +Initialise the Logging sub-system. + +B<DB_INIT_MPOOL> + +Initialise the ... + +B<DB_INIT_TXN> + +Initialise the ... + +B<DB_MPOOL_PRIVATE> + +Initialise the ... + +B<DB_INIT_MPOOL> is also specified. + +Initialise the ... + +B<DB_NOMMAP> + +Initialise the ... + +B<DB_RECOVER> + + + +B<DB_RECOVER_FATAL> + +B<DB_THREAD> + +B<DB_TXN_NOSYNC> + +B<DB_USE_ENVIRON> + +B<DB_USE_ENVIRON_ROOT> + +=item -SetFlags + +Calls ENV->set_flags with the supplied bitmask. Use this when you need to make +use of DB_ENV->set_flags before DB_ENV->open is called. + +Only valid when Berkeley DB 3.x or better is used. + +=item -LockDetect + +Specifies what to do when a lock conflict occurs. The value should be one of + +B<DB_LOCK_DEFAULT> + +B<DB_LOCK_OLDEST> + +B<DB_LOCK_RANDOM> + +B<DB_LOCK_YOUNGEST> + +=item -Verbose + +Add extra debugging information to the messages sent to B<-ErrFile>. + +=back + +=head2 Methods + +The environment class has the following methods: + +=over 5 + +=item $env->errPrefix("string") ; + +This method is identical to the B<-ErrPrefix> flag. It allows the +error prefix string to be changed dynamically. + +=item $env->set_flags(bitmask, 1|0); + +=item $txn = $env->TxnMgr() + +Constructor for creating a B<TxnMgr> object. +See L<"TRANSACTIONS"> for more details of using transactions. + +This method is deprecated. Access the transaction methods using the B<txn_> +methods below from the environment object directly. + +=item $env->txn_begin() + +TODO + +=item $env->txn_stat() + +TODO + +=item $env->txn_checkpoint() + +TODO + +=item $env->status() + +Returns the status of the last BerkeleyDB::Env method. + +=item $env->setmutexlocks() + +Only available in Berkeley Db 3.0 or greater. Calls +B<db_env_set_mutexlocks> when used with Berkeley DB 3.1.x. When used with +Berkeley DB 3.0 or 3.2 and better it calls B<DBENV-E<gt>set_mutexlocks>. + +=back + +=head2 Examples + +TODO. + +=head1 Global Classes + + $status = BerkeleyDB::db_remove [OPTIONS] + $status = BerkeleyDB::db_rename [OPTIONS] + $status = BerkeleyDB::db_verify [OPTIONS] + +=head1 THE DATABASE CLASSES + +B<BerkeleyDB> supports the following database formats: + +=over 5 + +=item B<BerkeleyDB::Hash> + +This database type allows arbitrary key/value pairs to be stored in data +files. This is equivalent to the functionality provided by other +hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, +the files created using B<BerkeleyDB::Hash> are not compatible with any +of the other packages mentioned. + +A default hashing algorithm, which will be adequate for most applications, +is built into BerkeleyDB. If you do need to use your own hashing algorithm +it is possible to write your own in Perl and have B<BerkeleyDB> use +it instead. + +=item B<BerkeleyDB::Btree> + +The Btree format allows arbitrary key/value pairs to be stored in a +B+tree. + +As with the B<BerkeleyDB::Hash> format, it is possible to provide a +user defined Perl routine to perform the comparison of keys. By default, +though, the keys are stored in lexical order. + +=item B<BerkeleyDB::Recno> + +TODO. + + +=item B<BerkeleyDB::Queue> + +TODO. + +=item B<BerkeleyDB::Unknown> + +This isn't a database format at all. It is used when you want to open an +existing Berkeley DB database without having to know what type is it. + +=back + + +Each of the database formats described above is accessed via a +corresponding B<BerkeleyDB> class. These will be described in turn in +the next sections. + +=head1 BerkeleyDB::Hash + +Equivalent to calling B<db_open> with type B<DB_HASH> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_HASH> in +Berkeley DB 3.x or greater. + +Two forms of constructor are supported: + + $db = new BerkeleyDB::Hash + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Hash specific + [ -Ffactor => number,] + [ -Nelem => number,] + [ -Hash => code reference,] + [ -DupCompare => code reference,] + +and this + + [$db =] tie %hash, 'BerkeleyDB::Hash', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Hash specific + [ -Ffactor => number,] + [ -Nelem => number,] + [ -Hash => code reference,] + [ -DupCompare => code reference,] + + +When the "tie" interface is used, reading from and writing to the database +is achieved via the tied hash. In this case the database operates like +a Perl associative array that happens to be stored on disk. + +In addition to the high-level tied hash interface, it is possible to +make use of the underlying methods provided by Berkeley DB + +=head2 Options + +In addition to the standard set of options (see L<COMMON OPTIONS>) +B<BerkeleyDB::Hash> supports these options: + +=over 5 + +=item -Property + +Used to specify extra flags when opening a database. The following +flags may be specified by logically OR'ing together one or more of the +following values: + +B<DB_DUP> + +When creating a new database, this flag enables the storing of duplicate +keys in the database. If B<DB_DUPSORT> is not specified as well, the +duplicates are stored in the order they are created in the database. + +B<DB_DUPSORT> + +Enables the sorting of duplicate keys in the database. Ignored if +B<DB_DUP> isn't also specified. + +=item -Ffactor + +=item -Nelem + +See the Berkeley DB documentation for details of these options. + +=item -Hash + +Allows you to provide a user defined hash function. If not specified, +a default hash function is used. Here is a template for a user-defined +hash function + + sub hash + { + my ($data) = shift ; + ... + # return the hash value for $data + return $hash ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Hash => \&hash, + ... + +See L<""> for an example. + +=item -DupCompare + +Used in conjunction with the B<DB_DUPOSRT> flag. + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Property => DB_DUP|DB_DUPSORT, + -DupCompare => \&compare, + ... + +=back + + +=head2 Methods + +B<BerkeleyDB::Hash> only supports the standard database methods. +See L<COMMON DATABASE METHODS>. + +=head2 A Simple Tied Hash Example + + use strict ; + use BerkeleyDB ; + use vars qw( %h $k $v ) ; + + my $filename = "fruit" ; + unlink $filename ; + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved from a Hash database are in an apparently random order. + +=head2 Another Simple Hash Example + +Do the same as the previous example but not using tie. + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("apple", "red") ; + $db->db_put("orange", "orange") ; + $db->db_put("banana", "yellow") ; + $db->db_put("tomato", "red") ; + + # Check for existence of a key + print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0; + + # Delete a key/value pair. + $db->db_del("apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + +=head2 Duplicate keys + +The code below is a variation on the examples above. This time the hash has +been inverted. The key this time is colour and the value is the fruit name. +The B<DB_DUP> flag has been specified to allow duplicates. + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + +here is the output: + + orange -> orange + yellow -> banana + red -> apple + red -> tomato + green -> banana + green -> apple + +=head2 Sorting Duplicate Keys + +In the previous example, when there were duplicate keys, the values are +sorted in the order they are stored in. The code below is +identical to the previous example except the B<DB_DUPSORT> flag is +specified. + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP | DB_DUPSORT + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + +Notice that in the output below the duplicate values are sorted. + + orange -> orange + yellow -> banana + red -> apple + red -> tomato + green -> apple + green -> banana + +=head2 Custom Sorting Duplicate Keys + +Another variation + +TODO + +=head2 Changing the hash + +TODO + +=head2 Using db_stat + +TODO + +=head1 BerkeleyDB::Btree + +Equivalent to calling B<db_open> with type B<DB_BTREE> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_BTREE> in +Berkeley DB 3.x or greater. + +Two forms of constructor are supported: + + + $db = new BerkeleyDB::Btree + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Btree specific + [ -Minkey => number,] + [ -Compare => code reference,] + [ -DupCompare => code reference,] + [ -Prefix => code reference,] + +and this + + [$db =] tie %hash, 'BerkeleyDB::Btree', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Btree specific + [ -Minkey => number,] + [ -Compare => code reference,] + [ -DupCompare => code reference,] + [ -Prefix => code reference,] + +=head2 Options + +In addition to the standard set of options (see L<COMMON OPTIONS>) +B<BerkeleyDB::Btree> supports these options: + +=over 5 + +=item -Property + +Used to specify extra flags when opening a database. The following +flags may be specified by logically OR'ing together one or more of the +following values: + +B<DB_DUP> + +When creating a new database, this flag enables the storing of duplicate +keys in the database. If B<DB_DUPSORT> is not specified as well, the +duplicates are stored in the order they are created in the database. + +B<DB_DUPSORT> + +Enables the sorting of duplicate keys in the database. Ignored if +B<DB_DUP> isn't also specified. + +=item Minkey + +TODO + +=item Compare + +Allow you to override the default sort order used in the database. See +L<"Changing the sort order"> for an example. + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Compare => \&compare, + ... + +=item Prefix + + sub prefix + { + my ($key, $key2) = @_ ; + ... + # return number of bytes of $key2 which are + # necessary to determine that it is greater than $key1 + return $bytes ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Prefix => \&prefix, + ... +=item DupCompare + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -DupCompare => \&compare, + ... + +=back + +=head2 Methods + +B<BerkeleyDB::Btree> supports the following database methods. +See also L<COMMON DATABASE METHODS>. + +All the methods below return 0 to indicate success. + +=over 5 + +=item $status = $db->db_key_range($key, $less, $equal, $greater [, $flags]) + +Given a key, C<$key>, this method returns the proportion of keys less than +C<$key> in C<$less>, the proportion equal to C<$key> in C<$equal> and the +proportion greater than C<$key> in C<$greater>. + +The proportion is returned as a double in the range 0.0 to 1.0. + +=back + +=head2 A Simple Btree Example + +The code below is a simple example of using a btree database. + + use strict ; + use BerkeleyDB ; + + my $filename = "tree" ; + unlink $filename ; + my %h ; + tie %h, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. The keys have been sorted using +Berkeley DB's default sorting algorithm. + + Smith + Wall + mouse + + +=head2 Changing the sort order + +It is possible to supply your own sorting algorithm if the one that Berkeley +DB used isn't suitable. The code below is identical to the previous example +except for the case insensitive compare function. + + use strict ; + use BerkeleyDB ; + + my $filename = "tree" ; + unlink $filename ; + my %h ; + tie %h, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE, + -Compare => sub { lc $_[0] cmp lc $_[1] } + or die "Cannot open $filename: $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +You cannot change the ordering once the database has been created. Thus +you must use the same compare function every time you access the +database. + +=back + +=head2 Using db_stat + +TODO + +=head1 BerkeleyDB::Recno + +Equivalent to calling B<db_open> with type B<DB_RECNO> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_RECNO> in +Berkeley DB 3.x or greater. + +Two forms of constructor are supported: + + $db = new BerkeleyDB::Recno + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Recno specific + [ -Delim => byte,] + [ -Len => number,] + [ -Pad => byte,] + [ -Source => filename,] + +and this + + [$db =] tie @arry, 'BerkeleyDB::Recno', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Recno specific + [ -Delim => byte,] + [ -Len => number,] + [ -Pad => byte,] + [ -Source => filename,] + +=head2 A Recno Example + +Here is a simple example that uses RECNO (if you are using a version +of Perl earlier than 5.004_57 this example won't work -- see +L<Extra RECNO Methods> for a workaround). + + use strict ; + use BerkeleyDB ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + tie @h, 'BerkeleyDB::Recno', + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_RENUMBER + or die "Cannot open $filename: $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + push @h, "green", "black" ; + + my $elements = scalar @h ; + print "The array contains $elements entries\n" ; + + my $last = pop @h ; + print "popped $last\n" ; + + unshift @h, "white" ; + my $first = shift @h ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + untie @h ; + +Here is the output from the script: + + The array contains 5 entries + popped black + shifted white + Element 1 Exists with value blue + The last element is green + The 2nd last element is yellow + +=head1 BerkeleyDB::Queue + +Equivalent to calling B<db_create> followed by B<DB-E<gt>open> with +type B<DB_QUEUE> in Berkeley DB 3.x or greater. This database format +isn't available if you use Berkeley DB 2.x. + +Two forms of constructor are supported: + + $db = new BerkeleyDB::Queue + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Queue specific + [ -Len => number,] + [ -Pad => byte,] + [ -ExtentSize => number, ] + +and this + + [$db =] tie @arry, 'BerkeleyDB::Queue', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Queue specific + [ -Len => number,] + [ -Pad => byte,] + + +=head1 BerkeleyDB::Unknown + +This class is used to open an existing database. + +Equivalent to calling B<db_open> with type B<DB_UNKNOWN> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_UNKNOWN> in +Berkeley DB 3.x or greater. + +The constructor looks like this: + + $db = new BerkeleyDB::Unknown + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + + +=head2 An example + +=head1 COMMON OPTIONS + +All database access class constructors support the common set of +options defined below. All are optional. + +=over 5 + +=item -Filename + +The database filename. If no filename is specified, a temporary file will +be created and removed once the program terminates. + +=item -Subname + +Specifies the name of the sub-database to open. +This option is only valid if you are using Berkeley DB 3.x or greater. + +=item -Flags + +Specify how the database will be opened/created. The valid flags are: + +B<DB_CREATE> + +Create any underlying files, as necessary. If the files do not already +exist and the B<DB_CREATE> flag is not specified, the call will fail. + +B<DB_NOMMAP> + +Not supported by BerkeleyDB. + +B<DB_RDONLY> + +Opens the database in read-only mode. + +B<DB_THREAD> + +Not supported by BerkeleyDB. + +B<DB_TRUNCATE> + +If the database file already exists, remove all the data before +opening it. + +=item -Mode + +Determines the file protection when the database is created. Defaults +to 0666. + +=item -Cachesize + +=item -Lorder + +=item -Pagesize + +=item -Env + +When working under a Berkeley DB environment, this parameter + +Defaults to no environment. + +=item -Txn + +TODO. + +=back + +=head1 COMMON DATABASE METHODS + +All the database interfaces support the common set of methods defined +below. + +All the methods below return 0 to indicate success. + +=head2 $status = $db->db_get($key, $value [, $flags]) + +Given a key (C<$key>) this method reads the value associated with it +from the database. If it exists, the value read from the database is +returned in the C<$value> parameter. + +The B<$flags> parameter is optional. If present, it must be set to B<one> +of the following values: + +=over 5 + +=item B<DB_GET_BOTH> + +When the B<DB_GET_BOTH> flag is specified, B<db_get> checks for the +existence of B<both> the C<$key> B<and> C<$value> in the database. + +=item B<DB_SET_RECNO> + +TODO. + +=back + +In addition, the following value may be set by logically OR'ing it into +the B<$flags> parameter: + +=over 5 + +=item B<DB_RMW> + +TODO + +=back + + +=head2 $status = $db->db_put($key, $value [, $flags]) + +Stores a key/value pair in the database. + +The B<$flags> parameter is optional. If present it must be set to B<one> +of the following values: + +=over 5 + +=item B<DB_APPEND> + +This flag is only applicable when accessing a B<BerkeleyDB::Recno> +database. + +TODO. + + +=item B<DB_NOOVERWRITE> + +If this flag is specified and C<$key> already exists in the database, +the call to B<db_put> will return B<DB_KEYEXIST>. + +=back + +=head2 $status = $db->db_del($key [, $flags]) + +Deletes a key/value pair in the database associated with C<$key>. +If duplicate keys are enabled in the database, B<db_del> will delete +B<all> key/value pairs with key C<$key>. + +The B<$flags> parameter is optional and is currently unused. + +=head2 $status = $db->db_sync() + +If any parts of the database are in memory, write them to the database. + +=head2 $cursor = $db->db_cursor([$flags]) + +Creates a cursor object. This is used to access the contents of the +database sequentially. See L<CURSORS> for details of the methods +available when working with cursors. + +The B<$flags> parameter is optional. If present it must be set to B<one> +of the following values: + +=over 5 + +=item B<DB_RMW> + +TODO. + +=back + +=head2 ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ; + +TODO + +=head2 ($flag, $old_offset, $old_length) = $db->partial_clear() ; + +TODO + +=head2 $db->byteswapped() + +TODO + +=head2 $db->type() + +Returns the type of the database. The possible return code are B<DB_HASH> +for a B<BerkeleyDB::Hash> database, B<DB_BTREE> for a B<BerkeleyDB::Btree> +database and B<DB_RECNO> for a B<BerkeleyDB::Recno> database. This method +is typically used when a database has been opened with +B<BerkeleyDB::Unknown>. + +=item $ref = $db->db_stat() + +Returns a reference to an associative array containing information about +the database. The keys of the associative array correspond directly to the +names of the fields defined in the Berkeley DB documentation. For example, +in the DB documentation, the field B<bt_version> stores the version of the +Btree database. Assuming you called B<db_stat> on a Btree database the +equivalent field would be accessed as follows: + + $version = $ref->{'bt_version'} ; + +If you are using Berkeley DB 3.x or better, this method will work will +all database formats. When DB 2.x is used, it only works with +B<BerkeleyDB::Btree>. + +=head2 $status = $db->status() + +Returns the status of the last C<$db> method called. + +=head2 $status = $db->truncate($count) + +Truncates the datatabase and returns the number or records deleted +in C<$count>. + +=head1 CURSORS + +A cursor is used whenever you want to access the contents of a database +in sequential order. +A cursor object is created with the C<db_cursor> + +A cursor object has the following methods available: + +=head2 $newcursor = $cursor->c_dup($flags) + +Creates a duplicate of C<$cursor>. This method needs Berkeley DB 3.0.x or better. + +The C<$flags> parameter is optional and can take the following value: + +=over 5 + +=item DB_POSITION + +When present this flag will position the new cursor at the same place as the +existing cursor. + +=back + +=head2 $status = $cursor->c_get($key, $value, $flags) + +Reads a key/value pair from the database, returning the data in C<$key> +and C<$value>. The key/value pair actually read is controlled by the +C<$flags> parameter, which can take B<one> of the following values: + +=over 5 + +=item B<DB_FIRST> + +Set the cursor to point to the first key/value pair in the +database. Return the key/value pair in C<$key> and C<$value>. + +=item B<DB_LAST> + +Set the cursor to point to the last key/value pair in the database. Return +the key/value pair in C<$key> and C<$value>. + +=item B<DB_NEXT> + +If the cursor is already pointing to a key/value pair, it will be +incremented to point to the next key/value pair and return its contents. + +If the cursor isn't initialised, B<DB_NEXT> works just like B<DB_FIRST>. + +If the cursor is already positioned at the last key/value pair, B<c_get> +will return B<DB_NOTFOUND>. + +=item B<DB_NEXT_DUP> + +This flag is only valid when duplicate keys have been enabled in +a database. +If the cursor is already pointing to a key/value pair and the key of +the next key/value pair is identical, the cursor will be incremented to +point to it and their contents returned. + +=item B<DB_PREV> + +If the cursor is already pointing to a key/value pair, it will be +decremented to point to the previous key/value pair and return its +contents. + +If the cursor isn't initialised, B<DB_PREV> works just like B<DB_LAST>. + +If the cursor is already positioned at the first key/value pair, B<c_get> +will return B<DB_NOTFOUND>. + +=item B<DB_CURRENT> + +If the cursor has been set to point to a key/value pair, return their +contents. +If the key/value pair referenced by the cursor has been deleted, B<c_get> +will return B<DB_KEYEMPTY>. + +=item B<DB_SET> + +Set the cursor to point to the key/value pair referenced by B<$key> +and return the value in B<$value>. + +=item B<DB_SET_RANGE> + +This flag is a variation on the B<DB_SET> flag. As well as returning +the value, it also returns the key, via B<$key>. +When used with a B<BerkeleyDB::Btree> database the key matched by B<c_get> +will be the shortest key (in length) which is greater than or equal to +the key supplied, via B<$key>. This allows partial key searches. +See ??? for an example of how to use this flag. + +=item B<DB_GET_BOTH> + +Another variation on B<DB_SET>. This one returns both the key and +the value. + +=item B<DB_SET_RECNO> + +TODO. + +=item B<DB_GET_RECNO> + +TODO. + +=back + +In addition, the following value may be set by logically OR'ing it into +the B<$flags> parameter: + +=over 5 + +=item B<DB_RMW> + +TODO. + +=back + +=head2 $status = $cursor->c_put($key, $value, $flags) + +Stores the key/value pair in the database. The position that the data is +stored in the database is controlled by the C<$flags> parameter, which +must take B<one> of the following values: + +=over 5 + +=item B<DB_AFTER> + +When used with a Btree or Hash database, a duplicate of the key referenced +by the current cursor position will be created and the contents of +B<$value> will be associated with it - B<$key> is ignored. +The new key/value pair will be stored immediately after the current +cursor position. +Obviously the database has to have been opened with B<DB_DUP>. + +When used with a Recno ... TODO + + +=item B<DB_BEFORE> + +When used with a Btree or Hash database, a duplicate of the key referenced +by the current cursor position will be created and the contents of +B<$value> will be associated with it - B<$key> is ignored. +The new key/value pair will be stored immediately before the current +cursor position. +Obviously the database has to have been opened with B<DB_DUP>. + +When used with a Recno ... TODO + +=item B<DB_CURRENT> + +If the cursor has been initialised, replace the value of the key/value +pair stored in the database with the contents of B<$value>. + +=item B<DB_KEYFIRST> + +Only valid with a Btree or Hash database. This flag is only really +used when duplicates are enabled in the database and sorted duplicates +haven't been specified. +In this case the key/value pair will be inserted as the first entry in +the duplicates for the particular key. + +=item B<DB_KEYLAST> + +Only valid with a Btree or Hash database. This flag is only really +used when duplicates are enabled in the database and sorted duplicates +haven't been specified. +In this case the key/value pair will be inserted as the last entry in +the duplicates for the particular key. + +=back + +=head2 $status = $cursor->c_del([$flags]) + +This method deletes the key/value pair associated with the current cursor +position. The cursor position will not be changed by this operation, so +any subsequent cursor operation must first initialise the cursor to +point to a valid key/value pair. + +If the key/value pair associated with the cursor have already been +deleted, B<c_del> will return B<DB_KEYEMPTY>. + +The B<$flags> parameter is not used at present. + +=head2 $status = $cursor->c_del($cnt [, $flags]) + +Stores the number of duplicates at the current cursor position in B<$cnt>. + +The B<$flags> parameter is not used at present. This method needs +Berkeley DB 3.1 or better. + +=head2 $status = $cursor->status() + +Returns the status of the last cursor method as a dual type. + +=head2 Cursor Examples + +TODO + +Iterating from first to last, then in reverse. + +examples of each of the flags. + +=head1 JOIN + +Join support for BerkeleyDB is in progress. Watch this space. + +TODO + +=head1 TRANSACTIONS + +TODO. + +=head1 DBM Filters + +A DBM Filter is a piece of code that is be used when you I<always> +want to make the same transformation to all keys and/or values in a DBM +database. All of the database classes (BerkeleyDB::Hash, +BerkeleyDB::Btree and BerkeleyDB::Recno) support DBM Filters. + +There are four methods associated with DBM Filters. All work +identically, and each is used to install (or uninstall) a single DBM +Filter. Each expects a single parameter, namely a reference to a sub. +The only difference between them is the place that the filter is +installed. + +To summarise: + +=over 5 + +=item B<filter_store_key> + +If a filter has been installed with this method, it will be invoked +every time you write a key to a DBM database. + +=item B<filter_store_value> + +If a filter has been installed with this method, it will be invoked +every time you write a value to a DBM database. + + +=item B<filter_fetch_key> + +If a filter has been installed with this method, it will be invoked +every time you read a key from a DBM database. + +=item B<filter_fetch_value> + +If a filter has been installed with this method, it will be invoked +every time you read a value from a DBM database. + +=back + +You can use any combination of the methods, from none, to all four. + +All filter methods return the existing filter, if present, or C<undef> +in not. + +To delete a filter pass C<undef> to it. + +=head2 The Filter + +When each filter is called by Perl, a local copy of C<$_> will contain +the key or value to be filtered. Filtering is achieved by modifying +the contents of C<$_>. The return code from the filter is ignored. + +=head2 An Example -- the NULL termination problem. + +Consider the following scenario. You have a DBM database that you need +to share with a third-party C application. The C application assumes +that I<all> keys and values are NULL terminated. Unfortunately when +Perl writes to DBM databases it doesn't use NULL termination, so your +Perl application will have to manage NULL termination itself. When you +write to the database you will have to use something like this: + + $hash{"$key\0"} = "$value\0" ; + +Similarly the NULL needs to be taken into account when you are considering +the length of existing keys/values. + +It would be much better if you could ignore the NULL terminations issue +in the main application code and have a mechanism that automatically +added the terminating NULL to all keys and values whenever you write to +the database and have them removed when you read from the database. As I'm +sure you have already guessed, this is a problem that DBM Filters can +fix very easily. + + use strict ; + use BerkeleyDB ; + + my %hash ; + my $filename = "filt.db" ; + unlink $filename ; + + my $db = tie %hash, 'BerkeleyDB::Hash', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; + +Hopefully the contents of each of the filters should be +self-explanatory. Both "fetch" filters remove the terminating NULL, +and both "store" filters add a terminating NULL. + + +=head2 Another Example -- Key is a C int. + +Here is another real-life example. By default, whenever Perl writes to +a DBM database it always writes the key and value as strings. So when +you use this: + + $hash{12345} = "something" ; + +the key 12345 will get stored in the DBM database as the 5 byte string +"12345". If you actually want the key to be stored in the DBM database +as a C int, you will have to use C<pack> when writing, and C<unpack> +when reading. + +Here is a DBM Filter that does it: + + use strict ; + use BerkeleyDB ; + my %hash ; + my $filename = "filt.db" ; + unlink $filename ; + + + my $db = tie %hash, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; + +This time only two filters have been used -- we only need to manipulate +the contents of the key, so it wasn't necessary to install any value +filters. + +=head1 Using BerkeleyDB with MLDBM + +Both BerkeleyDB::Hash and BerkeleyDB::Btree can be used with the MLDBM +module. The code fragment below shows how to open associate MLDBM with +BerkeleyDB::Btree. To use BerkeleyDB::Hash just replace +BerkeleyDB::Btree with BerkeleyDB::Hash. + + use strict ; + use BerkeleyDB ; + use MLDBM qw(BerkeleyDB::Btree) ; + use Data::Dumper; + + my $filename = 'testmldbm' ; + my %o ; + + unlink $filename ; + tie %o, 'MLDBM', -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open database '$filename: $!\n"; + +See the MLDBM documentation for information on how to use the module +and for details of its limitations. + +=head1 EXAMPLES + +TODO. + +=head1 HINTS & TIPS + +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings +are not. See L<An Example -- the NULL termination problem.> in the DBM +FILTERS section for a generic way to work around this problem. + + +=head2 The untie Gotcha + +TODO + +=head1 COMMON QUESTIONS + +This section attempts to answer some of the more common questions that +I get asked. + + +=head2 Relationship with DB_File + +Before Berkeley DB 2.x was written there was only one Perl module that +interfaced to Berkeley DB. That module is called B<DB_File>. Although +B<DB_File> can be build with Berkeley DB 1.x, 2.x, 3.x or 4.x, it only provides +an interface to the functionality available in Berkeley DB 1.x. That +means that it doesn't support transactions, locking or any of the other +new features available in DB 2.x or better. + +=head2 How do I store Perl data structures with BerkeleyDB? + +See L<Using BerkeleyDB with MLDBM>. + +=head1 HISTORY + +See the Changes file. + +=head1 AVAILABILITY + +The most recent version of B<BerkeleyDB> can always be found +on CPAN (see L<perlmod/CPAN> for details), in the directory +F<modules/by-module/BerkeleyDB>. + +The official web site for Berkeley DB is F<http://www.sleepycat.com>. + +=head1 COPYRIGHT + +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. + +Although B<BerkeleyDB> is covered by the Perl license, the library it +makes use of, namely Berkeley DB, is not. Berkeley DB has its own +copyright and its own license. Please take the time to read it. + +Here are few words taken from the Berkeley DB FAQ (at +F<http://www.sleepycat.com>) regarding the license: + + Do I have to license DB to use it in Perl scripts? + + No. The Berkeley DB license requires that software that uses + Berkeley DB be freely redistributable. In the case of Perl, that + software is Perl, and not your scripts. Any Perl scripts that you + write are your property, including scripts that make use of Berkeley + DB. Neither the Perl license nor the Berkeley DB license + place any restriction on what you may do with them. + +If you are in any doubt about the license situation, contact either the +Berkeley DB authors or the author of BerkeleyDB. +See L<"AUTHOR"> for details. + + +=head1 AUTHOR + +Paul Marquess E<lt>Paul.Marquess@btinternet.comE<gt>. + +Questions about Berkeley DB may be addressed to E<lt>db@sleepycat.comE<gt>. + +=head1 SEE ALSO + +perl(1), DB_File, Berkeley DB. + +=cut diff --git a/bdb/perl/BerkeleyDB/BerkeleyDB.pod.P b/bdb/perl/BerkeleyDB/BerkeleyDB.pod.P new file mode 100644 index 00000000000..4a848f5388d --- /dev/null +++ b/bdb/perl/BerkeleyDB/BerkeleyDB.pod.P @@ -0,0 +1,1559 @@ +=head1 NAME + +BerkeleyDB - Perl extension for Berkeley DB version 2, 3 or 4 + +=head1 SYNOPSIS + + use BerkeleyDB; + + $env = new BerkeleyDB::Env [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Hash', [OPTIONS] ; + $db = new BerkeleyDB::Hash [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Btree', [OPTIONS] ; + $db = new BerkeleyDB::Btree [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Recno', [OPTIONS] ; + $db = new BerkeleyDB::Recno [OPTIONS] ; + + $db = tie %hash, 'BerkeleyDB::Queue', [OPTIONS] ; + $db = new BerkeleyDB::Queue [OPTIONS] ; + + $db = new BerkeleyDB::Unknown [OPTIONS] ; + + $status = BerkeleyDB::db_remove [OPTIONS] + $status = BerkeleyDB::db_rename [OPTIONS] + $status = BerkeleyDB::db_verify [OPTIONS] + + $hash{$key} = $value ; + $value = $hash{$key} ; + each %hash ; + keys %hash ; + values %hash ; + + $status = $db->db_get() + $status = $db->db_put() ; + $status = $db->db_del() ; + $status = $db->db_sync() ; + $status = $db->db_close() ; + $status = $db->db_close() ; + $status = $db->db_pget() + $hash_ref = $db->db_stat() ; + $status = $db->db_key_range(); + $type = $db->type() ; + $status = $db->status() ; + $boolean = $db->byteswapped() ; + $status = $db->truncate($count) ; + + ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ; + ($flag, $old_offset, $old_length) = $db->partial_clear() ; + + $cursor = $db->db_cursor([$flags]) ; + $newcursor = $cursor->c_dup([$flags]); + $status = $cursor->c_get() ; + $status = $cursor->c_put() ; + $status = $cursor->c_del() ; + $status = $cursor->c_count() ; + $status = $cursor->c_pget() ; + $status = $cursor->status() ; + $status = $cursor->c_close() ; + + $cursor = $db->db_join() ; + $status = $cursor->c_get() ; + $status = $cursor->c_close() ; + + $status = $env->txn_checkpoint() + $hash_ref = $env->txn_stat() + $status = $env->setmutexlocks() + $status = $env->set_flags() + + $txn = $env->txn_begin() ; + $db->Txn($txn); + $txn->Txn($db1, $db2,...); + $status = $txn->txn_prepare() + $status = $txn->txn_commit() + $status = $txn->txn_abort() + $status = $txn->txn_id() + $status = $txn->txn_discard() + + $status = $env->set_lg_dir(); + $status = $env->set_lg_bsize(); + $status = $env->set_lg_max(); + + $status = $env->set_data_dir() ; + $status = $env->set_tmp_dir() ; + $status = $env->set_verbose() ; + + $BerkeleyDB::Error + $BerkeleyDB::db_version + + # DBM Filters + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; + + # deprecated, but supported + $txn_mgr = $env->TxnMgr(); + $status = $txn_mgr->txn_checkpoint() + $hash_ref = $txn_mgr->txn_stat() + $txn = $txn_mgr->txn_begin() ; + +=head1 DESCRIPTION + +B<NOTE: This document is still under construction. Expect it to be +incomplete in places.> + +This Perl module provides an interface to most of the functionality +available in Berkeley DB versions 2, 3 and 4. In general it is safe to assume +that the interface provided here to be identical to the Berkeley DB +interface. The main changes have been to make the Berkeley DB API work +in a Perl way. Note that if you are using Berkeley DB 2.x, the new +features available in Berkeley DB 3.x or DB 4.x are not available via +this module. + +The reader is expected to be familiar with the Berkeley DB +documentation. Where the interface provided here is identical to the +Berkeley DB library and the... TODO + +The B<db_appinit>, B<db_cursor>, B<db_open> and B<db_txn> man pages are +particularly relevant. + +The interface to Berkeley DB is implemented with a number of Perl +classes. + +=head1 ENV CLASS + +The B<BerkeleyDB::Env> class provides an interface to the Berkeley DB +function B<db_appinit> in Berkeley DB 2.x or B<db_env_create> and +B<DBENV-E<gt>open> in Berkeley DB 3.x/4.x. Its purpose is to initialise a +number of sub-systems that can then be used in a consistent way in all +the databases you make use of the environment. + +If you don't intend using transactions, locking or logging, then you +shouldn't need to make use of B<BerkeleyDB::Env>. + +=head2 Synopsis + + $env = new BerkeleyDB::Env + [ -Home => $path, ] + [ -Server => $name, ] + [ -CacheSize => $number, ] + [ -Config => { name => value, name => value }, ] + [ -ErrFile => filename, ] + [ -ErrPrefix => "string", ] + [ -Flags => number, ] + [ -SetFlags => bitmask, ] + [ -LockDetect => number, ] + [ -Verbose => boolean, ] + +=over 5 + +All the parameters to the BerkeleyDB::Env constructor are optional. + +=item -Home + +If present, this parameter should point to an existing directory. Any +files that I<aren't> specified with an absolute path in the sub-systems +that are initialised by the BerkeleyDB::Env class will be assumed to +live in the B<Home> directory. + +For example, in the code fragment below the database "fred.db" will be +opened in the directory "/home/databases" because it was specified as a +relative path, but "joe.db" will be opened in "/other" because it was +part of an absolute path. + + $env = new BerkeleyDB::Env + -Home => "/home/databases" + ... + + $db1 = new BerkeleyDB::Hash + -Filename = "fred.db", + -Env => $env + ... + + $db2 = new BerkeleyDB::Hash + -Filename = "/other/joe.db", + -Env => $env + ... + +=item -Server + +If present, this parameter should be the hostname of a server that is running +the Berkeley DB RPC server. All databases will be accessed via the RPC server. + +=item -Cachesize + +If present, this parameter sets the size of the environments shared memory +buffer pool. + +=item -Config + +This is a variation on the C<-Home> parameter, but it allows finer +control of where specific types of files will be stored. + +The parameter expects a reference to a hash. Valid keys are: +B<DB_DATA_DIR>, B<DB_LOG_DIR> and B<DB_TMP_DIR> + +The code below shows an example of how it can be used. + + $env = new BerkeleyDB::Env + -Config => { DB_DATA_DIR => "/home/databases", + DB_LOG_DIR => "/home/logs", + DB_TMP_DIR => "/home/tmp" + } + ... + +=item -ErrFile + +Expects a filenme. Any errors generated internally by Berkeley DB will +be logged to this file. + +=item -ErrPrefix + +Allows a prefix to be added to the error messages before they are sent +to B<-ErrFile>. + +=item -Flags + +The B<Flags> parameter specifies both which sub-systems to initialise, +as well as a number of environment-wide options. +See the Berkeley DB documentation for more details of these options. + +Any of the following can be specified by OR'ing them: + +B<DB_CREATE> + +If any of the files specified do not already exist, create them. + +B<DB_INIT_CDB> + +Initialise the Concurrent Access Methods + +B<DB_INIT_LOCK> + +Initialise the Locking sub-system. + +B<DB_INIT_LOG> + +Initialise the Logging sub-system. + +B<DB_INIT_MPOOL> + +Initialise the ... + +B<DB_INIT_TXN> + +Initialise the ... + +B<DB_MPOOL_PRIVATE> + +Initialise the ... + +B<DB_INIT_MPOOL> is also specified. + +Initialise the ... + +B<DB_NOMMAP> + +Initialise the ... + +B<DB_RECOVER> + + + +B<DB_RECOVER_FATAL> + +B<DB_THREAD> + +B<DB_TXN_NOSYNC> + +B<DB_USE_ENVIRON> + +B<DB_USE_ENVIRON_ROOT> + +=item -SetFlags + +Calls ENV->set_flags with the supplied bitmask. Use this when you need to make +use of DB_ENV->set_flags before DB_ENV->open is called. + +Only valid when Berkeley DB 3.x or better is used. + +=item -LockDetect + +Specifies what to do when a lock conflict occurs. The value should be one of + +B<DB_LOCK_DEFAULT> + +B<DB_LOCK_OLDEST> + +B<DB_LOCK_RANDOM> + +B<DB_LOCK_YOUNGEST> + +=item -Verbose + +Add extra debugging information to the messages sent to B<-ErrFile>. + +=back + +=head2 Methods + +The environment class has the following methods: + +=over 5 + +=item $env->errPrefix("string") ; + +This method is identical to the B<-ErrPrefix> flag. It allows the +error prefix string to be changed dynamically. + +=item $env->set_flags(bitmask, 1|0); + +=item $txn = $env->TxnMgr() + +Constructor for creating a B<TxnMgr> object. +See L<"TRANSACTIONS"> for more details of using transactions. + +This method is deprecated. Access the transaction methods using the B<txn_> +methods below from the environment object directly. + +=item $env->txn_begin() + +TODO + +=item $env->txn_stat() + +TODO + +=item $env->txn_checkpoint() + +TODO + +=item $env->status() + +Returns the status of the last BerkeleyDB::Env method. + +=item $env->setmutexlocks() + +Only available in Berkeley Db 3.0 or greater. Calls +B<db_env_set_mutexlocks> when used with Berkeley DB 3.1.x. When used with +Berkeley DB 3.0 or 3.2 and better it calls B<DBENV-E<gt>set_mutexlocks>. + +=back + +=head2 Examples + +TODO. + +=head1 Global Classes + + $status = BerkeleyDB::db_remove [OPTIONS] + $status = BerkeleyDB::db_rename [OPTIONS] + $status = BerkeleyDB::db_verify [OPTIONS] + +=head1 THE DATABASE CLASSES + +B<BerkeleyDB> supports the following database formats: + +=over 5 + +=item B<BerkeleyDB::Hash> + +This database type allows arbitrary key/value pairs to be stored in data +files. This is equivalent to the functionality provided by other +hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, +the files created using B<BerkeleyDB::Hash> are not compatible with any +of the other packages mentioned. + +A default hashing algorithm, which will be adequate for most applications, +is built into BerkeleyDB. If you do need to use your own hashing algorithm +it is possible to write your own in Perl and have B<BerkeleyDB> use +it instead. + +=item B<BerkeleyDB::Btree> + +The Btree format allows arbitrary key/value pairs to be stored in a +B+tree. + +As with the B<BerkeleyDB::Hash> format, it is possible to provide a +user defined Perl routine to perform the comparison of keys. By default, +though, the keys are stored in lexical order. + +=item B<BerkeleyDB::Recno> + +TODO. + + +=item B<BerkeleyDB::Queue> + +TODO. + +=item B<BerkeleyDB::Unknown> + +This isn't a database format at all. It is used when you want to open an +existing Berkeley DB database without having to know what type is it. + +=back + + +Each of the database formats described above is accessed via a +corresponding B<BerkeleyDB> class. These will be described in turn in +the next sections. + +=head1 BerkeleyDB::Hash + +Equivalent to calling B<db_open> with type B<DB_HASH> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_HASH> in +Berkeley DB 3.x or greater. + +Two forms of constructor are supported: + + $db = new BerkeleyDB::Hash + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Hash specific + [ -Ffactor => number,] + [ -Nelem => number,] + [ -Hash => code reference,] + [ -DupCompare => code reference,] + +and this + + [$db =] tie %hash, 'BerkeleyDB::Hash', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Hash specific + [ -Ffactor => number,] + [ -Nelem => number,] + [ -Hash => code reference,] + [ -DupCompare => code reference,] + + +When the "tie" interface is used, reading from and writing to the database +is achieved via the tied hash. In this case the database operates like +a Perl associative array that happens to be stored on disk. + +In addition to the high-level tied hash interface, it is possible to +make use of the underlying methods provided by Berkeley DB + +=head2 Options + +In addition to the standard set of options (see L<COMMON OPTIONS>) +B<BerkeleyDB::Hash> supports these options: + +=over 5 + +=item -Property + +Used to specify extra flags when opening a database. The following +flags may be specified by logically OR'ing together one or more of the +following values: + +B<DB_DUP> + +When creating a new database, this flag enables the storing of duplicate +keys in the database. If B<DB_DUPSORT> is not specified as well, the +duplicates are stored in the order they are created in the database. + +B<DB_DUPSORT> + +Enables the sorting of duplicate keys in the database. Ignored if +B<DB_DUP> isn't also specified. + +=item -Ffactor + +=item -Nelem + +See the Berkeley DB documentation for details of these options. + +=item -Hash + +Allows you to provide a user defined hash function. If not specified, +a default hash function is used. Here is a template for a user-defined +hash function + + sub hash + { + my ($data) = shift ; + ... + # return the hash value for $data + return $hash ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Hash => \&hash, + ... + +See L<""> for an example. + +=item -DupCompare + +Used in conjunction with the B<DB_DUPOSRT> flag. + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Property => DB_DUP|DB_DUPSORT, + -DupCompare => \&compare, + ... + +=back + + +=head2 Methods + +B<BerkeleyDB::Hash> only supports the standard database methods. +See L<COMMON DATABASE METHODS>. + +=head2 A Simple Tied Hash Example + +## simpleHash + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved from a Hash database are in an apparently random order. + +=head2 Another Simple Hash Example + +Do the same as the previous example but not using tie. + +## simpleHash2 + +=head2 Duplicate keys + +The code below is a variation on the examples above. This time the hash has +been inverted. The key this time is colour and the value is the fruit name. +The B<DB_DUP> flag has been specified to allow duplicates. + +##dupHash + +here is the output: + + orange -> orange + yellow -> banana + red -> apple + red -> tomato + green -> banana + green -> apple + +=head2 Sorting Duplicate Keys + +In the previous example, when there were duplicate keys, the values are +sorted in the order they are stored in. The code below is +identical to the previous example except the B<DB_DUPSORT> flag is +specified. + +##dupSortHash + +Notice that in the output below the duplicate values are sorted. + + orange -> orange + yellow -> banana + red -> apple + red -> tomato + green -> apple + green -> banana + +=head2 Custom Sorting Duplicate Keys + +Another variation + +TODO + +=head2 Changing the hash + +TODO + +=head2 Using db_stat + +TODO + +=head1 BerkeleyDB::Btree + +Equivalent to calling B<db_open> with type B<DB_BTREE> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_BTREE> in +Berkeley DB 3.x or greater. + +Two forms of constructor are supported: + + + $db = new BerkeleyDB::Btree + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Btree specific + [ -Minkey => number,] + [ -Compare => code reference,] + [ -DupCompare => code reference,] + [ -Prefix => code reference,] + +and this + + [$db =] tie %hash, 'BerkeleyDB::Btree', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Btree specific + [ -Minkey => number,] + [ -Compare => code reference,] + [ -DupCompare => code reference,] + [ -Prefix => code reference,] + +=head2 Options + +In addition to the standard set of options (see L<COMMON OPTIONS>) +B<BerkeleyDB::Btree> supports these options: + +=over 5 + +=item -Property + +Used to specify extra flags when opening a database. The following +flags may be specified by logically OR'ing together one or more of the +following values: + +B<DB_DUP> + +When creating a new database, this flag enables the storing of duplicate +keys in the database. If B<DB_DUPSORT> is not specified as well, the +duplicates are stored in the order they are created in the database. + +B<DB_DUPSORT> + +Enables the sorting of duplicate keys in the database. Ignored if +B<DB_DUP> isn't also specified. + +=item Minkey + +TODO + +=item Compare + +Allow you to override the default sort order used in the database. See +L<"Changing the sort order"> for an example. + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Compare => \&compare, + ... + +=item Prefix + + sub prefix + { + my ($key, $key2) = @_ ; + ... + # return number of bytes of $key2 which are + # necessary to determine that it is greater than $key1 + return $bytes ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Prefix => \&prefix, + ... +=item DupCompare + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -DupCompare => \&compare, + ... + +=back + +=head2 Methods + +B<BerkeleyDB::Btree> supports the following database methods. +See also L<COMMON DATABASE METHODS>. + +All the methods below return 0 to indicate success. + +=over 5 + +=item $status = $db->db_key_range($key, $less, $equal, $greater [, $flags]) + +Given a key, C<$key>, this method returns the proportion of keys less than +C<$key> in C<$less>, the proportion equal to C<$key> in C<$equal> and the +proportion greater than C<$key> in C<$greater>. + +The proportion is returned as a double in the range 0.0 to 1.0. + +=back + +=head2 A Simple Btree Example + +The code below is a simple example of using a btree database. + +## btreeSimple + +Here is the output from the code above. The keys have been sorted using +Berkeley DB's default sorting algorithm. + + Smith + Wall + mouse + + +=head2 Changing the sort order + +It is possible to supply your own sorting algorithm if the one that Berkeley +DB used isn't suitable. The code below is identical to the previous example +except for the case insensitive compare function. + +## btreeSortOrder + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +You cannot change the ordering once the database has been created. Thus +you must use the same compare function every time you access the +database. + +=back + +=head2 Using db_stat + +TODO + +=head1 BerkeleyDB::Recno + +Equivalent to calling B<db_open> with type B<DB_RECNO> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_RECNO> in +Berkeley DB 3.x or greater. + +Two forms of constructor are supported: + + $db = new BerkeleyDB::Recno + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Recno specific + [ -Delim => byte,] + [ -Len => number,] + [ -Pad => byte,] + [ -Source => filename,] + +and this + + [$db =] tie @arry, 'BerkeleyDB::Recno', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Recno specific + [ -Delim => byte,] + [ -Len => number,] + [ -Pad => byte,] + [ -Source => filename,] + +=head2 A Recno Example + +Here is a simple example that uses RECNO (if you are using a version +of Perl earlier than 5.004_57 this example won't work -- see +L<Extra RECNO Methods> for a workaround). + +## simpleRecno + +Here is the output from the script: + + The array contains 5 entries + popped black + shifted white + Element 1 Exists with value blue + The last element is green + The 2nd last element is yellow + +=head1 BerkeleyDB::Queue + +Equivalent to calling B<db_create> followed by B<DB-E<gt>open> with +type B<DB_QUEUE> in Berkeley DB 3.x or greater. This database format +isn't available if you use Berkeley DB 2.x. + +Two forms of constructor are supported: + + $db = new BerkeleyDB::Queue + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Queue specific + [ -Len => number,] + [ -Pad => byte,] + [ -ExtentSize => number, ] + +and this + + [$db =] tie @arry, 'BerkeleyDB::Queue', + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + # BerkeleyDB::Queue specific + [ -Len => number,] + [ -Pad => byte,] + + +=head1 BerkeleyDB::Unknown + +This class is used to open an existing database. + +Equivalent to calling B<db_open> with type B<DB_UNKNOWN> in Berkeley DB 2.x and +calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_UNKNOWN> in +Berkeley DB 3.x or greater. + +The constructor looks like this: + + $db = new BerkeleyDB::Unknown + [ -Filename => "filename", ] + [ -Subname => "sub-database name", ] + [ -Flags => flags,] + [ -Property => flags,] + [ -Mode => number,] + [ -Cachesize => number,] + [ -Lorder => number,] + [ -Pagesize => number,] + [ -Env => $env,] + [ -Txn => $txn,] + + +=head2 An example + +=head1 COMMON OPTIONS + +All database access class constructors support the common set of +options defined below. All are optional. + +=over 5 + +=item -Filename + +The database filename. If no filename is specified, a temporary file will +be created and removed once the program terminates. + +=item -Subname + +Specifies the name of the sub-database to open. +This option is only valid if you are using Berkeley DB 3.x or greater. + +=item -Flags + +Specify how the database will be opened/created. The valid flags are: + +B<DB_CREATE> + +Create any underlying files, as necessary. If the files do not already +exist and the B<DB_CREATE> flag is not specified, the call will fail. + +B<DB_NOMMAP> + +Not supported by BerkeleyDB. + +B<DB_RDONLY> + +Opens the database in read-only mode. + +B<DB_THREAD> + +Not supported by BerkeleyDB. + +B<DB_TRUNCATE> + +If the database file already exists, remove all the data before +opening it. + +=item -Mode + +Determines the file protection when the database is created. Defaults +to 0666. + +=item -Cachesize + +=item -Lorder + +=item -Pagesize + +=item -Env + +When working under a Berkeley DB environment, this parameter + +Defaults to no environment. + +=item -Txn + +TODO. + +=back + +=head1 COMMON DATABASE METHODS + +All the database interfaces support the common set of methods defined +below. + +All the methods below return 0 to indicate success. + +=head2 $status = $db->db_get($key, $value [, $flags]) + +Given a key (C<$key>) this method reads the value associated with it +from the database. If it exists, the value read from the database is +returned in the C<$value> parameter. + +The B<$flags> parameter is optional. If present, it must be set to B<one> +of the following values: + +=over 5 + +=item B<DB_GET_BOTH> + +When the B<DB_GET_BOTH> flag is specified, B<db_get> checks for the +existence of B<both> the C<$key> B<and> C<$value> in the database. + +=item B<DB_SET_RECNO> + +TODO. + +=back + +In addition, the following value may be set by logically OR'ing it into +the B<$flags> parameter: + +=over 5 + +=item B<DB_RMW> + +TODO + +=back + + +=head2 $status = $db->db_put($key, $value [, $flags]) + +Stores a key/value pair in the database. + +The B<$flags> parameter is optional. If present it must be set to B<one> +of the following values: + +=over 5 + +=item B<DB_APPEND> + +This flag is only applicable when accessing a B<BerkeleyDB::Recno> +database. + +TODO. + + +=item B<DB_NOOVERWRITE> + +If this flag is specified and C<$key> already exists in the database, +the call to B<db_put> will return B<DB_KEYEXIST>. + +=back + +=head2 $status = $db->db_del($key [, $flags]) + +Deletes a key/value pair in the database associated with C<$key>. +If duplicate keys are enabled in the database, B<db_del> will delete +B<all> key/value pairs with key C<$key>. + +The B<$flags> parameter is optional and is currently unused. + +=head2 $status = $db->db_sync() + +If any parts of the database are in memory, write them to the database. + +=head2 $cursor = $db->db_cursor([$flags]) + +Creates a cursor object. This is used to access the contents of the +database sequentially. See L<CURSORS> for details of the methods +available when working with cursors. + +The B<$flags> parameter is optional. If present it must be set to B<one> +of the following values: + +=over 5 + +=item B<DB_RMW> + +TODO. + +=back + +=head2 ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ; + +TODO + +=head2 ($flag, $old_offset, $old_length) = $db->partial_clear() ; + +TODO + +=head2 $db->byteswapped() + +TODO + +=head2 $db->type() + +Returns the type of the database. The possible return code are B<DB_HASH> +for a B<BerkeleyDB::Hash> database, B<DB_BTREE> for a B<BerkeleyDB::Btree> +database and B<DB_RECNO> for a B<BerkeleyDB::Recno> database. This method +is typically used when a database has been opened with +B<BerkeleyDB::Unknown>. + +=item $ref = $db->db_stat() + +Returns a reference to an associative array containing information about +the database. The keys of the associative array correspond directly to the +names of the fields defined in the Berkeley DB documentation. For example, +in the DB documentation, the field B<bt_version> stores the version of the +Btree database. Assuming you called B<db_stat> on a Btree database the +equivalent field would be accessed as follows: + + $version = $ref->{'bt_version'} ; + +If you are using Berkeley DB 3.x or better, this method will work will +all database formats. When DB 2.x is used, it only works with +B<BerkeleyDB::Btree>. + +=head2 $status = $db->status() + +Returns the status of the last C<$db> method called. + +=head2 $status = $db->truncate($count) + +Truncates the datatabase and returns the number or records deleted +in C<$count>. + +=head1 CURSORS + +A cursor is used whenever you want to access the contents of a database +in sequential order. +A cursor object is created with the C<db_cursor> + +A cursor object has the following methods available: + +=head2 $newcursor = $cursor->c_dup($flags) + +Creates a duplicate of C<$cursor>. This method needs Berkeley DB 3.0.x or better. + +The C<$flags> parameter is optional and can take the following value: + +=over 5 + +=item DB_POSITION + +When present this flag will position the new cursor at the same place as the +existing cursor. + +=back + +=head2 $status = $cursor->c_get($key, $value, $flags) + +Reads a key/value pair from the database, returning the data in C<$key> +and C<$value>. The key/value pair actually read is controlled by the +C<$flags> parameter, which can take B<one> of the following values: + +=over 5 + +=item B<DB_FIRST> + +Set the cursor to point to the first key/value pair in the +database. Return the key/value pair in C<$key> and C<$value>. + +=item B<DB_LAST> + +Set the cursor to point to the last key/value pair in the database. Return +the key/value pair in C<$key> and C<$value>. + +=item B<DB_NEXT> + +If the cursor is already pointing to a key/value pair, it will be +incremented to point to the next key/value pair and return its contents. + +If the cursor isn't initialised, B<DB_NEXT> works just like B<DB_FIRST>. + +If the cursor is already positioned at the last key/value pair, B<c_get> +will return B<DB_NOTFOUND>. + +=item B<DB_NEXT_DUP> + +This flag is only valid when duplicate keys have been enabled in +a database. +If the cursor is already pointing to a key/value pair and the key of +the next key/value pair is identical, the cursor will be incremented to +point to it and their contents returned. + +=item B<DB_PREV> + +If the cursor is already pointing to a key/value pair, it will be +decremented to point to the previous key/value pair and return its +contents. + +If the cursor isn't initialised, B<DB_PREV> works just like B<DB_LAST>. + +If the cursor is already positioned at the first key/value pair, B<c_get> +will return B<DB_NOTFOUND>. + +=item B<DB_CURRENT> + +If the cursor has been set to point to a key/value pair, return their +contents. +If the key/value pair referenced by the cursor has been deleted, B<c_get> +will return B<DB_KEYEMPTY>. + +=item B<DB_SET> + +Set the cursor to point to the key/value pair referenced by B<$key> +and return the value in B<$value>. + +=item B<DB_SET_RANGE> + +This flag is a variation on the B<DB_SET> flag. As well as returning +the value, it also returns the key, via B<$key>. +When used with a B<BerkeleyDB::Btree> database the key matched by B<c_get> +will be the shortest key (in length) which is greater than or equal to +the key supplied, via B<$key>. This allows partial key searches. +See ??? for an example of how to use this flag. + +=item B<DB_GET_BOTH> + +Another variation on B<DB_SET>. This one returns both the key and +the value. + +=item B<DB_SET_RECNO> + +TODO. + +=item B<DB_GET_RECNO> + +TODO. + +=back + +In addition, the following value may be set by logically OR'ing it into +the B<$flags> parameter: + +=over 5 + +=item B<DB_RMW> + +TODO. + +=back + +=head2 $status = $cursor->c_put($key, $value, $flags) + +Stores the key/value pair in the database. The position that the data is +stored in the database is controlled by the C<$flags> parameter, which +must take B<one> of the following values: + +=over 5 + +=item B<DB_AFTER> + +When used with a Btree or Hash database, a duplicate of the key referenced +by the current cursor position will be created and the contents of +B<$value> will be associated with it - B<$key> is ignored. +The new key/value pair will be stored immediately after the current +cursor position. +Obviously the database has to have been opened with B<DB_DUP>. + +When used with a Recno ... TODO + + +=item B<DB_BEFORE> + +When used with a Btree or Hash database, a duplicate of the key referenced +by the current cursor position will be created and the contents of +B<$value> will be associated with it - B<$key> is ignored. +The new key/value pair will be stored immediately before the current +cursor position. +Obviously the database has to have been opened with B<DB_DUP>. + +When used with a Recno ... TODO + +=item B<DB_CURRENT> + +If the cursor has been initialised, replace the value of the key/value +pair stored in the database with the contents of B<$value>. + +=item B<DB_KEYFIRST> + +Only valid with a Btree or Hash database. This flag is only really +used when duplicates are enabled in the database and sorted duplicates +haven't been specified. +In this case the key/value pair will be inserted as the first entry in +the duplicates for the particular key. + +=item B<DB_KEYLAST> + +Only valid with a Btree or Hash database. This flag is only really +used when duplicates are enabled in the database and sorted duplicates +haven't been specified. +In this case the key/value pair will be inserted as the last entry in +the duplicates for the particular key. + +=back + +=head2 $status = $cursor->c_del([$flags]) + +This method deletes the key/value pair associated with the current cursor +position. The cursor position will not be changed by this operation, so +any subsequent cursor operation must first initialise the cursor to +point to a valid key/value pair. + +If the key/value pair associated with the cursor have already been +deleted, B<c_del> will return B<DB_KEYEMPTY>. + +The B<$flags> parameter is not used at present. + +=head2 $status = $cursor->c_del($cnt [, $flags]) + +Stores the number of duplicates at the current cursor position in B<$cnt>. + +The B<$flags> parameter is not used at present. This method needs +Berkeley DB 3.1 or better. + +=head2 $status = $cursor->status() + +Returns the status of the last cursor method as a dual type. + +=head2 Cursor Examples + +TODO + +Iterating from first to last, then in reverse. + +examples of each of the flags. + +=head1 JOIN + +Join support for BerkeleyDB is in progress. Watch this space. + +TODO + +=head1 TRANSACTIONS + +TODO. + +=head1 DBM Filters + +A DBM Filter is a piece of code that is be used when you I<always> +want to make the same transformation to all keys and/or values in a DBM +database. All of the database classes (BerkeleyDB::Hash, +BerkeleyDB::Btree and BerkeleyDB::Recno) support DBM Filters. + +There are four methods associated with DBM Filters. All work +identically, and each is used to install (or uninstall) a single DBM +Filter. Each expects a single parameter, namely a reference to a sub. +The only difference between them is the place that the filter is +installed. + +To summarise: + +=over 5 + +=item B<filter_store_key> + +If a filter has been installed with this method, it will be invoked +every time you write a key to a DBM database. + +=item B<filter_store_value> + +If a filter has been installed with this method, it will be invoked +every time you write a value to a DBM database. + + +=item B<filter_fetch_key> + +If a filter has been installed with this method, it will be invoked +every time you read a key from a DBM database. + +=item B<filter_fetch_value> + +If a filter has been installed with this method, it will be invoked +every time you read a value from a DBM database. + +=back + +You can use any combination of the methods, from none, to all four. + +All filter methods return the existing filter, if present, or C<undef> +in not. + +To delete a filter pass C<undef> to it. + +=head2 The Filter + +When each filter is called by Perl, a local copy of C<$_> will contain +the key or value to be filtered. Filtering is achieved by modifying +the contents of C<$_>. The return code from the filter is ignored. + +=head2 An Example -- the NULL termination problem. + +Consider the following scenario. You have a DBM database that you need +to share with a third-party C application. The C application assumes +that I<all> keys and values are NULL terminated. Unfortunately when +Perl writes to DBM databases it doesn't use NULL termination, so your +Perl application will have to manage NULL termination itself. When you +write to the database you will have to use something like this: + + $hash{"$key\0"} = "$value\0" ; + +Similarly the NULL needs to be taken into account when you are considering +the length of existing keys/values. + +It would be much better if you could ignore the NULL terminations issue +in the main application code and have a mechanism that automatically +added the terminating NULL to all keys and values whenever you write to +the database and have them removed when you read from the database. As I'm +sure you have already guessed, this is a problem that DBM Filters can +fix very easily. + +## nullFilter + +Hopefully the contents of each of the filters should be +self-explanatory. Both "fetch" filters remove the terminating NULL, +and both "store" filters add a terminating NULL. + + +=head2 Another Example -- Key is a C int. + +Here is another real-life example. By default, whenever Perl writes to +a DBM database it always writes the key and value as strings. So when +you use this: + + $hash{12345} = "something" ; + +the key 12345 will get stored in the DBM database as the 5 byte string +"12345". If you actually want the key to be stored in the DBM database +as a C int, you will have to use C<pack> when writing, and C<unpack> +when reading. + +Here is a DBM Filter that does it: + +## intFilter + +This time only two filters have been used -- we only need to manipulate +the contents of the key, so it wasn't necessary to install any value +filters. + +=head1 Using BerkeleyDB with MLDBM + +Both BerkeleyDB::Hash and BerkeleyDB::Btree can be used with the MLDBM +module. The code fragment below shows how to open associate MLDBM with +BerkeleyDB::Btree. To use BerkeleyDB::Hash just replace +BerkeleyDB::Btree with BerkeleyDB::Hash. + + use strict ; + use BerkeleyDB ; + use MLDBM qw(BerkeleyDB::Btree) ; + use Data::Dumper; + + my $filename = 'testmldbm' ; + my %o ; + + unlink $filename ; + tie %o, 'MLDBM', -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open database '$filename: $!\n"; + +See the MLDBM documentation for information on how to use the module +and for details of its limitations. + +=head1 EXAMPLES + +TODO. + +=head1 HINTS & TIPS + +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings +are not. See L<An Example -- the NULL termination problem.> in the DBM +FILTERS section for a generic way to work around this problem. + + +=head2 The untie Gotcha + +TODO + +=head1 COMMON QUESTIONS + +This section attempts to answer some of the more common questions that +I get asked. + + +=head2 Relationship with DB_File + +Before Berkeley DB 2.x was written there was only one Perl module that +interfaced to Berkeley DB. That module is called B<DB_File>. Although +B<DB_File> can be build with Berkeley DB 1.x, 2.x, 3.x or 4.x, it only provides +an interface to the functionality available in Berkeley DB 1.x. That +means that it doesn't support transactions, locking or any of the other +new features available in DB 2.x or better. + +=head2 How do I store Perl data structures with BerkeleyDB? + +See L<Using BerkeleyDB with MLDBM>. + +=head1 HISTORY + +See the Changes file. + +=head1 AVAILABILITY + +The most recent version of B<BerkeleyDB> can always be found +on CPAN (see L<perlmod/CPAN> for details), in the directory +F<modules/by-module/BerkeleyDB>. + +The official web site for Berkeley DB is F<http://www.sleepycat.com>. + +=head1 COPYRIGHT + +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. + +Although B<BerkeleyDB> is covered by the Perl license, the library it +makes use of, namely Berkeley DB, is not. Berkeley DB has its own +copyright and its own license. Please take the time to read it. + +Here are few words taken from the Berkeley DB FAQ (at +F<http://www.sleepycat.com>) regarding the license: + + Do I have to license DB to use it in Perl scripts? + + No. The Berkeley DB license requires that software that uses + Berkeley DB be freely redistributable. In the case of Perl, that + software is Perl, and not your scripts. Any Perl scripts that you + write are your property, including scripts that make use of Berkeley + DB. Neither the Perl license nor the Berkeley DB license + place any restriction on what you may do with them. + +If you are in any doubt about the license situation, contact either the +Berkeley DB authors or the author of BerkeleyDB. +See L<"AUTHOR"> for details. + + +=head1 AUTHOR + +Paul Marquess E<lt>Paul.Marquess@btinternet.comE<gt>. + +Questions about Berkeley DB may be addressed to E<lt>db@sleepycat.comE<gt>. + +=head1 SEE ALSO + +perl(1), DB_File, Berkeley DB. + +=cut diff --git a/bdb/perl/BerkeleyDB/BerkeleyDB.xs b/bdb/perl/BerkeleyDB/BerkeleyDB.xs new file mode 100644 index 00000000000..531b38a655f --- /dev/null +++ b/bdb/perl/BerkeleyDB/BerkeleyDB.xs @@ -0,0 +1,3643 @@ +/* + + BerkeleyDB.xs -- Perl 5 interface to Berkeley DB version 2 & 3 + + written by Paul Marquess <Paul.Marquess@btinternet.com> + + All comments/suggestions/problems are welcome + + 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. + + Please refer to the COPYRIGHT section in + + Changes: + 0.01 - First Alpha Release + 0.02 - + +*/ + + + +#ifdef __cplusplus +extern "C" { +#endif + +#define PERL_POLLUTE +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + + +/* XSUB.h defines a macro called abort */ +/* This clashes with the txn abort method in Berkeley DB 4.x */ +/* This is a problem with ActivePerl (at least) */ + +#ifdef _WIN32 +# ifdef abort +# undef abort +# endif +# ifdef fopen +# undef fopen +# endif +# ifdef fclose +# undef fclose +# endif +#endif + +/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be + * shortly #included by the <db.h>) __attribute__ to the possibly + * already defined __attribute__, for example by GNUC or by Perl. */ + +#undef __attribute__ + +#ifdef USE_PERLIO +# define GetFILEptr(sv) PerlIO_findFILE(IoOFP(sv_2io(sv))) +#else +# define GetFILEptr(sv) IoOFP(sv_2io(sv)) +#endif + +#include <db.h> + +/* Check the version of Berkeley DB */ + +#ifndef DB_VERSION_MAJOR +#ifdef HASHMAGIC +#error db.h is from Berkeley DB 1.x - need at least Berkeley DB 2.6.4 +#else +#error db.h is not for Berkeley DB at all. +#endif +#endif + +#if (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6) ||\ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 6 && DB_VERSION_PATCH < 4) +# error db.h is from Berkeley DB 2.0-2.5 - need at least Berkeley DB 2.6.4 +#endif + + +#if (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0) +# define IS_DB_3_0_x +#endif + +#if DB_VERSION_MAJOR >= 3 +# define AT_LEAST_DB_3 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 1) +# define AT_LEAST_DB_3_1 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + +#if DB_VERSION_MAJOR > 3 || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 2) ||\ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 2 && DB_VERSION_PATCH >= 6) +# define AT_LEAST_DB_3_2_6 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3) +# define AT_LEAST_DB_3_3 +#endif + +#if DB_VERSION_MAJOR >= 4 +# define AT_LEAST_DB_4 +#endif + +#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1) +# define AT_LEAST_DB_4_1 +#endif + +#ifdef __cplusplus +} +#endif + +#define DBM_FILTERING +#define STRICT_CLOSE +/* #define ALLOW_RECNO_OFFSET */ +/* #define TRACE */ + +#if DB_VERSION_MAJOR == 2 && ! defined(DB_LOCK_DEADLOCK) +# define DB_LOCK_DEADLOCK EAGAIN +#endif /* DB_VERSION_MAJOR == 2 */ + +#if DB_VERSION_MAJOR == 2 +# define DB_QUEUE 4 +#endif /* DB_VERSION_MAJOR == 2 */ + +#ifdef AT_LEAST_DB_3_2 +# define DB_callback DB * db, +#else +# define DB_callback +#endif + +#if DB_VERSION_MAJOR > 2 +typedef struct { + int db_lorder; + size_t db_cachesize; + size_t db_pagesize; + + + void *(*db_malloc) __P((size_t)); + int (*dup_compare) + __P((DB_callback const DBT *, const DBT *)); + + u_int32_t bt_maxkey; + u_int32_t bt_minkey; + int (*bt_compare) + __P((DB_callback const DBT *, const DBT *)); + size_t (*bt_prefix) + __P((DB_callback const DBT *, const DBT *)); + + u_int32_t h_ffactor; + u_int32_t h_nelem; + u_int32_t (*h_hash) + __P((DB_callback const void *, u_int32_t)); + + int re_pad; + int re_delim; + u_int32_t re_len; + char *re_source; + +#define DB_DELIMITER 0x0001 +#define DB_FIXEDLEN 0x0008 +#define DB_PAD 0x0010 + u_int32_t flags; + u_int32_t q_extentsize; +} DB_INFO ; + +#endif /* DB_VERSION_MAJOR > 2 */ + +typedef struct { + int Status ; + /* char ErrBuff[1000] ; */ + SV * ErrPrefix ; + FILE * ErrHandle ; + DB_ENV * Env ; + int open_dbs ; + int TxnMgrStatus ; + int active ; + bool txn_enabled ; + } BerkeleyDB_ENV_type ; + + +typedef struct { + DBTYPE type ; + bool recno_or_queue ; + char * filename ; + BerkeleyDB_ENV_type * parent_env ; + DB * dbp ; + SV * compare ; + bool in_compare ; + SV * dup_compare ; + bool in_dup_compare ; + SV * prefix ; + bool in_prefix ; + SV * hash ; + bool in_hash ; +#ifdef AT_LEAST_DB_3_3 + SV * associated ; + bool secondary_db ; +#endif + int Status ; + DB_INFO * info ; + DBC * cursor ; + DB_TXN * txn ; + int open_cursors ; + u_int32_t partial ; + u_int32_t dlen ; + u_int32_t doff ; + int active ; +#ifdef ALLOW_RECNO_OFFSET + int array_base ; +#endif +#ifdef DBM_FILTERING + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; +#endif + } BerkeleyDB_type; + + +typedef struct { + DBTYPE type ; + bool recno_or_queue ; + char * filename ; + DB * dbp ; + SV * compare ; + SV * dup_compare ; + SV * prefix ; + SV * hash ; +#ifdef AT_LEAST_DB_3_3 + SV * associated ; + bool secondary_db ; +#endif + int Status ; + DB_INFO * info ; + DBC * cursor ; + DB_TXN * txn ; + BerkeleyDB_type * parent_db ; + u_int32_t partial ; + u_int32_t dlen ; + u_int32_t doff ; + int active ; +#ifdef ALLOW_RECNO_OFFSET + int array_base ; +#endif +#ifdef DBM_FILTERING + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; +#endif + } BerkeleyDB_Cursor_type; + +typedef struct { + BerkeleyDB_ENV_type * env ; + } BerkeleyDB_TxnMgr_type ; + +#if 1 +typedef struct { + int Status ; + DB_TXN * txn ; + int active ; + } BerkeleyDB_Txn_type ; +#else +typedef DB_TXN BerkeleyDB_Txn_type ; +#endif + +typedef BerkeleyDB_ENV_type * BerkeleyDB__Env ; +typedef BerkeleyDB_ENV_type * BerkeleyDB__Env__Raw ; +typedef BerkeleyDB_ENV_type * BerkeleyDB__Env__Inner ; +typedef BerkeleyDB_type * BerkeleyDB ; +typedef void * BerkeleyDB__Raw ; +typedef BerkeleyDB_type * BerkeleyDB__Common ; +typedef BerkeleyDB_type * BerkeleyDB__Common__Raw ; +typedef BerkeleyDB_type * BerkeleyDB__Common__Inner ; +typedef BerkeleyDB_type * BerkeleyDB__Hash ; +typedef BerkeleyDB_type * BerkeleyDB__Hash__Raw ; +typedef BerkeleyDB_type * BerkeleyDB__Btree ; +typedef BerkeleyDB_type * BerkeleyDB__Btree__Raw ; +typedef BerkeleyDB_type * BerkeleyDB__Recno ; +typedef BerkeleyDB_type * BerkeleyDB__Recno__Raw ; +typedef BerkeleyDB_type * BerkeleyDB__Queue ; +typedef BerkeleyDB_type * BerkeleyDB__Queue__Raw ; +typedef BerkeleyDB_Cursor_type BerkeleyDB__Cursor_type ; +typedef BerkeleyDB_Cursor_type * BerkeleyDB__Cursor ; +typedef BerkeleyDB_Cursor_type * BerkeleyDB__Cursor__Raw ; +typedef BerkeleyDB_TxnMgr_type * BerkeleyDB__TxnMgr ; +typedef BerkeleyDB_TxnMgr_type * BerkeleyDB__TxnMgr__Raw ; +typedef BerkeleyDB_TxnMgr_type * BerkeleyDB__TxnMgr__Inner ; +typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn ; +typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn__Raw ; +typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn__Inner ; +#if 0 +typedef DB_LOG * BerkeleyDB__Log ; +typedef DB_LOCKTAB * BerkeleyDB__Lock ; +#endif +typedef DBT DBTKEY ; +typedef DBT DBT_OPT ; +typedef DBT DBT_B ; +typedef DBT DBTKEY_B ; +typedef DBT DBTVALUE ; +typedef void * PV_or_NULL ; +typedef PerlIO * IO_or_NULL ; +typedef int DualType ; + +static void +hash_delete(char * hash, char * key); + +#ifdef TRACE +# define Trace(x) printf x +#else +# define Trace(x) +#endif + +#ifdef ALLOW_RECNO_OFFSET +# define RECNO_BASE db->array_base +#else +# define RECNO_BASE 1 +#endif + +#if DB_VERSION_MAJOR == 2 +# define flagSet_DB2(i, f) i |= f +#else +# define flagSet_DB2(i, f) +#endif + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define flagSet(bitmask) (flags & (bitmask)) +#else +# define flagSet(bitmask) ((flags & DB_OPFLAGS_MASK) == (bitmask)) +#endif + +#if DB_VERSION_MAJOR == 2 +# define BackRef internal +#else +# if DB_VERSION_MAJOR == 3 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0) +# define BackRef cj_internal +# else +# define BackRef api_internal +# endif +#endif + +#define ERR_BUFF "BerkeleyDB::Error" + +#define ZMALLOC(to, typ) ((to = (typ *)safemalloc(sizeof(typ))), \ + Zero(to,1,typ)) + +#define DBT_clear(x) Zero(&x, 1, DBT) ; + +#if 1 +#define getInnerObject(x) (*av_fetch((AV*)SvRV(x), 0, FALSE)) +#else +#define getInnerObject(x) ((SV*)SvRV(sv)) +#endif + +#define my_sv_setpvn(sv, d, s) (s ? sv_setpvn(sv, d, s) : sv_setpv(sv, "") ) + +#define SetValue_iv(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = SvIV(sv) +#define SetValue_io(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = GetFILEptr(sv) +#define SetValue_sv(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = sv +#define SetValue_pv(i, k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = (t)SvPV(sv,PL_na) +#define SetValue_pvx(i, k, t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = (t)SvPVX(sv) +#define SetValue_ov(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\ + IV tmp = SvIV(getInnerObject(sv)) ; \ + i = INT2PTR(t, tmp) ; \ + } + +#define SetValue_ovx(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\ + HV * hv = (HV *)GetInternalObject(sv); \ + SV ** svp = hv_fetch(hv, "db", 2, FALSE);\ + IV tmp = SvIV(*svp); \ + i = INT2PTR(t, tmp) ; \ + } + +#define SetValue_ovX(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\ + IV tmp = SvIV(GetInternalObject(sv));\ + i = INT2PTR(t, tmp) ; \ + } + +#define LastDBerror DB_RUNRECOVERY + +#define setDUALerrno(var, err) \ + sv_setnv(var, (double)err) ; \ + sv_setpv(var, ((err) ? db_strerror(err) : "")) ;\ + SvNOK_on(var); + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ + } + +#define OutputValue_B(arg, name) \ + { if (RETVAL == 0) { \ + if (db->type == DB_BTREE && \ + flagSet(DB_GET_RECNO)){ \ + sv_setiv(arg, (I32)(*(I32*)name.data) - RECNO_BASE); \ + } \ + else { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + } \ + DBM_ckFilter(arg, filter_fetch_value, "filter_fetch_value"); \ + } \ + } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (!db->recno_or_queue) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - RECNO_BASE); \ + DBM_ckFilter(arg, filter_fetch_key, "filter_fetch_key") ; \ + } \ + } + +#define OutputKey_B(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->recno_or_queue || \ + (db->type == DB_BTREE && \ + flagSet(DB_GET_RECNO))){ \ + sv_setiv(arg, (I32)(*(I32*)name.data) - RECNO_BASE); \ + } \ + else { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + DBM_ckFilter(arg, filter_fetch_key, "filter_fetch_key") ; \ + } \ + } + +#define SetPartial(data,db) \ + data.flags = db->partial ; \ + data.dlen = db->dlen ; \ + data.doff = db->doff ; + +#define ckActive(active, type) \ + { \ + if (!active) \ + softCrash("%s is already closed", type) ; \ + } + +#define ckActive_Environment(a) ckActive(a, "Environment") +#define ckActive_TxnMgr(a) ckActive(a, "Transaction Manager") +#define ckActive_Transaction(a) ckActive(a, "Transaction") +#define ckActive_Database(a) ckActive(a, "Database") +#define ckActive_Cursor(a) ckActive(a, "Cursor") + +/* Internal Global Data */ +static db_recno_t Value ; +static db_recno_t zero = 0 ; +static BerkeleyDB CurrentDB ; + +static DBTKEY empty ; +#if 0 +static char ErrBuff[1000] ; +#endif + +#ifdef AT_LEAST_DB_3_3 +# if PERL_REVISION == 5 && PERL_VERSION <= 4 + +/* saferealloc in perl5.004 will croak if it is given a NULL pointer*/ +void * +MyRealloc(void * ptr, size_t size) +{ + if (ptr == NULL ) + return safemalloc(size) ; + else + return saferealloc(ptr, size) ; +} + +# else +# define MyRealloc saferealloc +# endif +#endif + +static char * +my_strdup(const char *s) +{ + if (s == NULL) + return NULL ; + + { + MEM_SIZE l = strlen(s); + char *s1 = (char *)safemalloc(l); + + Copy(s, s1, (MEM_SIZE)l, char); + return s1; + } +} + +#if DB_VERSION_MAJOR == 2 +static char * +db_strerror(int err) +{ + if (err == 0) + return "" ; + + if (err > 0) + return Strerror(err) ; + + switch (err) { + case DB_INCOMPLETE: + return ("DB_INCOMPLETE: Sync was unable to complete"); + case DB_KEYEMPTY: + return ("DB_KEYEMPTY: Non-existent key/data pair"); + case DB_KEYEXIST: + return ("DB_KEYEXIST: Key/data pair already exists"); + case DB_LOCK_DEADLOCK: + return ( + "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock"); + case DB_LOCK_NOTGRANTED: + return ("DB_LOCK_NOTGRANTED: Lock not granted"); + case DB_LOCK_NOTHELD: + return ("DB_LOCK_NOTHELD: Lock not held by locker"); + case DB_NOTFOUND: + return ("DB_NOTFOUND: No matching key/data pair found"); + case DB_RUNRECOVERY: + return ("DB_RUNRECOVERY: Fatal error, run database recovery"); + default: + return "Unknown Error" ; + + } +} +#endif /* DB_VERSION_MAJOR == 2 */ + +#ifdef TRACE +#if DB_VERSION_MAJOR > 2 +static char * +my_db_strerror(int err) +{ + static char buffer[1000] ; + SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; + sprintf(buffer, "%d: %s", err, db_strerror(err)) ; + if (err && sv) { + strcat(buffer, ", ") ; + strcat(buffer, SvPVX(sv)) ; + } + return buffer; +} +#endif +#endif + +static void +close_everything(void) +{ + dTHR; + Trace(("close_everything\n")) ; + /* Abort All Transactions */ + { + BerkeleyDB__Txn__Raw tid ; + HE * he ; + I32 len ; + HV * hv = perl_get_hv("BerkeleyDB::Term::Txn", TRUE); + int all = 0 ; + int closed = 0 ; + (void)hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_txns dirty=%d\n", PL_dirty)) ; + while ( (he = hv_iternext(hv)) ) { + tid = * (BerkeleyDB__Txn__Raw *) hv_iterkey(he, &len) ; + Trace((" Aborting Transaction [%d] in [%d] Active [%d]\n", tid->txn, tid, tid->active)); + if (tid->active) { +#ifdef AT_LEAST_DB_4 + tid->txn->abort(tid->txn) ; +#else + txn_abort(tid->txn); +#endif + ++ closed ; + } + tid->active = FALSE ; + ++ all ; + } + Trace(("End of BerkeleyDB::Term::close_all_txns aborted %d of %d transactios\n",closed, all)) ; + } + + /* Close All Cursors */ + { + BerkeleyDB__Cursor db ; + HE * he ; + I32 len ; + HV * hv = perl_get_hv("BerkeleyDB::Term::Cursor", TRUE); + int all = 0 ; + int closed = 0 ; + (void) hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_cursors \n")) ; + while ( (he = hv_iternext(hv)) ) { + db = * (BerkeleyDB__Cursor*) hv_iterkey(he, &len) ; + Trace((" Closing Cursor [%d] in [%d] Active [%d]\n", db->cursor, db, db->active)); + if (db->active) { + ((db->cursor)->c_close)(db->cursor) ; + ++ closed ; + } + db->active = FALSE ; + ++ all ; + } + Trace(("End of BerkeleyDB::Term::close_all_cursors closed %d of %d cursors\n",closed, all)) ; + } + + /* Close All Databases */ + { + BerkeleyDB db ; + HE * he ; + I32 len ; + HV * hv = perl_get_hv("BerkeleyDB::Term::Db", TRUE); + int all = 0 ; + int closed = 0 ; + (void)hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_dbs\n" )) ; + while ( (he = hv_iternext(hv)) ) { + db = * (BerkeleyDB*) hv_iterkey(he, &len) ; + Trace((" Closing Database [%d] in [%d] Active [%d]\n", db->dbp, db, db->active)); + if (db->active) { + (db->dbp->close)(db->dbp, 0) ; + ++ closed ; + } + db->active = FALSE ; + ++ all ; + } + Trace(("End of BerkeleyDB::Term::close_all_dbs closed %d of %d dbs\n",closed, all)) ; + } + + /* Close All Environments */ + { + BerkeleyDB__Env env ; + HE * he ; + I32 len ; + HV * hv = perl_get_hv("BerkeleyDB::Term::Env", TRUE); + int all = 0 ; + int closed = 0 ; + (void)hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_envs\n")) ; + while ( (he = hv_iternext(hv)) ) { + env = * (BerkeleyDB__Env*) hv_iterkey(he, &len) ; + Trace((" Closing Environment [%d] in [%d] Active [%d]\n", env->Env, env, env->active)); + if (env->active) { +#if DB_VERSION_MAJOR == 2 + db_appexit(env->Env) ; +#else + (env->Env->close)(env->Env, 0) ; +#endif + ++ closed ; + } + env->active = FALSE ; + ++ all ; + } + Trace(("End of BerkeleyDB::Term::close_all_envs closed %d of %d dbs\n",closed, all)) ; + } + + Trace(("end close_everything\n")) ; + +} + +static void +destroyDB(BerkeleyDB db) +{ + dTHR; + if (! PL_dirty && db->active) { + -- db->open_cursors ; + ((db->dbp)->close)(db->dbp, 0) ; + } + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->dup_compare) + SvREFCNT_dec(db->dup_compare) ; +#ifdef AT_LEAST_DB_3_3 + if (db->associated && !db->secondary_db) + SvREFCNT_dec(db->associated) ; +#endif + if (db->prefix) + SvREFCNT_dec(db->prefix) ; +#ifdef DBM_FILTERING + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; +#endif + hash_delete("BerkeleyDB::Term::Db", (char *)db) ; + if (db->filename) + Safefree(db->filename) ; + Safefree(db) ; +} + +static int +softCrash(const char *pat, ...) +{ + char buffer1 [500] ; + char buffer2 [500] ; + va_list args; + va_start(args, pat); + + Trace(("softCrash: %s\n", pat)) ; + +#define ABORT_PREFIX "BerkeleyDB Aborting: " + + /* buffer = (char*) safemalloc(strlen(pat) + strlen(ABORT_PREFIX) + 1) ; */ + strcpy(buffer1, ABORT_PREFIX) ; + strcat(buffer1, pat) ; + + vsprintf(buffer2, buffer1, args) ; + + croak(buffer2); + + /* NOTREACHED */ + va_end(args); + return 1 ; +} + + +static I32 +GetArrayLength(BerkeleyDB db) +{ + DBT key ; + DBT value ; + int RETVAL = 0 ; + DBC * cursor ; + + DBT_clear(key) ; + DBT_clear(value) ; +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + if ( ((db->dbp)->cursor)(db->dbp, db->txn, &cursor) == 0 ) +#else + if ( ((db->dbp)->cursor)(db->dbp, db->txn, &cursor, 0) == 0 ) +#endif + { + RETVAL = cursor->c_get(cursor, &key, &value, DB_LAST) ; + if (RETVAL == 0) + RETVAL = *(I32 *)key.data ; + else /* No key means empty file */ + RETVAL = 0 ; + cursor->c_close(cursor) ; + } + + Trace(("GetArrayLength got %d\n", RETVAL)) ; + return ((I32)RETVAL) ; +} + +#if 0 + +#define GetRecnoKey(db, value) _GetRecnoKey(db, value) + +static db_recno_t +_GetRecnoKey(BerkeleyDB db, I32 value) +{ + Trace(("GetRecnoKey start value = %d\n", value)) ; + if (db->recno_or_queue && value < 0) { + /* Get the length of the array */ + I32 length = GetArrayLength(db) ; + + /* check for attempt to write before start of array */ + if (length + value + RECNO_BASE <= 0) + softCrash("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + + value = length + value + RECNO_BASE ; + } + else + ++ value ; + + Trace(("GetRecnoKey end value = %d\n", value)) ; + + return value ; +} + +#else /* ! 0 */ + +#if 0 +#ifdef ALLOW_RECNO_OFFSET +#define GetRecnoKey(db, value) _GetRecnoKey(db, value) + +static db_recno_t +_GetRecnoKey(BerkeleyDB db, I32 value) +{ + if (value + RECNO_BASE < 1) + softCrash("key value %d < base (%d)", (value), RECNO_BASE?0:1) ; + return value + RECNO_BASE ; +} + +#else +#endif /* ALLOW_RECNO_OFFSET */ +#endif /* 0 */ + +#define GetRecnoKey(db, value) ((value) + RECNO_BASE ) + +#endif /* 0 */ + +#if 0 +static SV * +GetInternalObject(SV * sv) +{ + SV * info = (SV*) NULL ; + SV * s ; + MAGIC * mg ; + + Trace(("in GetInternalObject %d\n", sv)) ; + if (sv == NULL || !SvROK(sv)) + return NULL ; + + s = SvRV(sv) ; + if (SvMAGICAL(s)) + { + if (SvTYPE(s) == SVt_PVHV || SvTYPE(s) == SVt_PVAV) + mg = mg_find(s, 'P') ; + else + mg = mg_find(s, 'q') ; + + /* all this testing is probably overkill, but till I know more + about global destruction it stays. + */ + /* if (mg && mg->mg_obj && SvRV(mg->mg_obj) && SvPVX(SvRV(mg->mg_obj))) */ + if (mg && mg->mg_obj && SvRV(mg->mg_obj) ) + info = SvRV(mg->mg_obj) ; + else + info = s ; + } + + Trace(("end of GetInternalObject %d\n", info)) ; + return info ; +} +#endif + +static int +btree_compare(DB_callback const DBT * key1, const DBT * key2 ) +{ + dSP ; + char * data1, * data2 ; + int retval ; + int count ; + BerkeleyDB keepDB = CurrentDB ; + + data1 = (char*) key1->data ; + data2 = (char*) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + softCrash ("in btree_compare - expected 1 return value from compare sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + CurrentDB = keepDB ; + return (retval) ; + +} + +static int +dup_compare(DB_callback const DBT * key1, const DBT * key2 ) +{ + dSP ; + char * data1, * data2 ; + int retval ; + int count ; + BerkeleyDB keepDB = CurrentDB ; + + Trace(("In dup_compare \n")) ; + if (!CurrentDB) + softCrash("Internal Error - No CurrentDB in dup_compare") ; + if (CurrentDB->dup_compare == NULL) + softCrash("in dup_compare: no callback specified for database '%s'", CurrentDB->filename) ; + + data1 = (char*) key1->data ; + data2 = (char*) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->dup_compare, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + softCrash ("dup_compare: expected 1 return value from compare sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + CurrentDB = keepDB ; + return (retval) ; + +} + +static size_t +btree_prefix(DB_callback const DBT * key1, const DBT * key2 ) +{ + dSP ; + char * data1, * data2 ; + int retval ; + int count ; + BerkeleyDB keepDB = CurrentDB ; + + data1 = (char*) key1->data ; + data2 = (char*) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + softCrash ("btree_prefix: expected 1 return value from prefix sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + CurrentDB = keepDB ; + + return (retval) ; +} + +static u_int32_t +hash_cb(DB_callback const void * data, u_int32_t size) +{ + dSP ; + int retval ; + int count ; + BerkeleyDB keepDB = CurrentDB ; + +#ifndef newSVpvn + if (size == 0) + data = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + + XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->hash, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + softCrash ("hash_cb: expected 1 return value from hash sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + CurrentDB = keepDB ; + + return (retval) ; +} + +#ifdef AT_LEAST_DB_3_3 + +static int +associate_cb(DB_callback const DBT * pkey, const DBT * pdata, DBT * skey) +{ + dSP ; + char * pk_dat, * pd_dat, *sk_dat ; + int retval ; + int count ; + SV * skey_SV ; + + Trace(("In associate_cb \n")) ; + if (((BerkeleyDB)db->BackRef)->associated == NULL){ + Trace(("No Callback registered\n")) ; + return EINVAL ; + } + + skey_SV = newSVpv("",0); + + + pk_dat = (char*) pkey->data ; + pd_dat = (char*) pdata->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (pkey->size == 0) + pk_dat = "" ; + if (pdata->size == 0) + pd_dat = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(pk_dat,pkey->size))); + PUSHs(sv_2mortal(newSVpvn(pd_dat,pdata->size))); + PUSHs(sv_2mortal(skey_SV)); + PUTBACK ; + + Trace(("calling associated cb\n")); + count = perl_call_sv(((BerkeleyDB)db->BackRef)->associated, G_SCALAR); + Trace(("called associated cb\n")); + + SPAGAIN ; + + if (count != 1) + softCrash ("associate: expected 1 return value from prefix sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + + /* retrieve the secondary key */ + DBT_clear(*skey); + skey->flags = DB_DBT_APPMALLOC; + skey->size = SvCUR(skey_SV); + skey->data = (char*)safemalloc(skey->size); + memcpy(skey->data, SvPVX(skey_SV), skey->size); + Trace(("key is %d -- %.*s\n", skey->size, skey->size, skey->data)); + + FREETMPS ; + LEAVE ; + + return (retval) ; +} + +#endif /* AT_LEAST_DB_3_3 */ + +static void +db_errcall_cb(const char * db_errpfx, char * buffer) +{ +#if 0 + + if (db_errpfx == NULL) + db_errpfx = "" ; + if (buffer == NULL ) + buffer = "" ; + ErrBuff[0] = '\0'; + if (strlen(db_errpfx) + strlen(buffer) + 3 <= 1000) { + if (*db_errpfx != '\0') { + strcat(ErrBuff, db_errpfx) ; + strcat(ErrBuff, ": ") ; + } + strcat(ErrBuff, buffer) ; + } + +#endif + + SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; + if (sv) { + if (db_errpfx) + sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ; + else + sv_setpv(sv, buffer) ; + } +} + +static SV * +readHash(HV * hash, char * key) +{ + SV ** svp; + svp = hv_fetch(hash, key, strlen(key), FALSE); + if (svp && SvOK(*svp)) + return *svp ; + return NULL ; +} + +static void +hash_delete(char * hash, char * key) +{ + HV * hv = perl_get_hv(hash, TRUE); + (void) hv_delete(hv, (char*)&key, sizeof(key), G_DISCARD); +} + +static void +hash_store_iv(char * hash, char * key, IV value) +{ + HV * hv = perl_get_hv(hash, TRUE); + (void)hv_store(hv, (char*)&key, sizeof(key), newSViv(value), 0); + /* printf("hv_store returned %d\n", ret) ; */ +} + +static void +hv_store_iv(HV * hash, char * key, IV value) +{ + hv_store(hash, key, strlen(key), newSViv(value), 0); +} + +static BerkeleyDB +my_db_open( + BerkeleyDB db , + SV * ref, + SV * ref_dbenv , + BerkeleyDB__Env dbenv , + BerkeleyDB__Txn txn, + const char * file, + const char * subname, + DBTYPE type, + int flags, + int mode, + DB_INFO * info + ) +{ + DB_ENV * env = NULL ; + BerkeleyDB RETVAL = NULL ; + DB * dbp ; + int Status ; + DB_TXN* txnid = NULL ; + + Trace(("_db_open(dbenv[%p] ref_dbenv [%p] file[%s] subname [%s] type[%d] flags[%d] mode[%d]\n", + dbenv, ref_dbenv, file, subname, type, flags, mode)) ; + + CurrentDB = db ; + if (dbenv) + env = dbenv->Env ; + + if (txn) + txnid = txn->txn; + + Trace(("_db_open(dbenv[%p] ref_dbenv [%p] txn [%p] file[%s] subname [%s] type[%d] flags[%d] mode[%d]\n", + dbenv, ref_dbenv, txn, file, subname, type, flags, mode)) ; + +#if DB_VERSION_MAJOR == 2 + if (subname) + softCrash("Subname needs Berkeley DB 3 or better") ; +#endif + +#if DB_VERSION_MAJOR > 2 + Status = db_create(&dbp, env, 0) ; + Trace(("db_create returned %s\n", my_db_strerror(Status))) ; + if (Status) + return RETVAL ; + +#ifdef AT_LEAST_DB_3_3 + if (! env) { + dbp->set_alloc(dbp, safemalloc, MyRealloc, safefree) ; + dbp->set_errcall(dbp, db_errcall_cb) ; + } +#endif + + if (info->re_source) { + Status = dbp->set_re_source(dbp, info->re_source) ; + Trace(("set_re_source [%s] returned %s\n", + info->re_source, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->db_cachesize) { + Status = dbp->set_cachesize(dbp, 0, info->db_cachesize, 0) ; + Trace(("set_cachesize [%d] returned %s\n", + info->db_cachesize, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->db_lorder) { + Status = dbp->set_lorder(dbp, info->db_lorder) ; + Trace(("set_lorder [%d] returned %s\n", + info->db_lorder, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->db_pagesize) { + Status = dbp->set_pagesize(dbp, info->db_pagesize) ; + Trace(("set_pagesize [%d] returned %s\n", + info->db_pagesize, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->h_ffactor) { + Status = dbp->set_h_ffactor(dbp, info->h_ffactor) ; + Trace(("set_h_ffactor [%d] returned %s\n", + info->h_ffactor, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->h_nelem) { + Status = dbp->set_h_nelem(dbp, info->h_nelem) ; + Trace(("set_h_nelem [%d] returned %s\n", + info->h_nelem, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->bt_minkey) { + Status = dbp->set_bt_minkey(dbp, info->bt_minkey) ; + Trace(("set_bt_minkey [%d] returned %s\n", + info->bt_minkey, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->bt_compare) { + Status = dbp->set_bt_compare(dbp, info->bt_compare) ; + Trace(("set_bt_compare [%p] returned %s\n", + info->bt_compare, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->h_hash) { + Status = dbp->set_h_hash(dbp, info->h_hash) ; + Trace(("set_h_hash [%d] returned %s\n", + info->h_hash, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->dup_compare) { + Status = dbp->set_dup_compare(dbp, info->dup_compare) ; + Trace(("set_dup_compare [%d] returned %s\n", + info->dup_compare, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->bt_prefix) { + Status = dbp->set_bt_prefix(dbp, info->bt_prefix) ; + Trace(("set_bt_prefix [%d] returned %s\n", + info->bt_prefix, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->re_len) { + Status = dbp->set_re_len(dbp, info->re_len) ; + Trace(("set_re_len [%d] returned %s\n", + info->re_len, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->re_delim) { + Status = dbp->set_re_delim(dbp, info->re_delim) ; + Trace(("set_re_delim [%d] returned %s\n", + info->re_delim, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->re_pad) { + Status = dbp->set_re_pad(dbp, info->re_pad) ; + Trace(("set_re_pad [%d] returned %s\n", + info->re_pad, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->flags) { + Status = dbp->set_flags(dbp, info->flags) ; + Trace(("set_flags [%d] returned %s\n", + info->flags, my_db_strerror(Status))); + if (Status) + return RETVAL ; + } + + if (info->q_extentsize) { +#ifdef AT_LEAST_DB_3_2 + Status = dbp->set_q_extentsize(dbp, info->q_extentsize) ; + Trace(("set_flags [%d] returned %s\n", + info->flags, my_db_strerror(Status))); + if (Status) + return RETVAL ; +#else + softCrash("-ExtentSize needs at least Berkeley DB 3.2.x") ; +#endif + } + +#ifdef AT_LEAST_DB_4_1 + if ((Status = (dbp->open)(dbp, txnid, file, subname, type, flags, mode)) == 0) { +#else + if ((Status = (dbp->open)(dbp, file, subname, type, flags, mode)) == 0) { +#endif /* AT_LEAST_DB_4_1 */ +#else /* DB_VERSION_MAJOR == 2 */ + if ((Status = db_open(file, type, flags, mode, env, info, &dbp)) == 0) { +#endif /* DB_VERSION_MAJOR == 2 */ + + Trace(("db_opened ok\n")); +#ifdef AT_LEAST_DB_3_3 + dbp->BackRef = db; +#endif + RETVAL = db ; + RETVAL->dbp = dbp ; + RETVAL->txn = txnid ; +#if DB_VERSION_MAJOR == 2 + RETVAL->type = dbp->type ; +#else /* DB_VERSION_MAJOR > 2 */ +#ifdef AT_LEAST_DB_3_3 + dbp->get_type(dbp, &RETVAL->type) ; +#else /* DB 3.0 -> 3.2 */ + RETVAL->type = dbp->get_type(dbp) ; +#endif +#endif /* DB_VERSION_MAJOR > 2 */ + RETVAL->recno_or_queue = (RETVAL->type == DB_RECNO || + RETVAL->type == DB_QUEUE) ; + RETVAL->filename = my_strdup(file) ; + RETVAL->Status = Status ; + RETVAL->active = TRUE ; + hash_store_iv("BerkeleyDB::Term::Db", (char *)RETVAL, 1) ; + Trace((" storing %p %p in BerkeleyDB::Term::Db\n", RETVAL, dbp)) ; + if (dbenv) { + RETVAL->parent_env = dbenv ; + dbenv->Status = Status ; + ++ dbenv->open_dbs ; + } + } + else { +#if DB_VERSION_MAJOR > 2 + (dbp->close)(dbp, 0) ; +#endif + destroyDB(db) ; + Trace(("db open returned %s\n", my_db_strerror(Status))) ; + } + + return RETVAL ; +} + + +#include "constants.h" + +MODULE = BerkeleyDB PACKAGE = BerkeleyDB PREFIX = env_ + +INCLUDE: constants.xs + +#define env_db_version(maj, min, patch) db_version(&maj, &min, &patch) +char * +env_db_version(maj, min, patch) + int maj + int min + int patch + OUTPUT: + RETVAL + maj + min + patch + +int +db_value_set(value, which) + int value + int which + NOT_IMPLEMENTED_YET + + +DualType +_db_remove(ref) + SV * ref + CODE: + { +#if DB_VERSION_MAJOR == 2 + softCrash("BerkeleyDB::db_remove needs Berkeley DB 3.x or better") ; +#else + HV * hash ; + DB * dbp ; + SV * sv ; + const char * db = NULL ; + const char * subdb = NULL ; + BerkeleyDB__Env env = NULL ; + DB_ENV * dbenv = NULL ; + u_int32_t flags = 0 ; + + hash = (HV*) SvRV(ref) ; + SetValue_pv(db, "Filename", char *) ; + SetValue_pv(subdb, "Subname", char *) ; + SetValue_iv(flags, "Flags") ; + SetValue_ov(env, "Env", BerkeleyDB__Env) ; + if (env) + dbenv = env->Env ; + RETVAL = db_create(&dbp, dbenv, 0) ; + if (RETVAL == 0) { + RETVAL = dbp->remove(dbp, db, subdb, flags) ; + } +#endif + } + OUTPUT: + RETVAL + +DualType +_db_verify(ref) + SV * ref + CODE: + { +#ifndef AT_LEAST_DB_3_1 + softCrash("BerkeleyDB::db_verify needs Berkeley DB 3.1.x or better") ; +#else + HV * hash ; + DB * dbp ; + SV * sv ; + const char * db = NULL ; + const char * subdb = NULL ; + const char * outfile = NULL ; + FILE * ofh = NULL; + BerkeleyDB__Env env = NULL ; + DB_ENV * dbenv = NULL ; + u_int32_t flags = 0 ; + + hash = (HV*) SvRV(ref) ; + SetValue_pv(db, "Filename", char *) ; + SetValue_pv(subdb, "Subname", char *) ; + SetValue_pv(outfile, "Outfile", char *) ; + SetValue_iv(flags, "Flags") ; + SetValue_ov(env, "Env", BerkeleyDB__Env) ; + RETVAL = 0; + if (outfile){ + ofh = fopen(outfile, "w"); + if (! ofh) + RETVAL = errno; + } + if (! RETVAL) { + if (env) + dbenv = env->Env ; + RETVAL = db_create(&dbp, dbenv, 0) ; + if (RETVAL == 0) { + RETVAL = dbp->verify(dbp, db, subdb, ofh, flags) ; + } + if (outfile) + fclose(ofh); + } +#endif + } + OUTPUT: + RETVAL + +DualType +_db_rename(ref) + SV * ref + CODE: + { +#ifndef AT_LEAST_DB_3_1 + softCrash("BerkeleyDB::db_rename needs Berkeley DB 3.1.x or better") ; +#else + HV * hash ; + DB * dbp ; + SV * sv ; + const char * db = NULL ; + const char * subdb = NULL ; + const char * newname = NULL ; + BerkeleyDB__Env env = NULL ; + DB_ENV * dbenv = NULL ; + u_int32_t flags = 0 ; + + hash = (HV*) SvRV(ref) ; + SetValue_pv(db, "Filename", char *) ; + SetValue_pv(subdb, "Subname", char *) ; + SetValue_pv(newname, "Newname", char *) ; + SetValue_iv(flags, "Flags") ; + SetValue_ov(env, "Env", BerkeleyDB__Env) ; + if (env) + dbenv = env->Env ; + RETVAL = db_create(&dbp, dbenv, 0) ; + if (RETVAL == 0) { + RETVAL = dbp->rename(dbp, db, subdb, newname, flags) ; + } +#endif + } + OUTPUT: + RETVAL + +MODULE = BerkeleyDB::Env PACKAGE = BerkeleyDB::Env PREFIX = env_ + + +BerkeleyDB::Env::Raw +_db_appinit(self, ref) + char * self + SV * ref + CODE: + { + HV * hash ; + SV * sv ; + char * home = NULL ; + char * errfile = NULL ; + char * server = NULL ; + char ** config = NULL ; + int flags = 0 ; + int setflags = 0 ; + int cachesize = 0 ; + int lk_detect = 0 ; + SV * errprefix = NULL; + DB_ENV * env ; + int status ; + + Trace(("in _db_appinit [%s] %d\n", self, ref)) ; + hash = (HV*) SvRV(ref) ; + SetValue_pv(home, "Home", char *) ; + SetValue_pv(config, "Config", char **) ; + SetValue_sv(errprefix, "ErrPrefix") ; + SetValue_iv(flags, "Flags") ; + SetValue_iv(setflags, "SetFlags") ; + SetValue_pv(server, "Server", char *) ; + SetValue_iv(cachesize, "Cachesize") ; + SetValue_iv(lk_detect, "LockDetect") ; +#ifndef AT_LEAST_DB_3_2 + if (setflags) + softCrash("-SetFlags needs Berkeley DB 3.x or better") ; +#endif /* ! AT_LEAST_DB_3 */ +#ifndef AT_LEAST_DB_3_1 + if (server) + softCrash("-Server needs Berkeley DB 3.1 or better") ; +#endif /* ! AT_LEAST_DB_3_1 */ + Trace(("_db_appinit(config=[%d], home=[%s],errprefix=[%s],flags=[%d]\n", + config, home, errprefix, flags)) ; +#ifdef TRACE + if (config) { + int i ; + for (i = 0 ; i < 10 ; ++ i) { + if (config[i] == NULL) { + printf(" End\n") ; + break ; + } + printf(" config = [%s]\n", config[i]) ; + } + } +#endif /* TRACE */ + ZMALLOC(RETVAL, BerkeleyDB_ENV_type) ; + if (flags & DB_INIT_TXN) + RETVAL->txn_enabled = TRUE ; +#if DB_VERSION_MAJOR == 2 + ZMALLOC(RETVAL->Env, DB_ENV) ; + env = RETVAL->Env ; + { + /* Take a copy of the error prefix */ + if (errprefix) { + Trace(("copying errprefix\n" )) ; + RETVAL->ErrPrefix = newSVsv(errprefix) ; + SvPOK_only(RETVAL->ErrPrefix) ; + } + if (RETVAL->ErrPrefix) + RETVAL->Env->db_errpfx = SvPVX(RETVAL->ErrPrefix) ; + + SetValue_pv(errfile, "ErrFile", char *) ; + if (errfile) { + RETVAL->ErrHandle = env->db_errfile = fopen(errfile, "w"); + if (RETVAL->ErrHandle == NULL) + croak("Cannot open file %s: %s\n", errfile, Strerror(errno)); + } + SetValue_iv(env->db_verbose, "Verbose") ; + env->db_errcall = db_errcall_cb ; + RETVAL->active = TRUE ; + status = db_appinit(home, config, env, flags) ; + Trace((" status = %d env %d Env %d\n", status, RETVAL, env)) ; + if (status == 0) + hash_store_iv("BerkeleyDB::Term::Env", (char *)RETVAL, 1) ; + else { + if (RETVAL->ErrHandle) + fclose(RETVAL->ErrHandle) ; + if (RETVAL->ErrPrefix) + SvREFCNT_dec(RETVAL->ErrPrefix) ; + Safefree(RETVAL->Env) ; + Safefree(RETVAL) ; + RETVAL = NULL ; + } + } +#else /* DB_VERSION_MAJOR > 2 */ +#ifndef AT_LEAST_DB_3_1 +# define DB_CLIENT 0 +#endif + status = db_env_create(&RETVAL->Env, server ? DB_CLIENT : 0) ; + Trace(("db_env_create flags = %d returned %s\n", flags, + my_db_strerror(status))) ; + env = RETVAL->Env ; +#ifdef AT_LEAST_DB_3_3 + env->set_alloc(env, safemalloc, MyRealloc, safefree) ; +#endif + if (status == 0 && cachesize) { + status = env->set_cachesize(env, 0, cachesize, 0) ; + Trace(("set_cachesize [%d] returned %s\n", + cachesize, my_db_strerror(status))); + } + + if (status == 0 && lk_detect) { + status = env->set_lk_detect(env, lk_detect) ; + Trace(("set_lk_detect [%d] returned %s\n", + lk_detect, my_db_strerror(status))); + } +#ifdef AT_LEAST_DB_4 + /* set the server */ + if (server && status == 0) + { + status = env->set_rpc_server(env, NULL, server, 0, 0, 0); + Trace(("ENV->set_rpc_server server = %s returned %s\n", server, + my_db_strerror(status))) ; + } +#else +# if defined(AT_LEAST_DB_3_1) && ! defined(AT_LEAST_DB_4) + /* set the server */ + if (server && status == 0) + { + status = env->set_server(env, server, 0, 0, 0); + Trace(("ENV->set_server server = %s returned %s\n", server, + my_db_strerror(status))) ; + } +# endif +#endif +#ifdef AT_LEAST_DB_3_2 + if (setflags && status == 0) + { + status = env->set_flags(env, setflags, 1); + Trace(("ENV->set_flags value = %d returned %s\n", setflags, + my_db_strerror(status))) ; + } +#endif + if (status == 0) + { + int mode = 0 ; + /* Take a copy of the error prefix */ + if (errprefix) { + Trace(("copying errprefix\n" )) ; + RETVAL->ErrPrefix = newSVsv(errprefix) ; + SvPOK_only(RETVAL->ErrPrefix) ; + } + if (RETVAL->ErrPrefix) + env->set_errpfx(env, SvPVX(RETVAL->ErrPrefix)) ; + + SetValue_pv(errfile, "ErrFile", char *) ; + if (errfile) { + RETVAL->ErrHandle = fopen(errfile, "w"); + if (RETVAL->ErrHandle == NULL) + croak("Cannot open file %s: %s\n", errfile, Strerror(errno)); + env->set_errfile(env, RETVAL->ErrHandle) ; + } + + SetValue_iv(mode, "Mode") ; + env->set_errcall(env, db_errcall_cb) ; + RETVAL->active = TRUE ; +#ifdef IS_DB_3_0_x + status = (env->open)(env, home, config, flags, mode) ; +#else /* > 3.0 */ + status = (env->open)(env, home, flags, mode) ; +#endif + Trace(("ENV->open returned %s\n", my_db_strerror(status))) ; + } + + if (status == 0) + hash_store_iv("BerkeleyDB::Term::Env", (char *)RETVAL, 1) ; + else { + (env->close)(env, 0) ; + if (RETVAL->ErrHandle) + fclose(RETVAL->ErrHandle) ; + if (RETVAL->ErrPrefix) + SvREFCNT_dec(RETVAL->ErrPrefix) ; + Safefree(RETVAL) ; + RETVAL = NULL ; + } +#endif /* DB_VERSION_MAJOR > 2 */ + } + OUTPUT: + RETVAL + +void +log_archive(env, flags=0) + u_int32_t flags + BerkeleyDB::Env env + PPCODE: + { + char ** list; + char ** file; + AV * av; +#ifndef AT_LEAST_DB_3 + softCrash("log_archive needs at least Berkeley DB 3.x.x"); +#else +# ifdef AT_LEAST_DB_4 + env->Status = env->Env->log_archive(env->Env, &list, flags) ; +# else +# ifdef AT_LEAST_DB_3_3 + env->Status = log_archive(env->Env, &list, flags) ; +# else + env->Status = log_archive(env->Env, &list, flags, safemalloc) ; +# endif +# endif + if (env->Status == 0 && list != NULL) + { + for (file = list; *file != NULL; ++file) + { + XPUSHs(sv_2mortal(newSVpv(*file, 0))) ; + } + safefree(list); + } +#endif + } + +BerkeleyDB::Txn::Raw +_txn_begin(env, pid=NULL, flags=0) + u_int32_t flags + BerkeleyDB::Env env + BerkeleyDB::Txn pid + CODE: + { + DB_TXN *txn ; + DB_TXN *p_id = NULL ; + Trace(("txn_begin pid %d, flags %d\n", pid, flags)) ; +#if DB_VERSION_MAJOR == 2 + if (env->Env->tx_info == NULL) + softCrash("Transaction Manager not enabled") ; +#endif + if (!env->txn_enabled) + softCrash("Transaction Manager not enabled") ; + if (pid) + p_id = pid->txn ; + env->TxnMgrStatus = +#if DB_VERSION_MAJOR == 2 + txn_begin(env->Env->tx_info, p_id, &txn) ; +#else +# ifdef AT_LEAST_DB_4 + env->Env->txn_begin(env->Env, p_id, &txn, flags) ; +# else + txn_begin(env->Env, p_id, &txn, flags) ; +# endif +#endif + if (env->TxnMgrStatus == 0) { + ZMALLOC(RETVAL, BerkeleyDB_Txn_type) ; + RETVAL->txn = txn ; + RETVAL->active = TRUE ; + Trace(("_txn_begin created txn [%p] in [%p]\n", txn, RETVAL)); + hash_store_iv("BerkeleyDB::Term::Txn", (char *)RETVAL, 1) ; + } + else + RETVAL = NULL ; + } + OUTPUT: + RETVAL + + +#if DB_VERSION_MAJOR == 2 +# define env_txn_checkpoint(e,k,m,f) txn_checkpoint(e->Env->tx_info, k, m) +#else /* DB 3.0 or better */ +# ifdef AT_LEAST_DB_4 +# define env_txn_checkpoint(e,k,m,f) e->Env->txn_checkpoint(e->Env, k, m, f) +# else +# ifdef AT_LEAST_DB_3_1 +# define env_txn_checkpoint(e,k,m,f) txn_checkpoint(e->Env, k, m, 0) +# else +# define env_txn_checkpoint(e,k,m,f) txn_checkpoint(e->Env, k, m) +# endif +# endif +#endif +DualType +env_txn_checkpoint(env, kbyte, min, flags=0) + BerkeleyDB::Env env + long kbyte + long min + u_int32_t flags + +HV * +txn_stat(env) + BerkeleyDB::Env env + HV * RETVAL = NULL ; + CODE: + { + DB_TXN_STAT * stat ; +#ifdef AT_LEAST_DB_4 + if(env->Env->txn_stat(env->Env, &stat, 0) == 0) { +#else +# ifdef AT_LEAST_DB_3_3 + if(txn_stat(env->Env, &stat) == 0) { +# else +# if DB_VERSION_MAJOR == 2 + if(txn_stat(env->Env->tx_info, &stat, safemalloc) == 0) { +# else + if(txn_stat(env->Env, &stat, safemalloc) == 0) { +# endif +# endif +#endif + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "st_time_ckp", stat->st_time_ckp) ; + hv_store_iv(RETVAL, "st_last_txnid", stat->st_last_txnid) ; + hv_store_iv(RETVAL, "st_maxtxns", stat->st_maxtxns) ; + hv_store_iv(RETVAL, "st_naborts", stat->st_naborts) ; + hv_store_iv(RETVAL, "st_nbegins", stat->st_nbegins) ; + hv_store_iv(RETVAL, "st_ncommits", stat->st_ncommits) ; + hv_store_iv(RETVAL, "st_nactive", stat->st_nactive) ; +#if DB_VERSION_MAJOR > 2 + hv_store_iv(RETVAL, "st_maxnactive", stat->st_maxnactive) ; + hv_store_iv(RETVAL, "st_regsize", stat->st_regsize) ; + hv_store_iv(RETVAL, "st_region_wait", stat->st_region_wait) ; + hv_store_iv(RETVAL, "st_region_nowait", stat->st_region_nowait) ; +#endif + safefree(stat) ; + } + } + OUTPUT: + RETVAL + +#define EnDis(x) ((x) ? "Enabled" : "Disabled") +void +printEnv(env) + BerkeleyDB::Env env + INIT: + ckActive_Environment(env->active) ; + CODE: +#if 0 + printf("env [0x%X]\n", env) ; + printf(" ErrPrefix [%s]\n", env->ErrPrefix + ? SvPVX(env->ErrPrefix) : 0) ; + printf(" DB_ENV\n") ; + printf(" db_lorder [%d]\n", env->Env.db_lorder) ; + printf(" db_home [%s]\n", env->Env.db_home) ; + printf(" db_data_dir [%s]\n", env->Env.db_data_dir) ; + printf(" db_log_dir [%s]\n", env->Env.db_log_dir) ; + printf(" db_tmp_dir [%s]\n", env->Env.db_tmp_dir) ; + printf(" lk_info [%s]\n", EnDis(env->Env.lk_info)) ; + printf(" lk_max [%d]\n", env->Env.lk_max) ; + printf(" lg_info [%s]\n", EnDis(env->Env.lg_info)) ; + printf(" lg_max [%d]\n", env->Env.lg_max) ; + printf(" mp_info [%s]\n", EnDis(env->Env.mp_info)) ; + printf(" mp_size [%d]\n", env->Env.mp_size) ; + printf(" tx_info [%s]\n", EnDis(env->Env.tx_info)) ; + printf(" tx_max [%d]\n", env->Env.tx_max) ; + printf(" flags [%d]\n", env->Env.flags) ; + printf("\n") ; +#endif + +SV * +errPrefix(env, prefix) + BerkeleyDB::Env env + SV * prefix + INIT: + ckActive_Environment(env->active) ; + CODE: + if (env->ErrPrefix) { + RETVAL = newSVsv(env->ErrPrefix) ; + SvPOK_only(RETVAL) ; + sv_setsv(env->ErrPrefix, prefix) ; + } + else { + RETVAL = NULL ; + env->ErrPrefix = newSVsv(prefix) ; + } + SvPOK_only(env->ErrPrefix) ; +#if DB_VERSION_MAJOR == 2 + env->Env->db_errpfx = SvPVX(env->ErrPrefix) ; +#else + env->Env->set_errpfx(env->Env, SvPVX(env->ErrPrefix)) ; +#endif + OUTPUT: + RETVAL + +DualType +status(env) + BerkeleyDB::Env env + CODE: + RETVAL = env->Status ; + OUTPUT: + RETVAL + +DualType +db_appexit(env) + BerkeleyDB::Env env + ALIAS: close =1 + INIT: + ckActive_Environment(env->active) ; + CODE: +#ifdef STRICT_CLOSE + if (env->open_dbs) + softCrash("attempted to close an environment with %d open database(s)", + env->open_dbs) ; +#endif /* STRICT_CLOSE */ +#if DB_VERSION_MAJOR == 2 + RETVAL = db_appexit(env->Env) ; +#else + RETVAL = (env->Env->close)(env->Env, 0) ; +#endif + env->active = FALSE ; + hash_delete("BerkeleyDB::Term::Env", (char *)env) ; + OUTPUT: + RETVAL + + +void +_DESTROY(env) + BerkeleyDB::Env env + int RETVAL = 0 ; + CODE: + Trace(("In BerkeleyDB::Env::DESTROY\n")); + Trace((" env %ld Env %ld dirty %d\n", env, &env->Env, PL_dirty)) ; + if (env->active) +#if DB_VERSION_MAJOR == 2 + db_appexit(env->Env) ; +#else + (env->Env->close)(env->Env, 0) ; +#endif + if (env->ErrHandle) + fclose(env->ErrHandle) ; + if (env->ErrPrefix) + SvREFCNT_dec(env->ErrPrefix) ; +#if DB_VERSION_MAJOR == 2 + Safefree(env->Env) ; +#endif + Safefree(env) ; + hash_delete("BerkeleyDB::Term::Env", (char *)env) ; + Trace(("End of BerkeleyDB::Env::DESTROY %d\n", RETVAL)) ; + +BerkeleyDB::TxnMgr::Raw +_TxnMgr(env) + BerkeleyDB::Env env + INIT: + ckActive_Environment(env->active) ; + if (!env->txn_enabled) + softCrash("Transaction Manager not enabled") ; + CODE: + ZMALLOC(RETVAL, BerkeleyDB_TxnMgr_type) ; + RETVAL->env = env ; + /* hash_store_iv("BerkeleyDB::Term::TxnMgr", (char *)txn, 1) ; */ + OUTPUT: + RETVAL + +int +set_lg_dir(env, dir) + BerkeleyDB::Env env + char * dir + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("$env->set_lg_dir needs Berkeley DB 3.1 or better") ; +#else + RETVAL = env->Status = env->Env->set_lg_dir(env->Env, dir); +#endif + OUTPUT: + RETVAL + +int +set_lg_bsize(env, bsize) + BerkeleyDB::Env env + u_int32_t bsize + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3 + softCrash("$env->set_lg_bsize needs Berkeley DB 3.0.55 or better") ; +#else + RETVAL = env->Status = env->Env->set_lg_bsize(env->Env, bsize); +#endif + OUTPUT: + RETVAL + +int +set_lg_max(env, lg_max) + BerkeleyDB::Env env + u_int32_t lg_max + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3 + softCrash("$env->set_lg_max needs Berkeley DB 3.0.55 or better") ; +#else + RETVAL = env->Status = env->Env->set_lg_max(env->Env, lg_max); +#endif + OUTPUT: + RETVAL + +int +set_data_dir(env, dir) + BerkeleyDB::Env env + char * dir + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("$env->set_data_dir needs Berkeley DB 3.1 or better") ; +#else + RETVAL = env->Status = env->Env->set_data_dir(env->Env, dir); +#endif + OUTPUT: + RETVAL + +int +set_tmp_dir(env, dir) + BerkeleyDB::Env env + char * dir + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("$env->set_tmp_dir needs Berkeley DB 3.1 or better") ; +#else + RETVAL = env->Status = env->Env->set_tmp_dir(env->Env, dir); +#endif + OUTPUT: + RETVAL + +int +set_mutexlocks(env, do_lock) + BerkeleyDB::Env env + int do_lock + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3 + softCrash("$env->set_setmutexlocks needs Berkeley DB 3.0 or better") ; +#else +# ifdef AT_LEAST_DB_4 + RETVAL = env->Status = env->Env->set_flags(env->Env, DB_NOLOCKING, do_lock); +# else +# if defined(AT_LEAST_DB_3_2_6) || defined(IS_DB_3_0_x) + RETVAL = env->Status = env->Env->set_mutexlocks(env->Env, do_lock); +# else /* DB 3.1 or 3.2.3 */ + RETVAL = env->Status = db_env_set_mutexlocks(do_lock); +# endif +# endif +#endif + OUTPUT: + RETVAL + +int +set_verbose(env, which, onoff) + BerkeleyDB::Env env + u_int32_t which + int onoff + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3 + softCrash("$env->set_verbose needs Berkeley DB 3.x or better") ; +#else + RETVAL = env->Status = env->Env->set_verbose(env->Env, which, onoff); +#endif + OUTPUT: + RETVAL + +int +set_flags(env, flags, onoff) + BerkeleyDB::Env env + u_int32_t flags + int onoff + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3_2 + softCrash("$env->set_flags needs Berkeley DB 3.2.x or better") ; +#else + RETVAL = env->Status = env->Env->set_flags(env->Env, flags, onoff); +#endif + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Term PACKAGE = BerkeleyDB::Term + +void +close_everything() + +#define safeCroak(string) softCrash(string) +void +safeCroak(string) + char * string + +MODULE = BerkeleyDB::Hash PACKAGE = BerkeleyDB::Hash PREFIX = hash_ + +BerkeleyDB::Hash::Raw +_db_open_hash(self, ref) + char * self + SV * ref + CODE: + { + HV * hash ; + SV * sv ; + DB_INFO info ; + BerkeleyDB__Env dbenv = NULL; + SV * ref_dbenv = NULL; + const char * file = NULL ; + const char * subname = NULL ; + int flags = 0 ; + int mode = 0 ; + BerkeleyDB db ; + BerkeleyDB__Txn txn = NULL ; + + Trace(("_db_open_hash start\n")) ; + hash = (HV*) SvRV(ref) ; + SetValue_pv(file, "Filename", char *) ; + SetValue_pv(subname, "Subname", char *) ; + SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ; + SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ; + ref_dbenv = sv ; + SetValue_iv(flags, "Flags") ; + SetValue_iv(mode, "Mode") ; + + Zero(&info, 1, DB_INFO) ; + SetValue_iv(info.db_cachesize, "Cachesize") ; + SetValue_iv(info.db_lorder, "Lorder") ; + SetValue_iv(info.db_pagesize, "Pagesize") ; + SetValue_iv(info.h_ffactor, "Ffactor") ; + SetValue_iv(info.h_nelem, "Nelem") ; + SetValue_iv(info.flags, "Property") ; + ZMALLOC(db, BerkeleyDB_type) ; + if ((sv = readHash(hash, "Hash")) && sv != &PL_sv_undef) { + info.h_hash = hash_cb ; + db->hash = newSVsv(sv) ; + } + /* DB_DUPSORT was introduced in DB 2.5.9 */ + if ((sv = readHash(hash, "DupCompare")) && sv != &PL_sv_undef) { +#ifdef DB_DUPSORT + info.dup_compare = dup_compare ; + db->dup_compare = newSVsv(sv) ; + info.flags |= DB_DUP|DB_DUPSORT ; +#else + croak("DupCompare needs Berkeley DB 2.5.9 or later") ; +#endif + } + RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname, DB_HASH, flags, mode, &info) ; + Trace(("_db_open_hash end\n")) ; + } + OUTPUT: + RETVAL + + +HV * +db_stat(db, flags=0) + int flags + BerkeleyDB::Common db + HV * RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { +#if DB_VERSION_MAJOR == 2 + softCrash("$db->db_stat for a Hash needs Berkeley DB 3.x or better") ; +#else + DB_HASH_STAT * stat ; +#ifdef AT_LEAST_DB_3_3 + db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ; +#else + db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; +#endif + if (db->Status == 0) { + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "hash_magic", stat->hash_magic) ; + hv_store_iv(RETVAL, "hash_version", stat->hash_version); + hv_store_iv(RETVAL, "hash_pagesize", stat->hash_pagesize); +#ifdef AT_LEAST_DB_3_1 + hv_store_iv(RETVAL, "hash_nkeys", stat->hash_nkeys); + hv_store_iv(RETVAL, "hash_ndata", stat->hash_ndata); +#else + hv_store_iv(RETVAL, "hash_nrecs", stat->hash_nrecs); +#endif +#ifndef AT_LEAST_DB_3_1 + hv_store_iv(RETVAL, "hash_nelem", stat->hash_nelem); +#endif + hv_store_iv(RETVAL, "hash_ffactor", stat->hash_ffactor); + hv_store_iv(RETVAL, "hash_buckets", stat->hash_buckets); + hv_store_iv(RETVAL, "hash_free", stat->hash_free); + hv_store_iv(RETVAL, "hash_bfree", stat->hash_bfree); + hv_store_iv(RETVAL, "hash_bigpages", stat->hash_bigpages); + hv_store_iv(RETVAL, "hash_big_bfree", stat->hash_big_bfree); + hv_store_iv(RETVAL, "hash_overflows", stat->hash_overflows); + hv_store_iv(RETVAL, "hash_ovfl_free", stat->hash_ovfl_free); + hv_store_iv(RETVAL, "hash_dup", stat->hash_dup); + hv_store_iv(RETVAL, "hash_dup_free", stat->hash_dup_free); +#if DB_VERSION_MAJOR >= 3 + hv_store_iv(RETVAL, "hash_metaflags", stat->hash_metaflags); +#endif + safefree(stat) ; + } +#endif + } + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Unknown PACKAGE = BerkeleyDB::Unknown PREFIX = hash_ + +void +_db_open_unknown(ref) + SV * ref + PPCODE: + { + HV * hash ; + SV * sv ; + DB_INFO info ; + BerkeleyDB__Env dbenv = NULL; + SV * ref_dbenv = NULL; + const char * file = NULL ; + const char * subname = NULL ; + int flags = 0 ; + int mode = 0 ; + BerkeleyDB db ; + BerkeleyDB RETVAL ; + BerkeleyDB__Txn txn = NULL ; + static char * Names[] = {"", "Btree", "Hash", "Recno"} ; + + hash = (HV*) SvRV(ref) ; + SetValue_pv(file, "Filename", char *) ; + SetValue_pv(subname, "Subname", char *) ; + SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ; + SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ; + ref_dbenv = sv ; + SetValue_iv(flags, "Flags") ; + SetValue_iv(mode, "Mode") ; + + Zero(&info, 1, DB_INFO) ; + SetValue_iv(info.db_cachesize, "Cachesize") ; + SetValue_iv(info.db_lorder, "Lorder") ; + SetValue_iv(info.db_pagesize, "Pagesize") ; + SetValue_iv(info.h_ffactor, "Ffactor") ; + SetValue_iv(info.h_nelem, "Nelem") ; + SetValue_iv(info.flags, "Property") ; + ZMALLOC(db, BerkeleyDB_type) ; + + RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname, DB_UNKNOWN, flags, mode, &info) ; + XPUSHs(sv_2mortal(newSViv(PTR2IV(RETVAL)))); + if (RETVAL) + XPUSHs(sv_2mortal(newSVpv(Names[RETVAL->type], 0))) ; + else + XPUSHs(sv_2mortal(newSViv((IV)NULL))); + } + + + +MODULE = BerkeleyDB::Btree PACKAGE = BerkeleyDB::Btree PREFIX = btree_ + +BerkeleyDB::Btree::Raw +_db_open_btree(self, ref) + char * self + SV * ref + CODE: + { + HV * hash ; + SV * sv ; + DB_INFO info ; + BerkeleyDB__Env dbenv = NULL; + SV * ref_dbenv = NULL; + const char * file = NULL ; + const char * subname = NULL ; + int flags = 0 ; + int mode = 0 ; + BerkeleyDB db ; + BerkeleyDB__Txn txn = NULL ; + + Trace(("In _db_open_btree\n")); + hash = (HV*) SvRV(ref) ; + SetValue_pv(file, "Filename", char*) ; + SetValue_pv(subname, "Subname", char *) ; + SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ; + SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ; + ref_dbenv = sv ; + SetValue_iv(flags, "Flags") ; + SetValue_iv(mode, "Mode") ; + + Zero(&info, 1, DB_INFO) ; + SetValue_iv(info.db_cachesize, "Cachesize") ; + SetValue_iv(info.db_lorder, "Lorder") ; + SetValue_iv(info.db_pagesize, "Pagesize") ; + SetValue_iv(info.bt_minkey, "Minkey") ; + SetValue_iv(info.flags, "Property") ; + ZMALLOC(db, BerkeleyDB_type) ; + if ((sv = readHash(hash, "Compare")) && sv != &PL_sv_undef) { + Trace((" Parsed Compare callback\n")); + info.bt_compare = btree_compare ; + db->compare = newSVsv(sv) ; + } + /* DB_DUPSORT was introduced in DB 2.5.9 */ + if ((sv = readHash(hash, "DupCompare")) && sv != &PL_sv_undef) { +#ifdef DB_DUPSORT + Trace((" Parsed DupCompare callback\n")); + info.dup_compare = dup_compare ; + db->dup_compare = newSVsv(sv) ; + info.flags |= DB_DUP|DB_DUPSORT ; +#else + softCrash("DupCompare needs Berkeley DB 2.5.9 or later") ; +#endif + } + if ((sv = readHash(hash, "Prefix")) && sv != &PL_sv_undef) { + Trace((" Parsed Prefix callback\n")); + info.bt_prefix = btree_prefix ; + db->prefix = newSVsv(sv) ; + } + + RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname, DB_BTREE, flags, mode, &info) ; + } + OUTPUT: + RETVAL + + +HV * +db_stat(db, flags=0) + int flags + BerkeleyDB::Common db + HV * RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { + DB_BTREE_STAT * stat ; +#ifdef AT_LEAST_DB_3_3 + db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ; +#else + db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; +#endif + if (db->Status == 0) { + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "bt_magic", stat->bt_magic); + hv_store_iv(RETVAL, "bt_version", stat->bt_version); +#if DB_VERSION_MAJOR > 2 + hv_store_iv(RETVAL, "bt_metaflags", stat->bt_metaflags) ; + hv_store_iv(RETVAL, "bt_flags", stat->bt_metaflags) ; +#else + hv_store_iv(RETVAL, "bt_flags", stat->bt_flags) ; +#endif + hv_store_iv(RETVAL, "bt_maxkey", stat->bt_maxkey) ; + hv_store_iv(RETVAL, "bt_minkey", stat->bt_minkey); + hv_store_iv(RETVAL, "bt_re_len", stat->bt_re_len); + hv_store_iv(RETVAL, "bt_re_pad", stat->bt_re_pad); + hv_store_iv(RETVAL, "bt_pagesize", stat->bt_pagesize); + hv_store_iv(RETVAL, "bt_levels", stat->bt_levels); +#ifdef AT_LEAST_DB_3_1 + hv_store_iv(RETVAL, "bt_nkeys", stat->bt_nkeys); + hv_store_iv(RETVAL, "bt_ndata", stat->bt_ndata); +#else + hv_store_iv(RETVAL, "bt_nrecs", stat->bt_nrecs); +#endif + hv_store_iv(RETVAL, "bt_int_pg", stat->bt_int_pg); + hv_store_iv(RETVAL, "bt_leaf_pg", stat->bt_leaf_pg); + hv_store_iv(RETVAL, "bt_dup_pg", stat->bt_dup_pg); + hv_store_iv(RETVAL, "bt_over_pg", stat->bt_over_pg); + hv_store_iv(RETVAL, "bt_free", stat->bt_free); +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 + hv_store_iv(RETVAL, "bt_freed", stat->bt_freed); + hv_store_iv(RETVAL, "bt_pfxsaved", stat->bt_pfxsaved); + hv_store_iv(RETVAL, "bt_split", stat->bt_split); + hv_store_iv(RETVAL, "bt_rootsplit", stat->bt_rootsplit); + hv_store_iv(RETVAL, "bt_fastsplit", stat->bt_fastsplit); + hv_store_iv(RETVAL, "bt_added", stat->bt_added); + hv_store_iv(RETVAL, "bt_deleted", stat->bt_deleted); + hv_store_iv(RETVAL, "bt_get", stat->bt_get); + hv_store_iv(RETVAL, "bt_cache_hit", stat->bt_cache_hit); + hv_store_iv(RETVAL, "bt_cache_miss", stat->bt_cache_miss); +#endif + hv_store_iv(RETVAL, "bt_int_pgfree", stat->bt_int_pgfree); + hv_store_iv(RETVAL, "bt_leaf_pgfree", stat->bt_leaf_pgfree); + hv_store_iv(RETVAL, "bt_dup_pgfree", stat->bt_dup_pgfree); + hv_store_iv(RETVAL, "bt_over_pgfree", stat->bt_over_pgfree); + safefree(stat) ; + } + } + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Recno PACKAGE = BerkeleyDB::Recno PREFIX = recno_ + +BerkeleyDB::Recno::Raw +_db_open_recno(self, ref) + char * self + SV * ref + CODE: + { + HV * hash ; + SV * sv ; + DB_INFO info ; + BerkeleyDB__Env dbenv = NULL; + SV * ref_dbenv = NULL; + const char * file = NULL ; + const char * subname = NULL ; + int flags = 0 ; + int mode = 0 ; + BerkeleyDB db ; + BerkeleyDB__Txn txn = NULL ; + + hash = (HV*) SvRV(ref) ; + SetValue_pv(file, "Fname", char*) ; + SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ; + ref_dbenv = sv ; + SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ; + SetValue_iv(flags, "Flags") ; + SetValue_iv(mode, "Mode") ; + + Zero(&info, 1, DB_INFO) ; + SetValue_iv(info.db_cachesize, "Cachesize") ; + SetValue_iv(info.db_lorder, "Lorder") ; + SetValue_iv(info.db_pagesize, "Pagesize") ; + SetValue_iv(info.bt_minkey, "Minkey") ; + + SetValue_iv(info.flags, "Property") ; + SetValue_pv(info.re_source, "Source", char*) ; + if ((sv = readHash(hash, "Len")) && sv != &PL_sv_undef) { + info.re_len = SvIV(sv) ; ; + flagSet_DB2(info.flags, DB_FIXEDLEN) ; + } + if ((sv = readHash(hash, "Delim")) && sv != &PL_sv_undef) { + info.re_delim = SvPOK(sv) ? *SvPV(sv,PL_na) : SvIV(sv) ; ; + flagSet_DB2(info.flags, DB_DELIMITER) ; + } + if ((sv = readHash(hash, "Pad")) && sv != &PL_sv_undef) { + info.re_pad = (u_int32_t)SvPOK(sv) ? *SvPV(sv,PL_na) : SvIV(sv) ; ; + flagSet_DB2(info.flags, DB_PAD) ; + } + ZMALLOC(db, BerkeleyDB_type) ; +#ifdef ALLOW_RECNO_OFFSET + SetValue_iv(db->array_base, "ArrayBase") ; + db->array_base = (db->array_base == 0 ? 1 : 0) ; +#endif /* ALLOW_RECNO_OFFSET */ + + RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname, DB_RECNO, flags, mode, &info) ; + } + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Queue PACKAGE = BerkeleyDB::Queue PREFIX = recno_ + +BerkeleyDB::Queue::Raw +_db_open_queue(self, ref) + char * self + SV * ref + CODE: + { +#ifndef AT_LEAST_DB_3 + softCrash("BerkeleyDB::Queue needs Berkeley DB 3.0.x or better"); +#else + HV * hash ; + SV * sv ; + DB_INFO info ; + BerkeleyDB__Env dbenv = NULL; + SV * ref_dbenv = NULL; + const char * file = NULL ; + const char * subname = NULL ; + int flags = 0 ; + int mode = 0 ; + BerkeleyDB db ; + BerkeleyDB__Txn txn = NULL ; + + hash = (HV*) SvRV(ref) ; + SetValue_pv(file, "Fname", char*) ; + SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ; + ref_dbenv = sv ; + SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ; + SetValue_iv(flags, "Flags") ; + SetValue_iv(mode, "Mode") ; + + Zero(&info, 1, DB_INFO) ; + SetValue_iv(info.db_cachesize, "Cachesize") ; + SetValue_iv(info.db_lorder, "Lorder") ; + SetValue_iv(info.db_pagesize, "Pagesize") ; + SetValue_iv(info.bt_minkey, "Minkey") ; + SetValue_iv(info.q_extentsize, "ExtentSize") ; + + + SetValue_iv(info.flags, "Property") ; + if ((sv = readHash(hash, "Len")) && sv != &PL_sv_undef) { + info.re_len = SvIV(sv) ; ; + flagSet_DB2(info.flags, DB_FIXEDLEN) ; + } + if ((sv = readHash(hash, "Pad")) && sv != &PL_sv_undef) { + info.re_pad = (u_int32_t)SvPOK(sv) ? *SvPV(sv,PL_na) : SvIV(sv) ; ; + flagSet_DB2(info.flags, DB_PAD) ; + } + ZMALLOC(db, BerkeleyDB_type) ; +#ifdef ALLOW_RECNO_OFFSET + SetValue_iv(db->array_base, "ArrayBase") ; + db->array_base = (db->array_base == 0 ? 1 : 0) ; +#endif /* ALLOW_RECNO_OFFSET */ + + RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname, DB_QUEUE, flags, mode, &info) ; +#endif + } + OUTPUT: + RETVAL + +HV * +db_stat(db, flags=0) + int flags + BerkeleyDB::Common db + HV * RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { +#if DB_VERSION_MAJOR == 2 + softCrash("$db->db_stat for a Queue needs Berkeley DB 3.x or better") ; +#else /* Berkeley DB 3, or better */ + DB_QUEUE_STAT * stat ; +#ifdef AT_LEAST_DB_3_3 + db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ; +#else + db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; +#endif + if (db->Status == 0) { + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "qs_magic", stat->qs_magic) ; + hv_store_iv(RETVAL, "qs_version", stat->qs_version); +#ifdef AT_LEAST_DB_3_1 + hv_store_iv(RETVAL, "qs_nkeys", stat->qs_nkeys); + hv_store_iv(RETVAL, "qs_ndata", stat->qs_ndata); +#else + hv_store_iv(RETVAL, "qs_nrecs", stat->qs_nrecs); +#endif + hv_store_iv(RETVAL, "qs_pages", stat->qs_pages); + hv_store_iv(RETVAL, "qs_pagesize", stat->qs_pagesize); + hv_store_iv(RETVAL, "qs_pgfree", stat->qs_pgfree); + hv_store_iv(RETVAL, "qs_re_len", stat->qs_re_len); + hv_store_iv(RETVAL, "qs_re_pad", stat->qs_re_pad); +#ifdef AT_LEAST_DB_3_2 +#else + hv_store_iv(RETVAL, "qs_start", stat->qs_start); +#endif + hv_store_iv(RETVAL, "qs_first_recno", stat->qs_first_recno); + hv_store_iv(RETVAL, "qs_cur_recno", stat->qs_cur_recno); +#if DB_VERSION_MAJOR >= 3 + hv_store_iv(RETVAL, "qs_metaflags", stat->qs_metaflags); +#endif + safefree(stat) ; + } +#endif + } + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Common PACKAGE = BerkeleyDB::Common PREFIX = dab_ + + +DualType +db_close(db,flags=0) + int flags + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CurrentDB = db ; + CODE: + Trace(("BerkeleyDB::Common::db_close %d\n", db)); +#ifdef STRICT_CLOSE + if (db->txn) + softCrash("attempted to close a database while a transaction was still open") ; + if (db->open_cursors) + softCrash("attempted to close a database with %d open cursor(s)", + db->open_cursors) ; +#endif /* STRICT_CLOSE */ + RETVAL = db->Status = ((db->dbp)->close)(db->dbp, flags) ; + if (db->parent_env && db->parent_env->open_dbs) + -- db->parent_env->open_dbs ; + db->active = FALSE ; + hash_delete("BerkeleyDB::Term::Db", (char *)db) ; + -- db->open_cursors ; + Trace(("end of BerkeleyDB::Common::db_close\n")); + OUTPUT: + RETVAL + +void +dab__DESTROY(db) + BerkeleyDB::Common db + CODE: + CurrentDB = db ; + Trace(("In BerkeleyDB::Common::_DESTROY db %d dirty=%d\n", db, PL_dirty)) ; + destroyDB(db) ; + Trace(("End of BerkeleyDB::Common::DESTROY \n")) ; + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 +#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur) +#else +#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur,flags) +#endif +BerkeleyDB::Cursor::Raw +_db_cursor(db, flags=0) + u_int32_t flags + BerkeleyDB::Common db + BerkeleyDB::Cursor RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { + DBC * cursor ; + CurrentDB = db ; + if ((db->Status = db_cursor(db, db->txn, &cursor, flags)) == 0){ + ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ; + db->open_cursors ++ ; + RETVAL->parent_db = db ; + RETVAL->cursor = cursor ; + RETVAL->dbp = db->dbp ; + RETVAL->txn = db->txn ; + RETVAL->type = db->type ; + RETVAL->recno_or_queue = db->recno_or_queue ; + RETVAL->filename = my_strdup(db->filename) ; + RETVAL->compare = db->compare ; + RETVAL->dup_compare = db->dup_compare ; +#ifdef AT_LEAST_DB_3_3 + RETVAL->associated = db->associated ; + RETVAL->secondary_db = db->secondary_db; +#endif + RETVAL->prefix = db->prefix ; + RETVAL->hash = db->hash ; + RETVAL->partial = db->partial ; + RETVAL->doff = db->doff ; + RETVAL->dlen = db->dlen ; + RETVAL->active = TRUE ; +#ifdef ALLOW_RECNO_OFFSET + RETVAL->array_base = db->array_base ; +#endif /* ALLOW_RECNO_OFFSET */ +#ifdef DBM_FILTERING + RETVAL->filtering = FALSE ; + RETVAL->filter_fetch_key = db->filter_fetch_key ; + RETVAL->filter_store_key = db->filter_store_key ; + RETVAL->filter_fetch_value = db->filter_fetch_value ; + RETVAL->filter_store_value = db->filter_store_value ; +#endif + /* RETVAL->info ; */ + hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ; + } + } + OUTPUT: + RETVAL + +BerkeleyDB::Cursor::Raw +_db_join(db, cursors, flags=0) + u_int32_t flags + BerkeleyDB::Common db + AV * cursors + BerkeleyDB::Cursor RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { +#if DB_VERSION_MAJOR == 2 && (DB_VERSION_MINOR < 5 || (DB_VERSION_MINOR == 5 && DB_VERSION_PATCH < 2)) + softCrash("join needs Berkeley DB 2.5.2 or later") ; +#else /* Berkeley DB >= 2.5.2 */ + DBC * join_cursor ; + DBC ** cursor_list ; + I32 count = av_len(cursors) + 1 ; + int i ; + CurrentDB = db ; + if (count < 1 ) + softCrash("db_join: No cursors in parameter list") ; + cursor_list = (DBC **)safemalloc(sizeof(DBC*) * (count + 1)); + for (i = 0 ; i < count ; ++i) { + SV * obj = (SV*) * av_fetch(cursors, i, FALSE) ; + IV tmp = SvIV(getInnerObject(obj)) ; + BerkeleyDB__Cursor cur = INT2PTR(BerkeleyDB__Cursor, tmp); + cursor_list[i] = cur->cursor ; + } + cursor_list[i] = NULL ; +#if DB_VERSION_MAJOR == 2 + if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, flags, &join_cursor)) == 0){ +#else + if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, &join_cursor, flags)) == 0){ +#endif + ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ; + db->open_cursors ++ ; + RETVAL->parent_db = db ; + RETVAL->cursor = join_cursor ; + RETVAL->dbp = db->dbp ; + RETVAL->type = db->type ; + RETVAL->filename = my_strdup(db->filename) ; + RETVAL->compare = db->compare ; + RETVAL->dup_compare = db->dup_compare ; +#ifdef AT_LEAST_DB_3_3 + RETVAL->associated = db->associated ; + RETVAL->secondary_db = db->secondary_db; +#endif + RETVAL->prefix = db->prefix ; + RETVAL->hash = db->hash ; + RETVAL->partial = db->partial ; + RETVAL->doff = db->doff ; + RETVAL->dlen = db->dlen ; + RETVAL->active = TRUE ; +#ifdef ALLOW_RECNO_OFFSET + RETVAL->array_base = db->array_base ; +#endif /* ALLOW_RECNO_OFFSET */ +#ifdef DBM_FILTERING + RETVAL->filtering = FALSE ; + RETVAL->filter_fetch_key = db->filter_fetch_key ; + RETVAL->filter_store_key = db->filter_store_key ; + RETVAL->filter_fetch_value = db->filter_fetch_value ; + RETVAL->filter_store_value = db->filter_store_value ; +#endif + /* RETVAL->info ; */ + hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ; + } + safefree(cursor_list) ; +#endif /* Berkeley DB >= 2.5.2 */ + } + OUTPUT: + RETVAL + +int +ArrayOffset(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: +#ifdef ALLOW_RECNO_OFFSET + RETVAL = db->array_base ? 0 : 1 ; +#else + RETVAL = 0 ; +#endif /* ALLOW_RECNO_OFFSET */ + OUTPUT: + RETVAL + +int +type(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: + RETVAL = db->type ; + OUTPUT: + RETVAL + +int +byteswapped(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 + softCrash("byteswapped needs Berkeley DB 2.5 or later") ; +#else +#if DB_VERSION_MAJOR == 2 + RETVAL = db->dbp->byteswapped ; +#else +#ifdef AT_LEAST_DB_3_3 + db->dbp->get_byteswapped(db->dbp, &RETVAL) ; +#else + RETVAL = db->dbp->get_byteswapped(db->dbp) ; +#endif +#endif +#endif + OUTPUT: + RETVAL + +DualType +status(db) + BerkeleyDB::Common db + CODE: + RETVAL = db->Status ; + OUTPUT: + RETVAL + +#ifdef DBM_FILTERING + +#define setFilter(ftype) \ + { \ + if (db->ftype) \ + RETVAL = sv_mortalcopy(db->ftype) ; \ + ST(0) = RETVAL ; \ + if (db->ftype && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->ftype) ; \ + db->ftype = NULL ; \ + } \ + else if (code) { \ + if (db->ftype) \ + sv_setsv(db->ftype, code) ; \ + else \ + db->ftype = newSVsv(code) ; \ + } \ + } + + +SV * +filter_fetch_key(db, code) + BerkeleyDB::Common db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_key, code) ; + +SV * +filter_store_key(db, code) + BerkeleyDB::Common db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_key, code) ; + +SV * +filter_fetch_value(db, code) + BerkeleyDB::Common db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_value, code) ; + +SV * +filter_store_value(db, code) + BerkeleyDB::Common db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_value, code) ; + +#endif /* DBM_FILTERING */ + +void +partial_set(db, offset, length) + BerkeleyDB::Common db + u_int32_t offset + u_int32_t length + INIT: + ckActive_Database(db->active) ; + PPCODE: + if (GIMME == G_ARRAY) { + XPUSHs(sv_2mortal(newSViv(db->partial == DB_DBT_PARTIAL))) ; + XPUSHs(sv_2mortal(newSViv(db->doff))) ; + XPUSHs(sv_2mortal(newSViv(db->dlen))) ; + } + db->partial = DB_DBT_PARTIAL ; + db->doff = offset ; + db->dlen = length ; + + +void +partial_clear(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + PPCODE: + if (GIMME == G_ARRAY) { + XPUSHs(sv_2mortal(newSViv(db->partial == DB_DBT_PARTIAL))) ; + XPUSHs(sv_2mortal(newSViv(db->doff))) ; + XPUSHs(sv_2mortal(newSViv(db->dlen))) ; + } + db->partial = + db->doff = + db->dlen = 0 ; + + +#define db_del(db, key, flags) \ + (db->Status = ((db->dbp)->del)(db->dbp, db->txn, &key, flags)) +DualType +db_del(db, key, flags=0) + u_int flags + BerkeleyDB::Common db + DBTKEY key + INIT: + Trace(("db_del db[%p] in [%p] txn[%p] key[%.*s] flags[%d]\n", db->dbp, db, db->txn, key.size, key.data, flags)) ; + ckActive_Database(db->active) ; + CurrentDB = db ; + + +#ifdef AT_LEAST_DB_3 +# ifdef AT_LEAST_DB_3_2 +# define writeToKey() (flagSet(DB_CONSUME)||flagSet(DB_CONSUME_WAIT)||flagSet(DB_GET_BOTH)||flagSet(DB_SET_RECNO)) +# else +# define writeToKey() (flagSet(DB_CONSUME)||flagSet(DB_GET_BOTH)||flagSet(DB_SET_RECNO)) +# endif +#else +#define writeToKey() (flagSet(DB_GET_BOTH)||flagSet(DB_SET_RECNO)) +#endif +#define db_get(db, key, data, flags) \ + (db->Status = ((db->dbp)->get)(db->dbp, db->txn, &key, &data, flags)) +DualType +db_get(db, key, data, flags=0) + u_int flags + BerkeleyDB::Common db + DBTKEY_B key + DBT_OPT data + CODE: + ckActive_Database(db->active) ; + CurrentDB = db ; + SetPartial(data,db) ; + Trace(("db_get db[%p] in [%p] txn[%p] key [%.*s] flags[%d]\n", db->dbp, db, db->txn, key.size, key.data, flags)) ; + RETVAL = db_get(db, key, data, flags); + Trace((" RETVAL %d\n", RETVAL)); + OUTPUT: + RETVAL + key if (writeToKey()) OutputKey(ST(1), key) ; + data + +#define db_pget(db, key, pkey, data, flags) \ + (db->Status = ((db->dbp)->pget)(db->dbp, db->txn, &key, &pkey, &data, flags)) +DualType +db_pget(db, key, pkey, data, flags=0) + u_int flags + BerkeleyDB::Common db + DBTKEY_B key + DBTKEY_B pkey = NO_INIT + DBT_OPT data + CODE: +#ifndef AT_LEAST_DB_3_3 + softCrash("db_pget needs at least Berkeley DB 3.3"); +#else + Trace(("db_pget db [%p] in [%p] txn [%p] flags [%d]\n", db->dbp, db, db->txn, flags)) ; + ckActive_Database(db->active) ; + CurrentDB = db ; + SetPartial(data,db) ; + DBT_clear(pkey); + RETVAL = db_pget(db, key, pkey, data, flags); + Trace((" RETVAL %d\n", RETVAL)); +#endif + OUTPUT: + RETVAL + key if (writeToKey()) OutputKey(ST(1), key) ; + pkey + data + +#define db_put(db,key,data,flag) \ + (db->Status = (db->dbp->put)(db->dbp,db->txn,&key,&data,flag)) +DualType +db_put(db, key, data, flags=0) + u_int flags + BerkeleyDB::Common db + DBTKEY key + DBT data + CODE: + ckActive_Database(db->active) ; + CurrentDB = db ; + /* SetPartial(data,db) ; */ + Trace(("db_put db[%p] in [%p] txn[%p] key[%.*s] data [%.*s] flags[%d]\n", db->dbp, db, db->txn, key.size, key.data, data.size, data.data, flags)) ; + RETVAL = db_put(db, key, data, flags); + Trace((" RETVAL %d\n", RETVAL)); + OUTPUT: + RETVAL + key if (flagSet(DB_APPEND)) OutputKey(ST(1), key) ; + +#define db_key_range(db, key, range, flags) \ + (db->Status = ((db->dbp)->key_range)(db->dbp, db->txn, &key, &range, flags)) +DualType +db_key_range(db, key, less, equal, greater, flags=0) + u_int32_t flags + BerkeleyDB::Common db + DBTKEY_B key + double less = 0.0 ; + double equal = 0.0 ; + double greater = 0.0 ; + CODE: + { +#ifndef AT_LEAST_DB_3_1 + softCrash("key_range needs Berkeley DB 3.1.x or later") ; +#else + DB_KEY_RANGE range ; + range.less = range.equal = range.greater = 0.0 ; + ckActive_Database(db->active) ; + CurrentDB = db ; + RETVAL = db_key_range(db, key, range, flags); + if (RETVAL == 0) { + less = range.less ; + equal = range.equal; + greater = range.greater; + } +#endif + } + OUTPUT: + RETVAL + less + equal + greater + + +#define db_fd(d, x) (db->Status = (db->dbp->fd)(db->dbp, &x)) +DualType +db_fd(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: + CurrentDB = db ; + db_fd(db, RETVAL) ; + OUTPUT: + RETVAL + + +#define db_sync(db, fl) (db->Status = (db->dbp->sync)(db->dbp, fl)) +DualType +db_sync(db, flags=0) + u_int flags + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CurrentDB = db ; + +void +_Txn(db, txn=NULL) + BerkeleyDB::Common db + BerkeleyDB::Txn txn + INIT: + ckActive_Database(db->active) ; + CODE: + if (txn) { + Trace(("_Txn[%p] in[%p] active [%d]\n", txn->txn, txn, txn->active)); + ckActive_Transaction(txn->active) ; + db->txn = txn->txn ; + } + else { + Trace(("_Txn[undef] \n")); + db->txn = NULL ; + } + + +#define db_truncate(db, countp, flags) \ + (db->Status = ((db->dbp)->truncate)(db->dbp, db->txn, &countp, flags)) +DualType +truncate(db, countp, flags=0) + BerkeleyDB::Common db + u_int32_t countp + u_int32_t flags + INIT: + ckActive_Database(db->active) ; + CODE: +#ifndef AT_LEAST_DB_3_3 + softCrash("truncate needs Berkeley DB 3.3 or later") ; +#else + CurrentDB = db ; + RETVAL = db_truncate(db, countp, flags); +#endif + OUTPUT: + RETVAL + countp + +#ifdef AT_LEAST_DB_4_1 +# define db_associate(db, sec, cb, flags)\ + (db->Status = ((db->dbp)->associate)(db->dbp, NULL, sec->dbp, &cb, flags)) +#else +# define db_associate(db, sec, cb, flags)\ + (db->Status = ((db->dbp)->associate)(db->dbp, sec->dbp, &cb, flags)) +#endif +DualType +associate(db, secondary, callback, flags=0) + BerkeleyDB::Common db + BerkeleyDB::Common secondary + SV* callback + u_int32_t flags + INIT: + ckActive_Database(db->active) ; + CODE: +#ifndef AT_LEAST_DB_3_3 + softCrash("associate needs Berkeley DB 3.3 or later") ; +#else + CurrentDB = db ; + /* db->associated = newSVsv(callback) ; */ + secondary->associated = newSVsv(callback) ; + /* secondary->dbp->app_private = secondary->associated ; */ + secondary->secondary_db = TRUE; + RETVAL = db_associate(db, secondary, associate_cb, flags); +#endif + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Cursor PACKAGE = BerkeleyDB::Cursor PREFIX = cu_ + +BerkeleyDB::Cursor::Raw +_c_dup(db, flags=0) + u_int32_t flags + BerkeleyDB::Cursor db + BerkeleyDB::Cursor RETVAL = NULL ; + INIT: + CurrentDB = db->parent_db ; + ckActive_Database(db->active) ; + CODE: + { +#ifndef AT_LEAST_DB_3 + softCrash("c_dup needs at least Berkeley DB 3.0.x"); +#else + DBC * newcursor ; + db->Status = ((db->cursor)->c_dup)(db->cursor, &newcursor, flags) ; + if (db->Status == 0){ + ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ; + db->parent_db->open_cursors ++ ; + RETVAL->parent_db = db->parent_db ; + RETVAL->cursor = newcursor ; + RETVAL->dbp = db->dbp ; + RETVAL->type = db->type ; + RETVAL->recno_or_queue = db->recno_or_queue ; + RETVAL->filename = my_strdup(db->filename) ; + RETVAL->compare = db->compare ; + RETVAL->dup_compare = db->dup_compare ; +#ifdef AT_LEAST_DB_3_3 + RETVAL->associated = db->associated ; +#endif + RETVAL->prefix = db->prefix ; + RETVAL->hash = db->hash ; + RETVAL->partial = db->partial ; + RETVAL->doff = db->doff ; + RETVAL->dlen = db->dlen ; + RETVAL->active = TRUE ; +#ifdef ALLOW_RECNO_OFFSET + RETVAL->array_base = db->array_base ; +#endif /* ALLOW_RECNO_OFFSET */ +#ifdef DBM_FILTERING + RETVAL->filtering = FALSE ; + RETVAL->filter_fetch_key = db->filter_fetch_key ; + RETVAL->filter_store_key = db->filter_store_key ; + RETVAL->filter_fetch_value = db->filter_fetch_value ; + RETVAL->filter_store_value = db->filter_store_value ; +#endif /* DBM_FILTERING */ + /* RETVAL->info ; */ + hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ; + } +#endif + } + OUTPUT: + RETVAL + +DualType +_c_close(db) + BerkeleyDB::Cursor db + INIT: + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ; + CODE: + RETVAL = db->Status = + ((db->cursor)->c_close)(db->cursor) ; + db->active = FALSE ; + if (db->parent_db->open_cursors) + -- db->parent_db->open_cursors ; + OUTPUT: + RETVAL + +void +_DESTROY(db) + BerkeleyDB::Cursor db + CODE: + CurrentDB = db->parent_db ; + Trace(("In BerkeleyDB::Cursor::_DESTROY db %d dirty=%d active=%d\n", db, PL_dirty, db->active)); + hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ; + if (db->active) + ((db->cursor)->c_close)(db->cursor) ; + if (db->parent_db->open_cursors) + -- db->parent_db->open_cursors ; + Safefree(db->filename) ; + Safefree(db) ; + Trace(("End of BerkeleyDB::Cursor::_DESTROY\n")) ; + +DualType +status(db) + BerkeleyDB::Cursor db + CODE: + RETVAL = db->Status ; + OUTPUT: + RETVAL + + +#define cu_c_del(c,f) (c->Status = ((c->cursor)->c_del)(c->cursor,f)) +DualType +cu_c_del(db, flags=0) + int flags + BerkeleyDB::Cursor db + INIT: + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + OUTPUT: + RETVAL + + +#define cu_c_get(c,k,d,f) (c->Status = (c->cursor->c_get)(c->cursor,&k,&d,f)) +DualType +cu_c_get(db, key, data, flags=0) + int flags + BerkeleyDB::Cursor db + DBTKEY_B key + DBT_B data + INIT: + Trace(("c_get db [%p] in [%p] flags [%d]\n", db->dbp, db, flags)) ; + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + SetPartial(data,db) ; + Trace(("c_get end\n")) ; + OUTPUT: + RETVAL + key + data if (! flagSet(DB_JOIN_ITEM)) OutputValue_B(ST(2), data) ; + +#define cu_c_pget(c,k,p,d,f) (c->Status = (c->secondary_db ? (c->cursor->c_pget)(c->cursor,&k,&p,&d,f) : EINVAL)) +DualType +cu_c_pget(db, key, pkey, data, flags=0) + int flags + BerkeleyDB::Cursor db + DBTKEY_B key + DBTKEY_B pkey = NO_INIT + DBT_B data + CODE: +#ifndef AT_LEAST_DB_3_3 + softCrash("db_c_pget needs at least Berkeley DB 3.3"); +#else + Trace(("c_pget db [%d] flags [%d]\n", db, flags)) ; + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + SetPartial(data,db) ; + DBT_clear(pkey); + RETVAL = cu_c_pget(db, key, pkey, data, flags); + Trace(("c_pget end\n")) ; +#endif + OUTPUT: + RETVAL + key + pkey + data if (! flagSet(DB_JOIN_ITEM)) OutputValue_B(ST(2), data) ; + + + +#define cu_c_put(c,k,d,f) (c->Status = (c->cursor->c_put)(c->cursor,&k,&d,f)) +DualType +cu_c_put(db, key, data, flags=0) + int flags + BerkeleyDB::Cursor db + DBTKEY key + DBT data + INIT: + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + /* SetPartial(data,db) ; */ + OUTPUT: + RETVAL + +#define cu_c_count(c,p,f) (c->Status = (c->cursor->c_count)(c->cursor,&p,f)) +DualType +cu_c_count(db, count, flags=0) + int flags + BerkeleyDB::Cursor db + u_int32_t count = NO_INIT + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("c_count needs at least Berkeley DB 3.1.x"); +#else + Trace(("c_get count [%d] flags [%d]\n", db, flags)) ; + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + RETVAL = cu_c_count(db, count, flags) ; + Trace((" c_count got %d duplicates\n", count)) ; +#endif + OUTPUT: + RETVAL + count + +MODULE = BerkeleyDB::TxnMgr PACKAGE = BerkeleyDB::TxnMgr PREFIX = xx_ + +BerkeleyDB::Txn::Raw +_txn_begin(txnmgr, pid=NULL, flags=0) + u_int32_t flags + BerkeleyDB::TxnMgr txnmgr + BerkeleyDB::Txn pid + CODE: + { + DB_TXN *txn ; + DB_TXN *p_id = NULL ; +#if DB_VERSION_MAJOR == 2 + if (txnmgr->env->Env->tx_info == NULL) + softCrash("Transaction Manager not enabled") ; +#endif + if (pid) + p_id = pid->txn ; + txnmgr->env->TxnMgrStatus = +#if DB_VERSION_MAJOR == 2 + txn_begin(txnmgr->env->Env->tx_info, p_id, &txn) ; +#else +# ifdef AT_LEAST_DB_4 + txnmgr->env->Env->txn_begin(txnmgr->env->Env, p_id, &txn, flags) ; +# else + txn_begin(txnmgr->env->Env, p_id, &txn, flags) ; +# endif +#endif + if (txnmgr->env->TxnMgrStatus == 0) { + ZMALLOC(RETVAL, BerkeleyDB_Txn_type) ; + RETVAL->txn = txn ; + RETVAL->active = TRUE ; + Trace(("_txn_begin created txn [%d] in [%d]\n", txn, RETVAL)); + hash_store_iv("BerkeleyDB::Term::Txn", (char *)RETVAL, 1) ; + } + else + RETVAL = NULL ; + } + OUTPUT: + RETVAL + + +DualType +status(mgr) + BerkeleyDB::TxnMgr mgr + CODE: + RETVAL = mgr->env->TxnMgrStatus ; + OUTPUT: + RETVAL + + +void +_DESTROY(mgr) + BerkeleyDB::TxnMgr mgr + CODE: + Trace(("In BerkeleyDB::TxnMgr::DESTROY dirty=%d\n", PL_dirty)) ; + Safefree(mgr) ; + Trace(("End of BerkeleyDB::TxnMgr::DESTROY\n")) ; + +DualType +txn_close(txnp) + BerkeleyDB::TxnMgr txnp + NOT_IMPLEMENTED_YET + + +#if DB_VERSION_MAJOR == 2 +# define xx_txn_checkpoint(t,k,m,f) txn_checkpoint(t->env->Env->tx_info, k, m) +#else +# ifdef AT_LEAST_DB_4 +# define xx_txn_checkpoint(e,k,m,f) e->env->Env->txn_checkpoint(e->env->Env, k, m, f) +# else +# ifdef AT_LEAST_DB_3_1 +# define xx_txn_checkpoint(t,k,m,f) txn_checkpoint(t->env->Env, k, m, 0) +# else +# define xx_txn_checkpoint(t,k,m,f) txn_checkpoint(t->env->Env, k, m) +# endif +# endif +#endif +DualType +xx_txn_checkpoint(txnp, kbyte, min, flags=0) + BerkeleyDB::TxnMgr txnp + long kbyte + long min + u_int32_t flags + +HV * +txn_stat(txnp) + BerkeleyDB::TxnMgr txnp + HV * RETVAL = NULL ; + CODE: + { + DB_TXN_STAT * stat ; +#ifdef AT_LEAST_DB_4 + if(txnp->env->Env->txn_stat(txnp->env->Env, &stat, 0) == 0) { +#else +# ifdef AT_LEAST_DB_3_3 + if(txn_stat(txnp->env->Env, &stat) == 0) { +# else +# if DB_VERSION_MAJOR == 2 + if(txn_stat(txnp->env->Env->tx_info, &stat, safemalloc) == 0) { +# else + if(txn_stat(txnp->env->Env, &stat, safemalloc) == 0) { +# endif +# endif +#endif + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "st_time_ckp", stat->st_time_ckp) ; + hv_store_iv(RETVAL, "st_last_txnid", stat->st_last_txnid) ; + hv_store_iv(RETVAL, "st_maxtxns", stat->st_maxtxns) ; + hv_store_iv(RETVAL, "st_naborts", stat->st_naborts) ; + hv_store_iv(RETVAL, "st_nbegins", stat->st_nbegins) ; + hv_store_iv(RETVAL, "st_ncommits", stat->st_ncommits) ; + hv_store_iv(RETVAL, "st_nactive", stat->st_nactive) ; +#if DB_VERSION_MAJOR > 2 + hv_store_iv(RETVAL, "st_maxnactive", stat->st_maxnactive) ; + hv_store_iv(RETVAL, "st_regsize", stat->st_regsize) ; + hv_store_iv(RETVAL, "st_region_wait", stat->st_region_wait) ; + hv_store_iv(RETVAL, "st_region_nowait", stat->st_region_nowait) ; +#endif + safefree(stat) ; + } + } + OUTPUT: + RETVAL + + +BerkeleyDB::TxnMgr +txn_open(dir, flags, mode, dbenv) + int flags + const char * dir + int mode + BerkeleyDB::Env dbenv + NOT_IMPLEMENTED_YET + + +MODULE = BerkeleyDB::Txn PACKAGE = BerkeleyDB::Txn PREFIX = xx_ + +DualType +status(tid) + BerkeleyDB::Txn tid + CODE: + RETVAL = tid->Status ; + OUTPUT: + RETVAL + +int +_DESTROY(tid) + BerkeleyDB::Txn tid + CODE: + Trace(("In BerkeleyDB::Txn::_DESTROY txn [%d] active [%d] dirty=%d\n", tid->txn, tid->active, PL_dirty)) ; + if (tid->active) +#ifdef AT_LEAST_DB_4 + tid->txn->abort(tid->txn) ; +#else + txn_abort(tid->txn) ; +#endif + RETVAL = (int)tid ; + hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ; + Safefree(tid) ; + Trace(("End of BerkeleyDB::Txn::DESTROY\n")) ; + OUTPUT: + RETVAL + +#define xx_txn_unlink(d,f,e) txn_unlink(d,f,&(e->Env)) +DualType +xx_txn_unlink(dir, force, dbenv) + const char * dir + int force + BerkeleyDB::Env dbenv + NOT_IMPLEMENTED_YET + +#ifdef AT_LEAST_DB_4 +# define xx_txn_prepare(t) (t->Status = t->txn->prepare(t->txn, 0)) +#else +# ifdef AT_LEAST_DB_3_3 +# define xx_txn_prepare(t) (t->Status = txn_prepare(t->txn, 0)) +# else +# define xx_txn_prepare(t) (t->Status = txn_prepare(t->txn)) +# endif +#endif +DualType +xx_txn_prepare(tid) + BerkeleyDB::Txn tid + INIT: + ckActive_Transaction(tid->active) ; + +#ifdef AT_LEAST_DB_4 +# define _txn_commit(t,flags) (t->Status = t->txn->commit(t->txn, flags)) +#else +# if DB_VERSION_MAJOR == 2 +# define _txn_commit(t,flags) (t->Status = txn_commit(t->txn)) +# else +# define _txn_commit(t, flags) (t->Status = txn_commit(t->txn, flags)) +# endif +#endif +DualType +_txn_commit(tid, flags=0) + u_int32_t flags + BerkeleyDB::Txn tid + INIT: + ckActive_Transaction(tid->active) ; + hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ; + tid->active = FALSE ; + +#ifdef AT_LEAST_DB_4 +# define _txn_abort(t) (t->Status = t->txn->abort(t->txn)) +#else +# define _txn_abort(t) (t->Status = txn_abort(t->txn)) +#endif +DualType +_txn_abort(tid) + BerkeleyDB::Txn tid + INIT: + ckActive_Transaction(tid->active) ; + hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ; + tid->active = FALSE ; + +#ifdef AT_LEAST_DB_4 +# define _txn_discard(t,f) (t->Status = t->txn->discard(t->txn, f)) +#else +# ifdef AT_LEAST_DB_3_3_4 +# define _txn_discard(t,f) (t->Status = txn_discard(t->txn, f)) +# else +# define _txn_discard(t,f) (int)softCrash("txn_discard needs Berkeley DB 3.3.4 or better") ; +# endif +#endif +DualType +_txn_discard(tid, flags=0) + BerkeleyDB::Txn tid + u_int32_t flags + INIT: + ckActive_Transaction(tid->active) ; + hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ; + tid->active = FALSE ; + +#ifdef AT_LEAST_DB_4 +# define xx_txn_id(t) t->txn->id(t->txn) +#else +# define xx_txn_id(t) txn_id(t->txn) +#endif +u_int32_t +xx_txn_id(tid) + BerkeleyDB::Txn tid + +MODULE = BerkeleyDB::_tiedHash PACKAGE = BerkeleyDB::_tiedHash + +int +FIRSTKEY(db) + BerkeleyDB::Common db + CODE: + { + DBTKEY key ; + DBT value ; + DBC * cursor ; + + /* + TODO! + set partial value to 0 - to eliminate the retrieval of + the value need to store any existing partial settings & + restore at the end. + + */ + CurrentDB = db ; + DBT_clear(key) ; + DBT_clear(value) ; + /* If necessary create a cursor for FIRSTKEY/NEXTKEY use */ + if (!db->cursor && + (db->Status = db_cursor(db, db->txn, &cursor, 0)) == 0 ) + db->cursor = cursor ; + + if (db->cursor) + RETVAL = (db->Status) = + ((db->cursor)->c_get)(db->cursor, &key, &value, DB_FIRST); + else + RETVAL = db->Status ; + /* check for end of cursor */ + if (RETVAL == DB_NOTFOUND) { + ((db->cursor)->c_close)(db->cursor) ; + db->cursor = NULL ; + } + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) + } + + + +int +NEXTKEY(db, key) + BerkeleyDB::Common db + DBTKEY key = NO_INIT + CODE: + { + DBT value ; + + CurrentDB = db ; + DBT_clear(key) ; + DBT_clear(value) ; + key.flags = 0 ; + RETVAL = (db->Status) = + ((db->cursor)->c_get)(db->cursor, &key, &value, DB_NEXT); + + /* check for end of cursor */ + if (RETVAL == DB_NOTFOUND) { + ((db->cursor)->c_close)(db->cursor) ; + db->cursor = NULL ; + } + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) + } + +MODULE = BerkeleyDB::_tiedArray PACKAGE = BerkeleyDB::_tiedArray + +I32 +FETCHSIZE(db) + BerkeleyDB::Common db + CODE: + CurrentDB = db ; + RETVAL = GetArrayLength(db) ; + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB PACKAGE = BerkeleyDB + +BOOT: + { + SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; + SV * version_sv = perl_get_sv("BerkeleyDB::db_version", GV_ADD|GV_ADDMULTI) ; + SV * ver_sv = perl_get_sv("BerkeleyDB::db_ver", GV_ADD|GV_ADDMULTI) ; + int Major, Minor, Patch ; + (void)db_version(&Major, &Minor, &Patch) ; + /* Check that the versions of db.h and libdb.a are the same */ + if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR + || Patch != DB_VERSION_PATCH) + croak("\nBerkeleyDB needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n", + DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, + Major, Minor, Patch) ; + + if (Major < 2 || (Major == 2 && Minor < 6)) + { + croak("BerkeleyDB needs Berkeley DB 2.6 or greater. This is %d.%d.%d\n", + Major, Minor, Patch) ; + } + sv_setpvf(version_sv, "%d.%d", Major, Minor) ; + sv_setpvf(ver_sv, "%d.%03d%03d", Major, Minor, Patch) ; + sv_setpv(sv_err, ""); + + DBT_clear(empty) ; + empty.data = &zero ; + empty.size = sizeof(db_recno_t) ; + empty.flags = 0 ; + + } + diff --git a/bdb/perl/BerkeleyDB/BerkeleyDB/Btree.pm b/bdb/perl/BerkeleyDB/BerkeleyDB/Btree.pm new file mode 100644 index 00000000000..ba9a9c0085d --- /dev/null +++ b/bdb/perl/BerkeleyDB/BerkeleyDB/Btree.pm @@ -0,0 +1,8 @@ + +package BerkeleyDB::Btree ; + +# This file is only used for MLDBM + +use BerkeleyDB ; + +1 ; diff --git a/bdb/perl/BerkeleyDB/BerkeleyDB/Hash.pm b/bdb/perl/BerkeleyDB/BerkeleyDB/Hash.pm new file mode 100644 index 00000000000..8e7bc7e78c7 --- /dev/null +++ b/bdb/perl/BerkeleyDB/BerkeleyDB/Hash.pm @@ -0,0 +1,8 @@ + +package BerkeleyDB::Hash ; + +# This file is only used for MLDBM + +use BerkeleyDB ; + +1 ; diff --git a/bdb/perl/BerkeleyDB/Changes b/bdb/perl/BerkeleyDB/Changes new file mode 100644 index 00000000000..cbeb1a34d73 --- /dev/null +++ b/bdb/perl/BerkeleyDB/Changes @@ -0,0 +1,167 @@ +Revision history for Perl extension BerkeleyDB. + +0.20 2nd September 2002 + + * More support for building with Berkeley DB 4.1.x + * db->get & db->pget used the wrong output macro for DBM filters + bug spotted by Aaron Ross. + * db_join didn't keep a reference to the cursors it was joining. + Spotted by Winton Davies. + +0.19 5th June 2002 + * Removed the targets that used mkconsts from Makefile.PL. They relied + on a module that is not available in all versions of Perl. + * added support for env->set_verbose + * added support for db->truncate + * added support for db->rename via BerkeleyDB::db_rename + * added support for db->verify via BerkeleyDB::db_verify + * added support for db->associate, db->pget & cursor->c_pget + * Builds with Berkeley DB 4.1.x + + +0.18 6th January 2002 + * Dropped support for ErrFile as a file handle. It was proving too + difficult to get at the underlying FILE * in XS. + Reported by Jonas Smedegaard (Debian powerpc) & Kenneth Olwing (Win32) + * Fixed problem with abort macro in XSUB.h clashing with txn abort + method in Berkeley DB 4.x -- patch supplied by Kenneth Olwing. + * DB->set_alloc was getting called too late in BerkeleyDB.xs. + This was causing problems with ActivePerl -- problem reported + by Kenneth Olwing. + * When opening a queue, the Len proprty set the DB_PAD flag. + Should have been DB_FIXEDLEN. Fix provided by Kenneth Olwing. + * Test harness fixes from Kenneth Olwing. + +0.17 23 September 2001 + * Fixed a bug in BerkeleyDB::Recno - reported by Niklas Paulsson. + * Added log_archive - patch supplied by Benjamin Holzman + * Added txn_discard + * Builds with Berkeley DB 4.0.x + +0.16 1 August 2001 + * added support for Berkeley DB 3.3.x (but no support for any of the + new features just yet) + +0.15 26 April 2001 + * Fixed a bug in the processing of the flags options in + db_key_range. + * added support for set_lg_max & set_lg_bsize + * allow DB_TMP_DIR and DB_TEMP_DIR + * the -Filename parameter to BerkeleyDB::Queue didn't work. + * added symbol DB_CONSUME_WAIT + +0.14 21st January 2001 + * Silenced the warnings when build with a 64-bit Perl. + * Can now build with DB 3.2.3h (part of MySQL). The test harness + takes an age to do the queue test, but it does eventually pass. + * Mentioned the problems that occur when perl is built with sfio. + +0.13 15th January 2001 + * Added support to allow this module to build with Berkeley DB 3.2 + * Updated dbinfo to support Berkeley DB 3.1 & 3.2 file format + changes. + * Documented the Solaris 2.7 core dump problem in README. + * Tidied up the test harness to fix a problem on Solaris where the + "fred" directory wasn't being deleted when it should have been. + * two calls to "open" clashed with a win32 macro. + * size argument for hash_cb is different for Berkeley DB 3.x + * Documented the issue of building on Linux. + * Added -Server, -CacheSize & -LockDetect options + [original patch supplied by Graham Barr] + * Added support for set_mutexlocks, c_count, set_q_extentsize, + key_range, c_dup + * Dropped the "attempted to close a Cursor with an open transaction" + error in c_close. The correct behaviour is that the cursor + should be closed before committing/aborting the transaction. + +0.12 2nd August 2000 + * Serious bug with get fixed. Spotted by Sleepycat. + * Added hints file for Solaris & Irix (courtesy of Albert Chin-A-Young) + +0.11 4th June 2000 + * When built with Berkeley Db 3.x there can be a clash with the close + macro. + * Typo in the definition of DB_WRITECURSOR + * The flags parameter wasn't getting sent to db_cursor + * Plugged small memory leak in db_cursor (DESTROY wasn't freeing + memory) + * Can be built with Berkeley DB 3.1 + +0.10 8th December 1999 + * The DESTROY method was missing for BerkeleyDB::Env. This resulted in + a memory leak. Fixed. + * If opening an environment or database failed, there was a small + memory leak. This has been fixed. + * A thread-enabled Perl it could core when a database was closed. + Problem traced to the strdup function. + +0.09 29th November 1999 + * the queue.t & subdb.t test harnesses were outputting a few + spurious warnings. This has been fixed. + +0.08 28nd November 1999 + * More documentation updates + * Changed reference to files in /tmp in examples.t + * Fixed a typo in softCrash that caused problems when building + with a thread-enabled Perl. + * BerkeleyDB::Error wasn't initialised properly. + * ANSI-ified all the static C functions in BerkeleyDB.xs + * Added support for the following DB 3.x features: + + The Queue database type + + db_remove + + subdatabases + + db_stat for Hash & Queue + +0.07 21st September 1999 + * Numerous small bug fixes. + * Added support for sorting duplicate values DB_DUPSORT. + * Added support for DB_GET_BOTH & DB_NEXT_DUP. + * Added get_dup (from DB_File). + * beefed up the documentation. + * Forgot to add the DB_INIT_CDB in BerkeleyDB.pm in previous release. + * Merged the DBM Filter code from DB_File into BerkeleyDB. + * Fixed a nasty bug where a closed transaction was still used with + with dp_put, db_get etc. + * Added logic to gracefully close everything whenever a fatal error + happens. Previously the plug was just pulled. + * It is now a fatal error to explicitly close an environment if there + is still an open database; a database when there are open cursors or + an open transaction; and a cursor if there is an open transaction. + Using object destruction doesn't have this issue, as object + references will ensure everything gets closed in the correct order. + * The BOOT code now checks that the version of db.h & libdb are the + same - this seems to be a common problem on Linux. + * MLDBM support added. + * Support for the new join cursor added. + * Builds with Berkeley DB 3.x + * Updated dbinfo for Berkeley DB 3.x file formats. + * Deprecated the TxnMgr class. As with Berkeley DB version 3, + txn_begin etc are now accessed via the environment object. + +0.06 19 December 1998 + * Minor modifications to get the module to build with DB 2.6.x + * Added support for DB 2.6.x's Concurrent Access Method, DB_INIT_CDB. + +0.05 9 November 1998 + * Added a note to README about how to build Berkeley DB 2.x + when using HP-UX. + * Minor modifications to get the module to build with DB 2.5.x + +0.04 19 May 1998 + * Define DEFSV & SAVE_DEFSV if not already defined. This allows + the module to be built with Perl 5.004_04. + +0.03 5 May 1998 + * fixed db_get with DB_SET_RECNO + * fixed c_get with DB_SET_RECNO and DB_GET_RECNO + * implemented BerkeleyDB::Unknown + * implemented BerkeleyDB::Recno, including push, pop etc + modified the txn support. + +0.02 30 October 1997 + * renamed module to BerkeleyDB + * fixed a few bugs & added more tests + +0.01 23 October 1997 + * first alpha release as BerkDB. + diff --git a/bdb/perl/BerkeleyDB/MANIFEST b/bdb/perl/BerkeleyDB/MANIFEST new file mode 100644 index 00000000000..7da51ef7d7c --- /dev/null +++ b/bdb/perl/BerkeleyDB/MANIFEST @@ -0,0 +1,56 @@ +BerkeleyDB.pm +BerkeleyDB.pod +BerkeleyDB.pod.P +BerkeleyDB.xs +BerkeleyDB/Btree.pm +BerkeleyDB/Hash.pm +Changes +config.in +constants.h +constants.xs +dbinfo +hints/dec_osf.pl +hints/solaris.pl +hints/irix_6_5.pl +Makefile.PL +MANIFEST +mkconsts +mkpod +ppport.h +README +t/btree.t +t/db-3.0.t +t/db-3.1.t +t/db-3.2.t +t/db-3.3.t +t/destroy.t +t/env.t +t/examples.t +t/examples.t.T +t/examples3.t +t/examples3.t.T +t/filter.t +t/hash.t +t/join.t +t/mldbm.t +t/queue.t +t/recno.t +t/strict.t +t/subdb.t +t/txn.t +t/unknown.t +t/util.pm +Todo +typemap +patches/5.004 +patches/5.004_01 +patches/5.004_02 +patches/5.004_03 +patches/5.004_04 +patches/5.004_05 +patches/5.005 +patches/5.005_01 +patches/5.005_02 +patches/5.005_03 +patches/5.6.0 +scan diff --git a/bdb/perl/BerkeleyDB/Makefile.PL b/bdb/perl/BerkeleyDB/Makefile.PL new file mode 100644 index 00000000000..86da9a845af --- /dev/null +++ b/bdb/perl/BerkeleyDB/Makefile.PL @@ -0,0 +1,123 @@ +#! perl -w + +# It should not be necessary to edit this file. The configuration for +# BerkeleyDB is controlled from the file config.in + + +BEGIN { die "BerkeleyDB needs Perl 5.004_04 or greater" if $] < 5.004_04 ; } + +use strict ; +use ExtUtils::MakeMaker ; +use Config ; + +# Check for the presence of sfio +if ($Config{'d_sfio'}) { + print <<EOM; + +WARNING: Perl seems to have been built with SFIO support enabled. + Please read the SFIO Notes in the README file. + +EOM +} + +my $LIB_DIR ; +my $INC_DIR ; +my $DB_NAME ; +my $LIBS ; + +ParseCONFIG() ; + +if (defined $DB_NAME) + { $LIBS = $DB_NAME } +else { + if ($^O eq 'MSWin32') + { $LIBS = '-llibdb' } + else + { $LIBS = '-ldb' } +} + +# OS2 is a special case, so check for it now. +my $OS2 = "" ; +$OS2 = "-DOS2" if $^O eq 'os2' ; + +WriteMakefile( + NAME => 'BerkeleyDB', + LIBS => ["-L${LIB_DIR} $LIBS"], + #MAN3PODS => {}, # Pods will be built by installman. + INC => "-I$INC_DIR", + VERSION_FROM => 'BerkeleyDB.pm', + XSPROTOARG => '-noprototypes', + DEFINE => "$OS2", + #'macro' => { INSTALLDIRS => 'perl' }, + 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'}, + ($] >= 5.005 + ? (ABSTRACT_FROM => 'BerkeleyDB.pod', + AUTHOR => 'Paul Marquess <Paul.Marquess@btinternet.com>') + : () + ), + ); + + +sub MY::postamble { + ' +$(NAME).pod: $(NAME).pod.P t/examples.t.T t/examples3.t.T mkpod + perl ./mkpod + +$(NAME).xs: typemap + $(TOUCH) $(NAME).xs + +Makefile: config.in + + +' ; +} + +sub ParseCONFIG +{ + my ($k, $v) ; + my @badkey = () ; + my %Info = () ; + my @Options = qw( INCLUDE LIB DBNAME ) ; + my %ValidOption = map {$_, 1} @Options ; + my %Parsed = %ValidOption ; + my $CONFIG = 'config.in' ; + + print "Parsing $CONFIG...\n" ; + + # DBNAME is optional, so pretend it has been parsed. + delete $Parsed{'DBNAME'} ; + + open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ; + while (<F>) { + s/^\s*|\s*$//g ; + next if /^\s*$/ or /^\s*#/ ; + s/\s*#\s*$// ; + + ($k, $v) = split(/\s+=\s+/, $_, 2) ; + $k = uc $k ; + if ($ValidOption{$k}) { + delete $Parsed{$k} ; + $Info{$k} = $v ; + } + else { + push(@badkey, $k) ; + } + } + close F ; + + print "Unknown keys in $CONFIG ignored [@badkey]\n" + if @badkey ; + + # check parsed values + my @missing = () ; + die "The following keys are missing from $CONFIG file: [@missing]\n" + if @missing = keys %Parsed ; + + $INC_DIR = $ENV{'BERKELEYDB_INCLUDE'} || $Info{'INCLUDE'} ; + $LIB_DIR = $ENV{'BERKELEYDB_LIB'} || $Info{'LIB'} ; + $DB_NAME = $Info{'DBNAME'} if defined $Info{'DBNAME'} ; + print "Looks Good.\n" ; + +} + +# end of file Makefile.PL diff --git a/bdb/perl/BerkeleyDB/README b/bdb/perl/BerkeleyDB/README new file mode 100644 index 00000000000..a600e313193 --- /dev/null +++ b/bdb/perl/BerkeleyDB/README @@ -0,0 +1,484 @@ + BerkeleyDB + + Version 0.20 + + 2nd Sept 2002 + + 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. + + +DESCRIPTION +----------- + +BerkeleyDB is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 2 or greater. (Note: if +you want to use version 1 of Berkeley DB with Perl you need the DB_File +module). + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. BerkeleyDB provides an interface to all +four of the database types (hash, btree, queue and recno) currently +supported by Berkeley DB. + +For further details see the documentation in the file BerkeleyDB.pod. + +PREREQUISITES +------------- + +Before you can build BerkeleyDB you need to have the following +installed on your system: + + * Perl 5.004_04 or greater. + + * Berkeley DB Version 2.6.4 or greater + + The official web site for Berkeley DB is http://www.sleepycat.com + + The latest version of Berkeley DB is always available there. It + is recommended that you use the most recent version available at + the Sleepycat site. + + The one exception to this advice is where you want to use BerkeleyDB + to access database files created by a third-party application, + like Sendmail. In these cases you must build BerkeleyDB with a + compatible version of Berkeley DB. + + +BUILDING THE MODULE +------------------- + +Assuming you have met all the prerequisites, building the module should +be relatively straightforward. + +Step 1 : If you are running Solaris 2.5, 2.7 or HP-UX 10 read either + the Solaris Notes or HP-UX Notes sections below. + If you are running Linux please read the Linux Notes section + before proceeding. + + +Step 2 : Edit the file config.in to suit you local installation. + Instructions are given in the file. + +Step 3 : Build and test the module using this sequence of commands: + + perl Makefile.PL + make + make test + +INSTALLATION +------------ + + make install + +TROUBLESHOOTING +=============== + +Here are some of the problems that people encounter when building BerkeleyDB. + +Missing db.h or libdb.a +----------------------- + +If you get an error like this: + + cc -c -I./libraries/ -Dbool=char -DHAS_BOOL -I/usr/local/include -O2 + -DVERSION=\"0.07\" -DXS_VERSION=\"0.07\" -fpic + -I/usr/local/lib/perl5/5.00503/i586-linux/CORE BerkeleyDB.c + BerkeleyDB.xs:52: db.h: No such file or directory + +or this: + + cc -c -I./libraries/2.7.5 -Dbool=char -DHAS_BOOL -I/usr/local/include -O2 + -DVERSION=\"0.07\" -DXS_VERSION=\"0.07\" -fpic + -I/usr/local/lib/perl5/5.00503/i586-linux/CORE BerkeleyDB.c + LD_RUN_PATH="/lib" cc -o blib/arch/auto/BerkeleyDB/BerkeleyDB.so -shared + -L/usr/local/lib BerkeleyDB.o + -L/home/paul/perl/ext/BerkDB/BerkeleyDB/libraries -ldb + ld: cannot open -ldb: No such file or directory + +This symptom can imply: + + 1. You don't have Berkeley DB installed on your system at all. + Solution: get & install Berkeley DB. + + 2. You do have Berkeley DB installed, but it isn't in a standard place. + Solution: Edit config.in and set the LIB and INCLUDE variables to point + to the directories where libdb.a and db.h are installed. + +#error db.h is not for Berkeley DB at all. +------------------------------------------ + +If you get the error above when building this module it means that there +is a file called "db.h" on your system that isn't the one that comes +with Berkeley DB. + +Options: + + 1. You don't have Berkeley DB installed on your system at all. + Solution: get & install Berkeley DB. + + 2. Edit config.in and make sure the INCLUDE variable points to the + directory where the Berkeley DB file db.h is installed. + + 3. If option 2 doesn't work, try tempoarily renaming the db.h file + that is causing the error. + +#error db.h is for Berkeley DB 1.x - need at least Berkeley DB 2.6.4 +-------------------------------------------------------------------- + +The error above will occur if there is a copy of the Berkeley DB 1.x +file db.h on your system. + +This error will happen when + + 1. you only have Berkeley DB version 1 on your system. + Solution: get & install a newer version of Berkeley DB. + + 2. you have both version 1 and a later version of Berkeley DB + installed on your system. When building BerkeleyDB it attempts to + use the db.h for Berkeley DB version 1. + Solution: Edit config.in and set the LIB and INCLUDE variables + to point to the directories where libdb.a and db.h are + installed. + + +#error db.h is for Berkeley DB 2.0-2.5 - need at least Berkeley DB 2.6.4 +------------------------------------------------------------------------ + +The error above will occur if there is a copy of the the file db.h for +Berkeley DB 2.0 to 2.5 on your system. + +This symptom can imply: + + 1. You don't have a new enough version of Berkeley DB. + Solution: get & install a newer version of Berkeley DB. + + 2. You have the correct version of Berkeley DB installed, but it isn't + in a standard place. + Solution: Edit config.in and set the LIB and INCLUDE variables + to point to the directories where libdb.a and db.h are + installed. + +Undefined Symbol: txn_stat +-------------------------- + +BerkeleyDB seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00503 + -Iblib/arch -Iblib/lib -I/usr/local/lib/perl5/5.00503/i586-linux + -I/usr/local/lib/perl5/5.00503 -e 'use Test::Harness qw(&runtests $verbose); + $verbose=0; runtests @ARGV;' t/*.t + t/btree.............Can't load 'blib/arch/auto/BerkeleyDB/BerkeleyDB.so' for + module BerkeleyDB: blib/arch/auto/BerkeleyDB/BerkeleyDB.so: + undefined symbol: txn_stat + at /usr/local/lib/perl5/5.00503/i586-linux/DynaLoader.pm line 169. + ... + +This error usually happens when you have both version 1 and a newer version +of Berkeley DB installed on your system. BerkeleyDB attempts +to build using the db.h for Berkeley DB version 2/3/4 and the version 1 +library. Unfortunately the two versions aren't compatible with each +other. BerkeleyDB can only be built with Berkeley DB version 2, 3 or 4. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want BerkeleyDB to use. + +Undefined Symbol: db_appinit +---------------------------- + +BerkeleyDB seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00561 -Iblib/arch + -Iblib/lib -I/home/paul/perl/install/5.005_61/lib/5.00561/i586-linux + -I/home/paul/perl/install/5.005_61/lib/5.00561 -e 'use Test::Harness + qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/btree.............Can't load 'blib/arch/auto/BerkeleyDB/BerkeleyDB.so' for + module BerkeleyDB: blib/arch/auto/BerkeleyDB/BerkeleyDB.so: + undefined symbol: db_appinit + at /home/paul/perl/install/5.005_61/lib/5.00561/i586-linux/DynaLoader.pm + ... + + +This error usually happens when you have both version 2 and version +3 of Berkeley DB installed on your system and BerkeleyDB attempts +to build using the db.h for Berkeley DB version 2 and the version 3 +library. Unfortunately the two versions aren't compatible with each +other. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want BerkeleyDB to use. + +Undefined Symbol: db_create +--------------------------- + +BerkeleyDB seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00561 -Iblib/arch + -Iblib/lib -I/home/paul/perl/install/5.005_61/lib/5.00561/i586-linux + -I/home/paul/perl/install/5.005_61/lib/5.00561 -e 'use Test::Harness + qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/btree.............Can't load 'blib/arch/auto/BerkeleyDB/BerkeleyDB.so' for + module BerkeleyDB: blib/arch/auto/BerkeleyDB/BerkeleyDB.so: + undefined symbol: db_create + at /home/paul/perl/install/5.005_61/lib/5.00561/i586-linux/DynaLoader.pm + ... + +This error usually happens when you have both version 2 and version +3 of Berkeley DB installed on your system and BerkeleyDB attempts +to build using the db.h for Berkeley DB version 3 and the version 2 +library. Unfortunately the two versions aren't compatible with each +other. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want BerkeleyDB to use. + + +Incompatible versions of db.h and libdb +--------------------------------------- + +BerkeleyDB seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00503 + -Iblib/arch -Iblib/lib -I/usr/local/lib/perl5/5.00503/i586-linux + -I/usr/local/lib/perl5/5.00503 -e 'use Test::Harness qw(&runtests $verbose); + $verbose=0; runtests @ARGV;' t/*.t + t/btree............. + BerkeleyDB needs compatible versions of libdb & db.h + you have db.h version 2.6.4 and libdb version 2.7.5 + BEGIN failed--compilation aborted at t/btree.t line 25. + dubious + Test returned status 255 (wstat 65280, 0xff00) + ... + +Another variation on the theme of having two versions of Berkeley DB on +your system. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want BerkeleyDB to use. + If you are running Linux, please read the Linux Notes section below. + + +Linux Notes +----------- + +Newer versions of Linux (e.g. RedHat 6, SuSe 6) ship with a C library +that has version 2.x of Berkeley DB linked into it. This makes it +difficult to build this module with anything other than the version of +Berkeley DB that shipped with your Linux release. If you do try to use +a different version of Berkeley DB you will most likely get the error +described in the "Incompatible versions of db.h and libdb" section of +this file. + +To make matters worse, prior to Perl 5.6.1, the perl binary itself +*always* included the Berkeley DB library. + +If you want to use a newer version of Berkeley DB with this module, the +easiest solution is to use Perl 5.6.1 (or better) and Berkeley DB 3.x +(or better). + +There are two approaches you can use to get older versions of Perl to +work with specific versions of Berkeley DB. Both have their advantages +and disadvantages. + +The first approach will only work when you want to build a version of +Perl older than 5.6.1 along with Berkeley DB 3.x. If you want to use +Berkeley DB 2.x, you must use the next approach. This approach involves +rebuilding your existing version of Perl after applying an unofficial +patch. The "patches" directory in the this module's source distribution +contains a number of patch files. There is one patch file for every +stable version of Perl since 5.004. Apply the appropriate patch to your +Perl source tree before re-building and installing Perl from scratch. +For example, assuming you are in the top-level source directory for +Perl 5.6.0, the command below will apply the necessary patch. Remember +to replace the path shown below with one that points to this module's +patches directory. + + patch -p1 -N </path/to/BerkeleyDB/patches/5.6.0 + +Now rebuild & install perl. You should now have a perl binary that can +be used to build this module. Follow the instructions in "BUILDING THE +MODULE", remembering to set the INCLUDE and LIB variables in config.in. + + +The second approach will work with Berkeley DB 2.x or better. +Start by building Berkeley DB as a shared library. This is from +the Berkeley DB build instructions: + + Building Shared Libraries for the GNU GCC compiler + + If you're using gcc and there's no better shared library example for + your architecture, the following shared library build procedure will + probably work. + + Add the -fpic option to the CFLAGS value in the Makefile. + + Rebuild all of your .o files. This will create a Berkeley DB library + that contains .o files with PIC code. To build the shared library, + then take the following steps in the library build directory: + + % mkdir tmp + % cd tmp + % ar xv ../libdb.a + % gcc -shared -o libdb.so *.o + % mv libdb.so .. + % cd .. + % rm -rf tmp + + Note, you may have to change the gcc line depending on the + requirements of your system. + + The file libdb.so is your shared library + +Once you have built libdb.so, you will need to store it somewhere safe. + + cp libdb.so /usr/local/BerkeleyDB/lib + +If you now set the LD_PRELOAD environment variable to point to this +shared library, Perl will use it instead of the version of Berkeley DB +that shipped with your Linux distribution. + + export LD_PRELOAD=/usr/local/BerkeleyDB/lib/libdb.so + +Finally follow the instructions in "BUILDING THE MODULE" to build, +test and install this module. Don't forget to set the INCLUDE and LIB +variables in config.in. + +Remember, you will need to have the LD_PRELOAD variable set anytime you +want to use Perl with Berkeley DB. Also note that if you have LD_PRELOAD +permanently set it will affect ALL commands you execute. This may be a +problem if you run any commands that access a database created by the +version of Berkeley DB that shipped with your Linux distribution. + + + +Solaris 2.5 Notes +----------------- + +If you are running Solaris 2.5, and you get this error when you run the +BerkeleyDB test harness: + + libc internal error: _rmutex_unlock: rmutex not held. + +you probably need to install a Sun patch. It has been reported that +Sun patch 103187-25 (or later revisions) fixes this problem. + +To find out if you have the patch installed, the command "showrev -p" +will display the patches that are currently installed on your system. + +Solaris 2.7 Notes +----------------- + +If you are running Solaris 2.7 and all the tests in the test harness +generate a core dump, try applying Sun patch 106980-09 (or better). + +To find out if you have the patch installed, the command "showrev -p" +will display the patches that are currently installed on your system. + + +HP-UX Notes +----------- + +Some people running HP-UX 10 have reported getting an error like this +when building this module with the native HP-UX compiler. + + ld: (Warning) At least one PA 2.0 object file (BerkeleyDB.o) was detected. + The linked output may not run on a PA 1.x system. + ld: Invalid loader fixup for symbol "$000000A5". + +If this is the case for you, Berkeley DB needs to be recompiled with +the +z or +Z option and the resulting library placed in a .sl file. The +following steps should do the trick: + + 1: Configure the Berkeley DB distribution with the +z or +Z C compiler + flag: + + env "CFLAGS=+z" ../dist/configure ... + + 2: Edit the Berkeley DB Makefile and change: + + "libdb= libdb.a" to "libdb= libdb.sl". + + 3: Build and install the Berkeley DB distribution as usual. + + + +FEEDBACK +-------- + +How to report a problem with BerkeleyDB. + +To help me help you, I need of the following information: + + 1. The version of Perl and the operating system name and version you + are running. The complete output from running "perl -V" will tell + me all I need to know. + If your perl does not understand the "-V" option is too old. + BerkeleyDB needs Perl version 5.004_04 or better. + + 2. The version of BerkeleyDB you have. If you have successfully + installed BerkeleyDB, this one-liner will tell you: + + perl -MBerkeleyDB -e 'print qq{BerkeleyDB ver $BerkeleyDB::VERSION\n}' + + If you haven't installed BerkeleyDB then search BerkeleyDB.pm for a + line like this: + + $VERSION = "1.20" ; + + 3. The version of Berkeley DB you have installed. If you have + successfully installed BerkeleyDB, this one-liner will tell you: + + perl -MBerkeleyDB -e 'print BerkeleyDB::DB_VERSION_STRING.qq{\n}' + + If you haven't installed BerkeleyDB then search db.h for a line + like this: + + #define DB_VERSION_STRING + + 4. If you are having problems building BerkeleyDB, send me a complete + log of what happened. + + 5. Now the difficult one. If you think you have found a bug in + BerkeleyDB and you want me to fix it, you will *greatly* enhance + the chances of me being able to track it down by sending me a small + self-contained Perl script that illustrates the problem you are + encountering. Include a summary of what you think the problem is + and a log of what happens when you run the script, in case I can't + reproduce your problem on my system. If possible, don't have the + script dependent on an existing 20Meg database. If the script you + send me can create the database itself then that is preferred. + + I realise that in some cases this is easier said than done, so if + you can only reproduce the problem in your existing script, then + you can post me that if you want. Just don't expect me to find your + problem in a hurry, or at all. :-) + + +CHANGES +------- + +See the Changes file. + +Paul Marquess <Paul.Marquess@btinternet.com> + diff --git a/bdb/perl/BerkeleyDB/Todo b/bdb/perl/BerkeleyDB/Todo new file mode 100644 index 00000000000..12d53bcf91c --- /dev/null +++ b/bdb/perl/BerkeleyDB/Todo @@ -0,0 +1,57 @@ + + * Proper documentation. + + * address or document the "close all cursors if you encounter an error" + + * Change the $BerkeleyDB::Error to store the info in the db object, + if possible. + + * $BerkeleyDB::db_version is documented. &db_version isn't. + + * migrate perl code into the .xs file where necessary + + * convert as many of the DB examples files to BerkeleyDB format. + + * add a method to the DB object to allow access to the environment (if there + actually is one). + + +Possibles + + * use '~' magic to store the inner data. + + * for the get stuff zap the value to undef if it doesn't find the + key. This may be more intuitive for those folks who are used with + the $hash{key} interface. + + * Text interface? This can be done as via Recno + + * allow recno to allow base offset for arrays to be either 0 or 1. + + * when duplicate keys are enabled, allow db_put($key, [$val1, $val2,...]) + + +2.x -> 3.x Upgrade +================== + +Environment Verbose +Env->open mode +DB cache size extra parameter +DB->open subdatabases Done +An empty environment causes DB->open to fail +where is __db.001 coming from? db_remove seems to create it. Bug in 3.0.55 +Change db_strerror for 0 to ""? Done +Queue Done +db_stat for Hash & Queue Done +No TxnMgr +DB->remove +ENV->remove +ENV->set_verbose +upgrade + + $env = BerkeleyDB::Env::Create + $env = create BerkeleyDB::Env + $status = $env->open() + + $db = BerkeleyDB::Hash::Create + $status = $db->open() diff --git a/bdb/perl/BerkeleyDB/config.in b/bdb/perl/BerkeleyDB/config.in new file mode 100644 index 00000000000..fd1bb1caede --- /dev/null +++ b/bdb/perl/BerkeleyDB/config.in @@ -0,0 +1,43 @@ +# Filename: config.in +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> + +# 1. Where is the file db.h? +# +# Change the path below to point to the directory where db.h is +# installed on your system. + +INCLUDE = /usr/local/include +#INCLUDE = /usr/local/BerkeleyDB/include + +# 2. Where is libdb? +# +# Change the path below to point to the directory where libdb is +# installed on your system. + +LIB = /usr/local/lib +#LIB = /usr/local/BerkeleyDB/lib + +# 3. Is the library called libdb? +# +# If you have copies of both 1.x and 2.x Berkeley DB installed on +# your system it can sometimes be tricky to make sure you are using +# the correct one. Renaming one (or creating a symbolic link) to +# include the version number of the library can help. +# +# For example, if you have Berkeley DB 2.6.4 you could rename the +# Berkeley DB library from libdb.a to libdb-2.6.4.a and change the +# DBNAME line below to look like this: +# +# DBNAME = -ldb-2.6.4 +# +# Note: If you are building this module with Win32, -llibdb will be +# used by default. +# +# If you have changed the name of the library, uncomment the line +# below (by removing the leading #) and edit the line to use the name +# you have picked. + +#DBNAME = -ldb-3.0 + +# end of file config.in diff --git a/bdb/perl/BerkeleyDB/constants.h b/bdb/perl/BerkeleyDB/constants.h new file mode 100644 index 00000000000..d86cef15513 --- /dev/null +++ b/bdb/perl/BerkeleyDB/constants.h @@ -0,0 +1,4046 @@ +#define PERL_constant_NOTFOUND 1 +#define PERL_constant_NOTDEF 2 +#define PERL_constant_ISIV 3 +#define PERL_constant_ISNO 4 +#define PERL_constant_ISNV 5 +#define PERL_constant_ISPV 6 +#define PERL_constant_ISPVN 7 +#define PERL_constant_ISSV 8 +#define PERL_constant_ISUNDEF 9 +#define PERL_constant_ISUV 10 +#define PERL_constant_ISYES 11 + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif + +static int +constant_6 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_DUP DB_PAD DB_RMW DB_SET */ + /* Offset 3 gives the best switch position. */ + switch (name[3]) { + case 'D': + if (memEQ(name, "DB_DUP", 6)) { + /* ^ */ +#ifdef DB_DUP + *iv_return = DB_DUP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_PAD", 6)) { + /* ^ */ +#ifdef DB_PAD + *iv_return = DB_PAD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_RMW", 6)) { + /* ^ */ +#ifdef DB_RMW + *iv_return = DB_RMW; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_SET", 6)) { + /* ^ */ +#ifdef DB_SET + *iv_return = DB_SET; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_7 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_EXCL DB_HASH DB_LAST DB_NEXT DB_PREV */ + /* Offset 3 gives the best switch position. */ + switch (name[3]) { + case 'E': + if (memEQ(name, "DB_EXCL", 7)) { + /* ^ */ +#ifdef DB_EXCL + *iv_return = DB_EXCL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'H': + if (memEQ(name, "DB_HASH", 7)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_HASH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_LAST", 7)) { + /* ^ */ +#ifdef DB_LAST + *iv_return = DB_LAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_NEXT", 7)) { + /* ^ */ +#ifdef DB_NEXT + *iv_return = DB_NEXT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_PREV", 7)) { + /* ^ */ +#ifdef DB_PREV + *iv_return = DB_PREV; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_8 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_AFTER DB_BTREE DB_FIRST DB_FLUSH DB_FORCE DB_QUEUE DB_RECNO */ + /* Offset 4 gives the best switch position. */ + switch (name[4]) { + case 'E': + if (memEQ(name, "DB_RECNO", 8)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_RECNO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'F': + if (memEQ(name, "DB_AFTER", 8)) { + /* ^ */ +#ifdef DB_AFTER + *iv_return = DB_AFTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_FIRST", 8)) { + /* ^ */ +#ifdef DB_FIRST + *iv_return = DB_FIRST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_FLUSH", 8)) { + /* ^ */ +#ifdef DB_FLUSH + *iv_return = DB_FLUSH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_FORCE", 8)) { + /* ^ */ +#ifdef DB_FORCE + *iv_return = DB_FORCE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_BTREE", 8)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_BTREE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_QUEUE", 8)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 55) + *iv_return = DB_QUEUE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_9 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_APPEND DB_BEFORE DB_CLIENT DB_COMMIT DB_CREATE DB_CURLSN DB_DIRECT + DB_EXTENT DB_GETREC DB_NOCOPY DB_NOMMAP DB_NOSYNC DB_RDONLY DB_RECNUM + DB_THREAD DB_VERIFY */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'A': + if (memEQ(name, "DB_NOMMAP", 9)) { + /* ^ */ +#ifdef DB_NOMMAP + *iv_return = DB_NOMMAP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_THREAD", 9)) { + /* ^ */ +#ifdef DB_THREAD + *iv_return = DB_THREAD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'C': + if (memEQ(name, "DB_DIRECT", 9)) { + /* ^ */ +#ifdef DB_DIRECT + *iv_return = DB_DIRECT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_GETREC", 9)) { + /* ^ */ +#ifdef DB_GETREC + *iv_return = DB_GETREC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'F': + if (memEQ(name, "DB_VERIFY", 9)) { + /* ^ */ +#ifdef DB_VERIFY + *iv_return = DB_VERIFY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_COMMIT", 9)) { + /* ^ */ +#ifdef DB_COMMIT + *iv_return = DB_COMMIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_RDONLY", 9)) { + /* ^ */ +#ifdef DB_RDONLY + *iv_return = DB_RDONLY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_APPEND", 9)) { + /* ^ */ +#ifdef DB_APPEND + *iv_return = DB_APPEND; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_CLIENT", 9)) { + /* ^ */ +#ifdef DB_CLIENT + *iv_return = DB_CLIENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_EXTENT", 9)) { + /* ^ */ +#ifdef DB_EXTENT + *iv_return = DB_EXTENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_NOSYNC", 9)) { + /* ^ */ +#ifdef DB_NOSYNC + *iv_return = DB_NOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_NOCOPY", 9)) { + /* ^ */ +#ifdef DB_NOCOPY + *iv_return = DB_NOCOPY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_BEFORE", 9)) { + /* ^ */ +#ifdef DB_BEFORE + *iv_return = DB_BEFORE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_CURLSN", 9)) { + /* ^ */ +#ifdef DB_CURLSN + *iv_return = DB_CURLSN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_CREATE", 9)) { + /* ^ */ +#ifdef DB_CREATE + *iv_return = DB_CREATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_RECNUM", 9)) { + /* ^ */ +#ifdef DB_RECNUM + *iv_return = DB_RECNUM; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_10 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_CONSUME DB_CURRENT DB_DELETED DB_DUPSORT DB_ENCRYPT DB_ENV_CDB + DB_ENV_TXN DB_JOINENV DB_KEYLAST DB_NOPANIC DB_OK_HASH DB_PRIVATE + DB_PR_PAGE DB_RECOVER DB_SALVAGE DB_TIMEOUT DB_TXN_CKP DB_UNKNOWN + DB_UPGRADE */ + /* Offset 8 gives the best switch position. */ + switch (name[8]) { + case 'D': + if (memEQ(name, "DB_ENV_CDB", 10)) { + /* ^ */ +#ifdef DB_ENV_CDB + *iv_return = DB_ENV_CDB; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_UPGRADE", 10)) { + /* ^ */ +#ifdef DB_UPGRADE + *iv_return = DB_UPGRADE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_DELETED", 10)) { + /* ^ */ +#ifdef DB_DELETED + *iv_return = DB_DELETED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_RECOVER", 10)) { + /* ^ */ +#ifdef DB_RECOVER + *iv_return = DB_RECOVER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_PR_PAGE", 10)) { + /* ^ */ +#ifdef DB_PR_PAGE + *iv_return = DB_PR_PAGE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_SALVAGE", 10)) { + /* ^ */ +#ifdef DB_SALVAGE + *iv_return = DB_SALVAGE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_NOPANIC", 10)) { + /* ^ */ +#ifdef DB_NOPANIC + *iv_return = DB_NOPANIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'K': + if (memEQ(name, "DB_TXN_CKP", 10)) { + /* ^ */ +#ifdef DB_TXN_CKP + *iv_return = DB_TXN_CKP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_CONSUME", 10)) { + /* ^ */ +#ifdef DB_CONSUME + *iv_return = DB_CONSUME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_CURRENT", 10)) { + /* ^ */ +#ifdef DB_CURRENT + *iv_return = DB_CURRENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_JOINENV", 10)) { + /* ^ */ +#ifdef DB_JOINENV + *iv_return = DB_JOINENV; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_ENCRYPT", 10)) { + /* ^ */ +#ifdef DB_ENCRYPT + *iv_return = DB_ENCRYPT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_DUPSORT", 10)) { + /* ^ */ +#ifdef DB_DUPSORT + *iv_return = DB_DUPSORT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_KEYLAST", 10)) { + /* ^ */ +#ifdef DB_KEYLAST + *iv_return = DB_KEYLAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_OK_HASH", 10)) { + /* ^ */ +#ifdef DB_OK_HASH + *iv_return = DB_OK_HASH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_PRIVATE", 10)) { + /* ^ */ +#ifdef DB_PRIVATE + *iv_return = DB_PRIVATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_TIMEOUT", 10)) { + /* ^ */ +#ifdef DB_TIMEOUT + *iv_return = DB_TIMEOUT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'W': + if (memEQ(name, "DB_UNKNOWN", 10)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_UNKNOWN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'X': + if (memEQ(name, "DB_ENV_TXN", 10)) { + /* ^ */ +#ifdef DB_ENV_TXN + *iv_return = DB_ENV_TXN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_11 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_APP_INIT DB_ARCH_ABS DB_ARCH_LOG DB_FIXEDLEN DB_GET_BOTH DB_INIT_CDB + DB_INIT_LOG DB_INIT_TXN DB_KEYEMPTY DB_KEYEXIST DB_KEYFIRST DB_LOCKDOWN + DB_LOCK_GET DB_LOCK_PUT DB_LOGMAGIC DB_LOG_DISK DB_MULTIPLE DB_NEXT_DUP + DB_NOSERVER DB_NOTFOUND DB_OK_BTREE DB_OK_QUEUE DB_OK_RECNO DB_POSITION + DB_QAMMAGIC DB_RENUMBER DB_SNAPSHOT DB_TRUNCATE DB_TXNMAGIC DB_TXN_LOCK + DB_TXN_REDO DB_TXN_SYNC DB_TXN_UNDO DB_WRNOSYNC DB_YIELDCPU */ + /* Offset 8 gives the best switch position. */ + switch (name[8]) { + case 'A': + if (memEQ(name, "DB_ARCH_ABS", 11)) { + /* ^ */ +#ifdef DB_ARCH_ABS + *iv_return = DB_ARCH_ABS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TRUNCATE", 11)) { + /* ^ */ +#ifdef DB_TRUNCATE + *iv_return = DB_TRUNCATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'B': + if (memEQ(name, "DB_RENUMBER", 11)) { + /* ^ */ +#ifdef DB_RENUMBER + *iv_return = DB_RENUMBER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'C': + if (memEQ(name, "DB_INIT_CDB", 11)) { + /* ^ */ +#ifdef DB_INIT_CDB + *iv_return = DB_INIT_CDB; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_OK_RECNO", 11)) { + /* ^ */ +#ifdef DB_OK_RECNO + *iv_return = DB_OK_RECNO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_YIELDCPU", 11)) { + /* ^ */ +#ifdef DB_YIELDCPU + *iv_return = DB_YIELDCPU; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'D': + if (memEQ(name, "DB_NEXT_DUP", 11)) { + /* ^ */ +#ifdef DB_NEXT_DUP + *iv_return = DB_NEXT_DUP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_OK_QUEUE", 11)) { + /* ^ */ +#ifdef DB_OK_QUEUE + *iv_return = DB_OK_QUEUE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_REDO", 11)) { + /* ^ */ +#ifdef DB_TXN_REDO + *iv_return = DB_TXN_REDO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_LOCK_GET", 11)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_LOCK_GET; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOGMAGIC", 11)) { + /* ^ */ +#ifdef DB_LOGMAGIC + *iv_return = DB_LOGMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_QAMMAGIC", 11)) { + /* ^ */ +#ifdef DB_QAMMAGIC + *iv_return = DB_QAMMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXNMAGIC", 11)) { + /* ^ */ +#ifdef DB_TXNMAGIC + *iv_return = DB_TXNMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'H': + if (memEQ(name, "DB_SNAPSHOT", 11)) { + /* ^ */ +#ifdef DB_SNAPSHOT + *iv_return = DB_SNAPSHOT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_KEYEXIST", 11)) { + /* ^ */ +#ifdef DB_KEYEXIST + *iv_return = DB_KEYEXIST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOG_DISK", 11)) { + /* ^ */ +#ifdef DB_LOG_DISK + *iv_return = DB_LOG_DISK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_POSITION", 11)) { + /* ^ */ +#ifdef DB_POSITION + *iv_return = DB_POSITION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_ARCH_LOG", 11)) { + /* ^ */ +#ifdef DB_ARCH_LOG + *iv_return = DB_ARCH_LOG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_FIXEDLEN", 11)) { + /* ^ */ +#ifdef DB_FIXEDLEN + *iv_return = DB_FIXEDLEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_INIT_LOG", 11)) { + /* ^ */ +#ifdef DB_INIT_LOG + *iv_return = DB_INIT_LOG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_APP_INIT", 11)) { + /* ^ */ +#ifdef DB_APP_INIT + *iv_return = DB_APP_INIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_UNDO", 11)) { + /* ^ */ +#ifdef DB_TXN_UNDO + *iv_return = DB_TXN_UNDO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_GET_BOTH", 11)) { + /* ^ */ +#ifdef DB_GET_BOTH + *iv_return = DB_GET_BOTH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCKDOWN", 11)) { + /* ^ */ +#ifdef DB_LOCKDOWN + *iv_return = DB_LOCKDOWN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_LOCK", 11)) { + /* ^ */ +#ifdef DB_TXN_LOCK + *iv_return = DB_TXN_LOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_KEYEMPTY", 11)) { + /* ^ */ +#ifdef DB_KEYEMPTY + *iv_return = DB_KEYEMPTY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_PUT", 11)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_LOCK_PUT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MULTIPLE", 11)) { + /* ^ */ +#ifdef DB_MULTIPLE + *iv_return = DB_MULTIPLE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_KEYFIRST", 11)) { + /* ^ */ +#ifdef DB_KEYFIRST + *iv_return = DB_KEYFIRST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_OK_BTREE", 11)) { + /* ^ */ +#ifdef DB_OK_BTREE + *iv_return = DB_OK_BTREE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_INIT_TXN", 11)) { + /* ^ */ +#ifdef DB_INIT_TXN + *iv_return = DB_INIT_TXN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_NOTFOUND", 11)) { + /* ^ */ +#ifdef DB_NOTFOUND + *iv_return = DB_NOTFOUND; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'V': + if (memEQ(name, "DB_NOSERVER", 11)) { + /* ^ */ +#ifdef DB_NOSERVER + *iv_return = DB_NOSERVER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'Y': + if (memEQ(name, "DB_TXN_SYNC", 11)) { + /* ^ */ +#ifdef DB_TXN_SYNC + *iv_return = DB_TXN_SYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_WRNOSYNC", 11)) { + /* ^ */ +#ifdef DB_WRNOSYNC + *iv_return = DB_WRNOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_12 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_ARCH_DATA DB_CDB_ALLDB DB_CL_WRITER DB_DELIMITER DB_DIRECT_DB + DB_DUPCURSOR DB_ENV_FATAL DB_FAST_STAT DB_GET_BOTHC DB_GET_RECNO + DB_HASHMAGIC DB_INIT_LOCK DB_JOIN_ITEM DB_LOCKMAGIC DB_LOCK_DUMP + DB_LOCK_RW_N DB_LOGOLDVER DB_MAX_PAGES DB_MPOOL_NEW DB_NEEDSPLIT + DB_NODUPDATA DB_NOLOCKING DB_NORECURSE DB_OVERWRITE DB_PAGEYIELD + DB_PAGE_LOCK DB_PERMANENT DB_POSITIONI DB_PRINTABLE DB_QAMOLDVER + DB_SET_RANGE DB_SET_RECNO DB_SWAPBYTES DB_TEMPORARY DB_TXN_ABORT + DB_TXN_APPLY DB_TXN_PRINT DB_WRITELOCK DB_WRITEOPEN DB_XA_CREATE */ + /* Offset 3 gives the best switch position. */ + switch (name[3]) { + case 'A': + if (memEQ(name, "DB_ARCH_DATA", 12)) { + /* ^ */ +#ifdef DB_ARCH_DATA + *iv_return = DB_ARCH_DATA; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'C': + if (memEQ(name, "DB_CDB_ALLDB", 12)) { + /* ^ */ +#ifdef DB_CDB_ALLDB + *iv_return = DB_CDB_ALLDB; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_CL_WRITER", 12)) { + /* ^ */ +#ifdef DB_CL_WRITER + *iv_return = DB_CL_WRITER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'D': + if (memEQ(name, "DB_DELIMITER", 12)) { + /* ^ */ +#ifdef DB_DELIMITER + *iv_return = DB_DELIMITER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_DIRECT_DB", 12)) { + /* ^ */ +#ifdef DB_DIRECT_DB + *iv_return = DB_DIRECT_DB; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_DUPCURSOR", 12)) { + /* ^ */ +#ifdef DB_DUPCURSOR + *iv_return = DB_DUPCURSOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_ENV_FATAL", 12)) { + /* ^ */ +#ifdef DB_ENV_FATAL + *iv_return = DB_ENV_FATAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'F': + if (memEQ(name, "DB_FAST_STAT", 12)) { + /* ^ */ +#ifdef DB_FAST_STAT + *iv_return = DB_FAST_STAT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_GET_BOTHC", 12)) { + /* ^ */ +#ifdef DB_GET_BOTHC + *iv_return = DB_GET_BOTHC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_GET_RECNO", 12)) { + /* ^ */ +#ifdef DB_GET_RECNO + *iv_return = DB_GET_RECNO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'H': + if (memEQ(name, "DB_HASHMAGIC", 12)) { + /* ^ */ +#ifdef DB_HASHMAGIC + *iv_return = DB_HASHMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_INIT_LOCK", 12)) { + /* ^ */ +#ifdef DB_INIT_LOCK + *iv_return = DB_INIT_LOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'J': + if (memEQ(name, "DB_JOIN_ITEM", 12)) { + /* ^ */ +#ifdef DB_JOIN_ITEM + *iv_return = DB_JOIN_ITEM; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_LOCKMAGIC", 12)) { + /* ^ */ +#ifdef DB_LOCKMAGIC + *iv_return = DB_LOCKMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_DUMP", 12)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_LOCK_DUMP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_RW_N", 12)) { + /* ^ */ +#ifdef DB_LOCK_RW_N + *iv_return = DB_LOCK_RW_N; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOGOLDVER", 12)) { + /* ^ */ +#ifdef DB_LOGOLDVER + *iv_return = DB_LOGOLDVER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_MAX_PAGES", 12)) { + /* ^ */ +#ifdef DB_MAX_PAGES + *iv_return = DB_MAX_PAGES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MPOOL_NEW", 12)) { + /* ^ */ +#ifdef DB_MPOOL_NEW + *iv_return = DB_MPOOL_NEW; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_NEEDSPLIT", 12)) { + /* ^ */ +#ifdef DB_NEEDSPLIT + *iv_return = DB_NEEDSPLIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_NODUPDATA", 12)) { + /* ^ */ +#ifdef DB_NODUPDATA + *iv_return = DB_NODUPDATA; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_NOLOCKING", 12)) { + /* ^ */ +#ifdef DB_NOLOCKING + *iv_return = DB_NOLOCKING; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_NORECURSE", 12)) { + /* ^ */ +#ifdef DB_NORECURSE + *iv_return = DB_NORECURSE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_OVERWRITE", 12)) { + /* ^ */ +#ifdef DB_OVERWRITE + *iv_return = DB_OVERWRITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_PAGEYIELD", 12)) { + /* ^ */ +#ifdef DB_PAGEYIELD + *iv_return = DB_PAGEYIELD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_PAGE_LOCK", 12)) { + /* ^ */ +#ifdef DB_PAGE_LOCK + *iv_return = DB_PAGE_LOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_PERMANENT", 12)) { + /* ^ */ +#ifdef DB_PERMANENT + *iv_return = DB_PERMANENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_POSITIONI", 12)) { + /* ^ */ +#ifdef DB_POSITIONI + *iv_return = DB_POSITIONI; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_PRINTABLE", 12)) { + /* ^ */ +#ifdef DB_PRINTABLE + *iv_return = DB_PRINTABLE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'Q': + if (memEQ(name, "DB_QAMOLDVER", 12)) { + /* ^ */ +#ifdef DB_QAMOLDVER + *iv_return = DB_QAMOLDVER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_SET_RANGE", 12)) { + /* ^ */ +#ifdef DB_SET_RANGE + *iv_return = DB_SET_RANGE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_SET_RECNO", 12)) { + /* ^ */ +#ifdef DB_SET_RECNO + *iv_return = DB_SET_RECNO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_SWAPBYTES", 12)) { + /* ^ */ +#ifdef DB_SWAPBYTES + *iv_return = DB_SWAPBYTES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_TEMPORARY", 12)) { + /* ^ */ +#ifdef DB_TEMPORARY + *iv_return = DB_TEMPORARY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_ABORT", 12)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 12) + *iv_return = DB_TXN_ABORT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_APPLY", 12)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 7) + *iv_return = DB_TXN_APPLY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_PRINT", 12)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_TXN_PRINT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'W': + if (memEQ(name, "DB_WRITELOCK", 12)) { + /* ^ */ +#ifdef DB_WRITELOCK + *iv_return = DB_WRITELOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_WRITEOPEN", 12)) { + /* ^ */ +#ifdef DB_WRITEOPEN + *iv_return = DB_WRITEOPEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'X': + if (memEQ(name, "DB_XA_CREATE", 12)) { + /* ^ */ +#ifdef DB_XA_CREATE + *iv_return = DB_XA_CREATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_13 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_AGGRESSIVE DB_BTREEMAGIC DB_CHECKPOINT DB_DIRECT_LOG DB_DIRTY_READ + DB_DONOTINDEX DB_ENV_CREATE DB_ENV_NOMMAP DB_ENV_THREAD DB_HASHOLDVER + DB_INCOMPLETE DB_INIT_MPOOL DB_LOCK_NORUN DB_LOCK_RIW_N DB_LOCK_TRADE + DB_LOGVERSION DB_LOG_LOCKED DB_MPOOL_LAST DB_MUTEXDEBUG DB_MUTEXLOCKS + DB_NEXT_NODUP DB_NOORDERCHK DB_PREV_NODUP DB_PR_HEADERS DB_QAMVERSION + DB_RDWRMASTER DB_REGISTERED DB_REP_CLIENT DB_REP_MASTER DB_SEQUENTIAL + DB_STAT_CLEAR DB_SYSTEM_MEM DB_TXNVERSION DB_TXN_NOSYNC DB_TXN_NOWAIT + DB_VERIFY_BAD */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case 'A': + if (memEQ(name, "DB_STAT_CLEAR", 13)) { + /* ^ */ +#ifdef DB_STAT_CLEAR + *iv_return = DB_STAT_CLEAR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'C': + if (memEQ(name, "DB_INCOMPLETE", 13)) { + /* ^ */ +#ifdef DB_INCOMPLETE + *iv_return = DB_INCOMPLETE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_NORUN", 13)) { + /* ^ */ +#ifdef DB_LOCK_NORUN + *iv_return = DB_LOCK_NORUN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_RIW_N", 13)) { + /* ^ */ +#ifdef DB_LOCK_RIW_N + *iv_return = DB_LOCK_RIW_N; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_TRADE", 13)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_LOCK_TRADE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_CHECKPOINT", 13)) { + /* ^ */ +#ifdef DB_CHECKPOINT + *iv_return = DB_CHECKPOINT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_PREV_NODUP", 13)) { + /* ^ */ +#ifdef DB_PREV_NODUP + *iv_return = DB_PREV_NODUP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_AGGRESSIVE", 13)) { + /* ^ */ +#ifdef DB_AGGRESSIVE + *iv_return = DB_AGGRESSIVE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOGVERSION", 13)) { + /* ^ */ +#ifdef DB_LOGVERSION + *iv_return = DB_LOGVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOG_LOCKED", 13)) { + /* ^ */ +#ifdef DB_LOG_LOCKED + *iv_return = DB_LOG_LOCKED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REGISTERED", 13)) { + /* ^ */ +#ifdef DB_REGISTERED + *iv_return = DB_REGISTERED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_INIT_MPOOL", 13)) { + /* ^ */ +#ifdef DB_INIT_MPOOL + *iv_return = DB_INIT_MPOOL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_QAMVERSION", 13)) { + /* ^ */ +#ifdef DB_QAMVERSION + *iv_return = DB_QAMVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_DONOTINDEX", 13)) { + /* ^ */ +#ifdef DB_DONOTINDEX + *iv_return = DB_DONOTINDEX; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXNVERSION", 13)) { + /* ^ */ +#ifdef DB_TXNVERSION + *iv_return = DB_TXNVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_NOSYNC", 13)) { + /* ^ */ +#ifdef DB_TXN_NOSYNC + *iv_return = DB_TXN_NOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_NOWAIT", 13)) { + /* ^ */ +#ifdef DB_TXN_NOWAIT + *iv_return = DB_TXN_NOWAIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_MPOOL_LAST", 13)) { + /* ^ */ +#ifdef DB_MPOOL_LAST + *iv_return = DB_MPOOL_LAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_NOORDERCHK", 13)) { + /* ^ */ +#ifdef DB_NOORDERCHK + *iv_return = DB_NOORDERCHK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_REP_CLIENT", 13)) { + /* ^ */ +#ifdef DB_REP_CLIENT + *iv_return = DB_REP_CLIENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REP_MASTER", 13)) { + /* ^ */ +#ifdef DB_REP_MASTER + *iv_return = DB_REP_MASTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'Q': + if (memEQ(name, "DB_SEQUENTIAL", 13)) { + /* ^ */ +#ifdef DB_SEQUENTIAL + *iv_return = DB_SEQUENTIAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_BTREEMAGIC", 13)) { + /* ^ */ +#ifdef DB_BTREEMAGIC + *iv_return = DB_BTREEMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_DIRECT_LOG", 13)) { + /* ^ */ +#ifdef DB_DIRECT_LOG + *iv_return = DB_DIRECT_LOG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_DIRTY_READ", 13)) { + /* ^ */ +#ifdef DB_DIRTY_READ + *iv_return = DB_DIRTY_READ; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERIFY_BAD", 13)) { + /* ^ */ +#ifdef DB_VERIFY_BAD + *iv_return = DB_VERIFY_BAD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_HASHOLDVER", 13)) { + /* ^ */ +#ifdef DB_HASHOLDVER + *iv_return = DB_HASHOLDVER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_SYSTEM_MEM", 13)) { + /* ^ */ +#ifdef DB_SYSTEM_MEM + *iv_return = DB_SYSTEM_MEM; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_MUTEXDEBUG", 13)) { + /* ^ */ +#ifdef DB_MUTEXDEBUG + *iv_return = DB_MUTEXDEBUG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MUTEXLOCKS", 13)) { + /* ^ */ +#ifdef DB_MUTEXLOCKS + *iv_return = DB_MUTEXLOCKS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'V': + if (memEQ(name, "DB_ENV_CREATE", 13)) { + /* ^ */ +#ifdef DB_ENV_CREATE + *iv_return = DB_ENV_CREATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ENV_NOMMAP", 13)) { + /* ^ */ +#ifdef DB_ENV_NOMMAP + *iv_return = DB_ENV_NOMMAP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ENV_THREAD", 13)) { + /* ^ */ +#ifdef DB_ENV_THREAD + *iv_return = DB_ENV_THREAD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'W': + if (memEQ(name, "DB_RDWRMASTER", 13)) { + /* ^ */ +#ifdef DB_RDWRMASTER + *iv_return = DB_RDWRMASTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'X': + if (memEQ(name, "DB_NEXT_NODUP", 13)) { + /* ^ */ +#ifdef DB_NEXT_NODUP + *iv_return = DB_NEXT_NODUP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_PR_HEADERS", 13)) { + /* ^ */ +#ifdef DB_PR_HEADERS + *iv_return = DB_PR_HEADERS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_14 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_AUTO_COMMIT DB_BTREEOLDVER DB_CHKSUM_SHA1 DB_EID_INVALID DB_ENCRYPT_AES + DB_ENV_APPINIT DB_ENV_DBLOCAL DB_ENV_LOCKING DB_ENV_LOGGING DB_ENV_NOPANIC + DB_ENV_PRIVATE DB_FILE_ID_LEN DB_HANDLE_LOCK DB_HASHVERSION DB_INVALID_EID + DB_JOIN_NOSORT DB_LOCKVERSION DB_LOCK_EXPIRE DB_LOCK_NOWAIT DB_LOCK_OLDEST + DB_LOCK_RANDOM DB_LOCK_RECORD DB_LOCK_REMOVE DB_LOCK_SWITCH DB_MAX_RECORDS + DB_MPOOL_CLEAN DB_MPOOL_DIRTY DB_NOOVERWRITE DB_NOSERVER_ID DB_ODDFILESIZE + DB_OLD_VERSION DB_OPEN_CALLED DB_RECORDCOUNT DB_RECORD_LOCK DB_REGION_ANON + DB_REGION_INIT DB_REGION_NAME DB_RENAMEMAGIC DB_REP_NEWSITE DB_REP_UNAVAIL + DB_REVSPLITOFF DB_RUNRECOVERY DB_SET_TXN_NOW DB_USE_ENVIRON DB_WRITECURSOR + DB_XIDDATASIZE */ + /* Offset 9 gives the best switch position. */ + switch (name[9]) { + case 'A': + if (memEQ(name, "DB_LOCK_RANDOM", 14)) { + /* ^ */ +#ifdef DB_LOCK_RANDOM + *iv_return = DB_LOCK_RANDOM; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_OPEN_CALLED", 14)) { + /* ^ */ +#ifdef DB_OPEN_CALLED + *iv_return = DB_OPEN_CALLED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REP_UNAVAIL", 14)) { + /* ^ */ +#ifdef DB_REP_UNAVAIL + *iv_return = DB_REP_UNAVAIL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_XIDDATASIZE", 14)) { + /* ^ */ +#ifdef DB_XIDDATASIZE + *iv_return = DB_XIDDATASIZE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'C': + if (memEQ(name, "DB_ENV_LOCKING", 14)) { + /* ^ */ +#ifdef DB_ENV_LOCKING + *iv_return = DB_ENV_LOCKING; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MAX_RECORDS", 14)) { + /* ^ */ +#ifdef DB_MAX_RECORDS + *iv_return = DB_MAX_RECORDS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MPOOL_CLEAN", 14)) { + /* ^ */ +#ifdef DB_MPOOL_CLEAN + *iv_return = DB_MPOOL_CLEAN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_RECORDCOUNT", 14)) { + /* ^ */ +#ifdef DB_RECORDCOUNT + *iv_return = DB_RECORDCOUNT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'D': + if (memEQ(name, "DB_FILE_ID_LEN", 14)) { + /* ^ */ +#ifdef DB_FILE_ID_LEN + *iv_return = DB_FILE_ID_LEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_INVALID_EID", 14)) { + /* ^ */ +#ifdef DB_INVALID_EID + *iv_return = DB_INVALID_EID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MPOOL_DIRTY", 14)) { + /* ^ */ +#ifdef DB_MPOOL_DIRTY + *iv_return = DB_MPOOL_DIRTY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_LOCK_RECORD", 14)) { + /* ^ */ +#ifdef DB_LOCK_RECORD + *iv_return = DB_LOCK_RECORD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_REMOVE", 14)) { + /* ^ */ +#ifdef DB_LOCK_REMOVE + *iv_return = DB_LOCK_REMOVE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_NOSERVER_ID", 14)) { + /* ^ */ +#ifdef DB_NOSERVER_ID + *iv_return = DB_NOSERVER_ID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ODDFILESIZE", 14)) { + /* ^ */ +#ifdef DB_ODDFILESIZE + *iv_return = DB_ODDFILESIZE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_ENV_LOGGING", 14)) { + /* ^ */ +#ifdef DB_ENV_LOGGING + *iv_return = DB_ENV_LOGGING; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_ENV_PRIVATE", 14)) { + /* ^ */ +#ifdef DB_ENV_PRIVATE + *iv_return = DB_ENV_PRIVATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REVSPLITOFF", 14)) { + /* ^ */ +#ifdef DB_REVSPLITOFF + *iv_return = DB_REVSPLITOFF; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_BTREEOLDVER", 14)) { + /* ^ */ +#ifdef DB_BTREEOLDVER + *iv_return = DB_BTREEOLDVER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ENV_DBLOCAL", 14)) { + /* ^ */ +#ifdef DB_ENV_DBLOCAL + *iv_return = DB_ENV_DBLOCAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_OLDEST", 14)) { + /* ^ */ +#ifdef DB_LOCK_OLDEST + *iv_return = DB_LOCK_OLDEST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_RENAMEMAGIC", 14)) { + /* ^ */ +#ifdef DB_RENAMEMAGIC + *iv_return = DB_RENAMEMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_SET_TXN_NOW", 14)) { + /* ^ */ +#ifdef DB_SET_TXN_NOW + *iv_return = DB_SET_TXN_NOW; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_AUTO_COMMIT", 14)) { + /* ^ */ +#ifdef DB_AUTO_COMMIT + *iv_return = DB_AUTO_COMMIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_JOIN_NOSORT", 14)) { + /* ^ */ +#ifdef DB_JOIN_NOSORT + *iv_return = DB_JOIN_NOSORT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_NOWAIT", 14)) { + /* ^ */ +#ifdef DB_LOCK_NOWAIT + *iv_return = DB_LOCK_NOWAIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_RUNRECOVERY", 14)) { + /* ^ */ +#ifdef DB_RUNRECOVERY + *iv_return = DB_RUNRECOVERY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_ENV_APPINIT", 14)) { + /* ^ */ +#ifdef DB_ENV_APPINIT + *iv_return = DB_ENV_APPINIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ENV_NOPANIC", 14)) { + /* ^ */ +#ifdef DB_ENV_NOPANIC + *iv_return = DB_ENV_NOPANIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_HASHVERSION", 14)) { + /* ^ */ +#ifdef DB_HASHVERSION + *iv_return = DB_HASHVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCKVERSION", 14)) { + /* ^ */ +#ifdef DB_LOCKVERSION + *iv_return = DB_LOCKVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_OLD_VERSION", 14)) { + /* ^ */ +#ifdef DB_OLD_VERSION + *iv_return = DB_OLD_VERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_ENCRYPT_AES", 14)) { + /* ^ */ +#ifdef DB_ENCRYPT_AES + *iv_return = DB_ENCRYPT_AES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_WRITECURSOR", 14)) { + /* ^ */ +#ifdef DB_WRITECURSOR + *iv_return = DB_WRITECURSOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'V': + if (memEQ(name, "DB_EID_INVALID", 14)) { + /* ^ */ +#ifdef DB_EID_INVALID + *iv_return = DB_EID_INVALID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_USE_ENVIRON", 14)) { + /* ^ */ +#ifdef DB_USE_ENVIRON + *iv_return = DB_USE_ENVIRON; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'W': + if (memEQ(name, "DB_LOCK_SWITCH", 14)) { + /* ^ */ +#ifdef DB_LOCK_SWITCH + *iv_return = DB_LOCK_SWITCH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_NOOVERWRITE", 14)) { + /* ^ */ +#ifdef DB_NOOVERWRITE + *iv_return = DB_NOOVERWRITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REP_NEWSITE", 14)) { + /* ^ */ +#ifdef DB_REP_NEWSITE + *iv_return = DB_REP_NEWSITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'X': + if (memEQ(name, "DB_LOCK_EXPIRE", 14)) { + /* ^ */ +#ifdef DB_LOCK_EXPIRE + *iv_return = DB_LOCK_EXPIRE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_CHKSUM_SHA1", 14)) { + /* ^ */ +#ifdef DB_CHKSUM_SHA1 + *iv_return = DB_CHKSUM_SHA1; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_HANDLE_LOCK", 14)) { + /* ^ */ +#ifdef DB_HANDLE_LOCK + *iv_return = DB_HANDLE_LOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_RECORD_LOCK", 14)) { + /* ^ */ +#ifdef DB_RECORD_LOCK + *iv_return = DB_RECORD_LOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REGION_ANON", 14)) { + /* ^ */ +#ifdef DB_REGION_ANON + *iv_return = DB_REGION_ANON; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REGION_INIT", 14)) { + /* ^ */ +#ifdef DB_REGION_INIT + *iv_return = DB_REGION_INIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REGION_NAME", 14)) { + /* ^ */ +#ifdef DB_REGION_NAME + *iv_return = DB_REGION_NAME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_15 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_APPLY_LOGREG DB_BTREEVERSION DB_CONSUME_WAIT DB_ENV_LOCKDOWN + DB_ENV_PANIC_OK DB_ENV_YIELDCPU DB_LOCK_DEFAULT DB_LOCK_INHERIT + DB_LOCK_NOTHELD DB_LOCK_PUT_ALL DB_LOCK_PUT_OBJ DB_LOCK_TIMEOUT + DB_LOCK_UPGRADE DB_MPOOL_CREATE DB_MPOOL_EXTENT DB_MULTIPLE_KEY + DB_OPFLAGS_MASK DB_ORDERCHKONLY DB_PRIORITY_LOW DB_REGION_MAGIC + DB_REP_LOGSONLY DB_REP_OUTDATED DB_SURPRISE_KID DB_TEST_POSTLOG + DB_TEST_PREOPEN DB_TXN_GETPGNOS DB_TXN_LOCK_2PL DB_TXN_LOG_MASK + DB_TXN_LOG_REDO DB_TXN_LOG_UNDO DB_VERIFY_FATAL */ + /* Offset 10 gives the best switch position. */ + switch (name[10]) { + case 'D': + if (memEQ(name, "DB_REP_OUTDATED", 15)) { + /* ^ */ +#ifdef DB_REP_OUTDATED + *iv_return = DB_REP_OUTDATED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_MULTIPLE_KEY", 15)) { + /* ^ */ +#ifdef DB_MULTIPLE_KEY + *iv_return = DB_MULTIPLE_KEY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_SURPRISE_KID", 15)) { + /* ^ */ +#ifdef DB_SURPRISE_KID + *iv_return = DB_SURPRISE_KID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_PREOPEN", 15)) { + /* ^ */ +#ifdef DB_TEST_PREOPEN + *iv_return = DB_TEST_PREOPEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'F': + if (memEQ(name, "DB_LOCK_DEFAULT", 15)) { + /* ^ */ +#ifdef DB_LOCK_DEFAULT + *iv_return = DB_LOCK_DEFAULT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERIFY_FATAL", 15)) { + /* ^ */ +#ifdef DB_VERIFY_FATAL + *iv_return = DB_VERIFY_FATAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_LOCK_UPGRADE", 15)) { + /* ^ */ +#ifdef DB_LOCK_UPGRADE + *iv_return = DB_LOCK_UPGRADE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'H': + if (memEQ(name, "DB_LOCK_INHERIT", 15)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 7) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 7 && \ + DB_VERSION_PATCH >= 1) + *iv_return = DB_LOCK_INHERIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_ENV_PANIC_OK", 15)) { + /* ^ */ +#ifdef DB_ENV_PANIC_OK + *iv_return = DB_ENV_PANIC_OK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'K': + if (memEQ(name, "DB_ENV_LOCKDOWN", 15)) { + /* ^ */ +#ifdef DB_ENV_LOCKDOWN + *iv_return = DB_ENV_LOCKDOWN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ORDERCHKONLY", 15)) { + /* ^ */ +#ifdef DB_ORDERCHKONLY + *iv_return = DB_ORDERCHKONLY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_LOCK_2PL", 15)) { + /* ^ */ +#ifdef DB_TXN_LOCK_2PL + *iv_return = DB_TXN_LOCK_2PL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_ENV_YIELDCPU", 15)) { + /* ^ */ +#ifdef DB_ENV_YIELDCPU + *iv_return = DB_ENV_YIELDCPU; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_LOCK_TIMEOUT", 15)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 7) + *iv_return = DB_LOCK_TIMEOUT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REGION_MAGIC", 15)) { + /* ^ */ +#ifdef DB_REGION_MAGIC + *iv_return = DB_REGION_MAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_APPLY_LOGREG", 15)) { + /* ^ */ +#ifdef DB_APPLY_LOGREG + *iv_return = DB_APPLY_LOGREG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_TXN_GETPGNOS", 15)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_TXN_GETPGNOS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_BTREEVERSION", 15)) { + /* ^ */ +#ifdef DB_BTREEVERSION + *iv_return = DB_BTREEVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MPOOL_CREATE", 15)) { + /* ^ */ +#ifdef DB_MPOOL_CREATE + *iv_return = DB_MPOOL_CREATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_REP_LOGSONLY", 15)) { + /* ^ */ +#ifdef DB_REP_LOGSONLY + *iv_return = DB_REP_LOGSONLY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_POSTLOG", 15)) { + /* ^ */ +#ifdef DB_TEST_POSTLOG + *iv_return = DB_TEST_POSTLOG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_LOCK_NOTHELD", 15)) { + /* ^ */ +#ifdef DB_LOCK_NOTHELD + *iv_return = DB_LOCK_NOTHELD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_PUT_ALL", 15)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_LOCK_PUT_ALL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_PUT_OBJ", 15)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 2) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 0) + *iv_return = DB_LOCK_PUT_OBJ; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'X': + if (memEQ(name, "DB_MPOOL_EXTENT", 15)) { + /* ^ */ +#ifdef DB_MPOOL_EXTENT + *iv_return = DB_MPOOL_EXTENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'Y': + if (memEQ(name, "DB_PRIORITY_LOW", 15)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_PRIORITY_LOW; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_CONSUME_WAIT", 15)) { + /* ^ */ +#ifdef DB_CONSUME_WAIT + *iv_return = DB_CONSUME_WAIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_OPFLAGS_MASK", 15)) { + /* ^ */ +#ifdef DB_OPFLAGS_MASK + *iv_return = DB_OPFLAGS_MASK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_LOG_MASK", 15)) { + /* ^ */ +#ifdef DB_TXN_LOG_MASK + *iv_return = DB_TXN_LOG_MASK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_LOG_REDO", 15)) { + /* ^ */ +#ifdef DB_TXN_LOG_REDO + *iv_return = DB_TXN_LOG_REDO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_LOG_UNDO", 15)) { + /* ^ */ +#ifdef DB_TXN_LOG_UNDO + *iv_return = DB_TXN_LOG_UNDO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_16 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_BROADCAST_EID DB_CACHED_COUNTS DB_EID_BROADCAST DB_ENV_CDB_ALLDB + DB_ENV_DIRECT_DB DB_ENV_NOLOCKING DB_ENV_OVERWRITE DB_ENV_RPCCLIENT + DB_FCNTL_LOCKING DB_JAVA_CALLBACK DB_LOCK_CONFLICT DB_LOCK_DEADLOCK + DB_LOCK_MAXLOCKS DB_LOCK_MINLOCKS DB_LOCK_MINWRITE DB_LOCK_NOTEXIST + DB_LOCK_PUT_READ DB_LOCK_YOUNGEST DB_LOGC_BUF_SIZE DB_MPOOL_DISCARD + DB_MPOOL_PRIVATE DB_NOSERVER_HOME DB_PAGE_NOTFOUND DB_PRIORITY_HIGH + DB_RECOVER_FATAL DB_REP_DUPMASTER DB_REP_NEWMASTER DB_REP_PERMANENT + DB_SECONDARY_BAD DB_TEST_POSTOPEN DB_TEST_POSTSYNC DB_TXN_LOCK_MASK + DB_TXN_OPENFILES DB_VERB_CHKPOINT DB_VERB_DEADLOCK DB_VERB_RECOVERY + DB_VERB_WAITSFOR DB_VERSION_MAJOR DB_VERSION_MINOR DB_VERSION_PATCH + DB_VRFY_FLAGMASK */ + /* Offset 12 gives the best switch position. */ + switch (name[12]) { + case 'A': + if (memEQ(name, "DB_RECOVER_FATAL", 16)) { + /* ^ */ +#ifdef DB_RECOVER_FATAL + *iv_return = DB_RECOVER_FATAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERSION_MAJOR", 16)) { + /* ^ */ +#ifdef DB_VERSION_MAJOR + *iv_return = DB_VERSION_MAJOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERSION_PATCH", 16)) { + /* ^ */ +#ifdef DB_VERSION_PATCH + *iv_return = DB_VERSION_PATCH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'B': + if (memEQ(name, "DB_JAVA_CALLBACK", 16)) { + /* ^ */ +#ifdef DB_JAVA_CALLBACK + *iv_return = DB_JAVA_CALLBACK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'C': + if (memEQ(name, "DB_EID_BROADCAST", 16)) { + /* ^ */ +#ifdef DB_EID_BROADCAST + *iv_return = DB_EID_BROADCAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_MPOOL_DISCARD", 16)) { + /* ^ */ +#ifdef DB_MPOOL_DISCARD + *iv_return = DB_MPOOL_DISCARD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_LOCK_YOUNGEST", 16)) { + /* ^ */ +#ifdef DB_LOCK_YOUNGEST + *iv_return = DB_LOCK_YOUNGEST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'H': + if (memEQ(name, "DB_NOSERVER_HOME", 16)) { + /* ^ */ +#ifdef DB_NOSERVER_HOME + *iv_return = DB_NOSERVER_HOME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_PRIORITY_HIGH", 16)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_PRIORITY_HIGH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_ENV_RPCCLIENT", 16)) { + /* ^ */ +#ifdef DB_ENV_RPCCLIENT + *iv_return = DB_ENV_RPCCLIENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_OPENFILES", 16)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 12) + *iv_return = DB_TXN_OPENFILES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERSION_MINOR", 16)) { + /* ^ */ +#ifdef DB_VERSION_MINOR + *iv_return = DB_VERSION_MINOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'K': + if (memEQ(name, "DB_ENV_NOLOCKING", 16)) { + /* ^ */ +#ifdef DB_ENV_NOLOCKING + *iv_return = DB_ENV_NOLOCKING; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_FCNTL_LOCKING", 16)) { + /* ^ */ +#ifdef DB_FCNTL_LOCKING + *iv_return = DB_FCNTL_LOCKING; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_ENV_CDB_ALLDB", 16)) { + /* ^ */ +#ifdef DB_ENV_CDB_ALLDB + *iv_return = DB_ENV_CDB_ALLDB; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_CONFLICT", 16)) { + /* ^ */ +#ifdef DB_LOCK_CONFLICT + *iv_return = DB_LOCK_CONFLICT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_DEADLOCK", 16)) { + /* ^ */ +#ifdef DB_LOCK_DEADLOCK + *iv_return = DB_LOCK_DEADLOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERB_DEADLOCK", 16)) { + /* ^ */ +#ifdef DB_VERB_DEADLOCK + *iv_return = DB_VERB_DEADLOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_TXN_LOCK_MASK", 16)) { + /* ^ */ +#ifdef DB_TXN_LOCK_MASK + *iv_return = DB_TXN_LOCK_MASK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VRFY_FLAGMASK", 16)) { + /* ^ */ +#ifdef DB_VRFY_FLAGMASK + *iv_return = DB_VRFY_FLAGMASK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_REP_PERMANENT", 16)) { + /* ^ */ +#ifdef DB_REP_PERMANENT + *iv_return = DB_REP_PERMANENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_LOCK_MAXLOCKS", 16)) { + /* ^ */ +#ifdef DB_LOCK_MAXLOCKS + *iv_return = DB_LOCK_MAXLOCKS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_MINLOCKS", 16)) { + /* ^ */ +#ifdef DB_LOCK_MINLOCKS + *iv_return = DB_LOCK_MINLOCKS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_PAGE_NOTFOUND", 16)) { + /* ^ */ +#ifdef DB_PAGE_NOTFOUND + *iv_return = DB_PAGE_NOTFOUND; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_POSTOPEN", 16)) { + /* ^ */ +#ifdef DB_TEST_POSTOPEN + *iv_return = DB_TEST_POSTOPEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERB_CHKPOINT", 16)) { + /* ^ */ +#ifdef DB_VERB_CHKPOINT + *iv_return = DB_VERB_CHKPOINT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_ENV_OVERWRITE", 16)) { + /* ^ */ +#ifdef DB_ENV_OVERWRITE + *iv_return = DB_ENV_OVERWRITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_MINWRITE", 16)) { + /* ^ */ +#ifdef DB_LOCK_MINWRITE + *iv_return = DB_LOCK_MINWRITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_PUT_READ", 16)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 7) + *iv_return = DB_LOCK_PUT_READ; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_LOGC_BUF_SIZE", 16)) { + /* ^ */ +#ifdef DB_LOGC_BUF_SIZE + *iv_return = DB_LOGC_BUF_SIZE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REP_DUPMASTER", 16)) { + /* ^ */ +#ifdef DB_REP_DUPMASTER + *iv_return = DB_REP_DUPMASTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_REP_NEWMASTER", 16)) { + /* ^ */ +#ifdef DB_REP_NEWMASTER + *iv_return = DB_REP_NEWMASTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_POSTSYNC", 16)) { + /* ^ */ +#ifdef DB_TEST_POSTSYNC + *iv_return = DB_TEST_POSTSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERB_WAITSFOR", 16)) { + /* ^ */ +#ifdef DB_VERB_WAITSFOR + *iv_return = DB_VERB_WAITSFOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_ENV_DIRECT_DB", 16)) { + /* ^ */ +#ifdef DB_ENV_DIRECT_DB + *iv_return = DB_ENV_DIRECT_DB; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_CACHED_COUNTS", 16)) { + /* ^ */ +#ifdef DB_CACHED_COUNTS + *iv_return = DB_CACHED_COUNTS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'V': + if (memEQ(name, "DB_MPOOL_PRIVATE", 16)) { + /* ^ */ +#ifdef DB_MPOOL_PRIVATE + *iv_return = DB_MPOOL_PRIVATE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERB_RECOVERY", 16)) { + /* ^ */ +#ifdef DB_VERB_RECOVERY + *iv_return = DB_VERB_RECOVERY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'X': + if (memEQ(name, "DB_LOCK_NOTEXIST", 16)) { + /* ^ */ +#ifdef DB_LOCK_NOTEXIST + *iv_return = DB_LOCK_NOTEXIST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_BROADCAST_EID", 16)) { + /* ^ */ +#ifdef DB_BROADCAST_EID + *iv_return = DB_BROADCAST_EID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_SECONDARY_BAD", 16)) { + /* ^ */ +#ifdef DB_SECONDARY_BAD + *iv_return = DB_SECONDARY_BAD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_17 (pTHX_ const char *name, IV *iv_return, const char **pv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_ENV_DIRECT_LOG DB_ENV_REP_CLIENT DB_ENV_REP_MASTER DB_ENV_STANDALONE + DB_ENV_SYSTEM_MEM DB_ENV_TXN_NOSYNC DB_ENV_USER_ALLOC DB_GET_BOTH_RANGE + DB_LOG_SILENT_ERR DB_RPC_SERVERPROG DB_RPC_SERVERVERS DB_TEST_ELECTINIT + DB_TEST_ELECTSEND DB_TEST_PRERENAME DB_TXN_POPENFILES DB_VERSION_STRING */ + /* Offset 14 gives the best switch position. */ + switch (name[14]) { + case 'A': + if (memEQ(name, "DB_TEST_PRERENAME", 17)) { + /* ^ */ +#ifdef DB_TEST_PRERENAME + *iv_return = DB_TEST_PRERENAME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_ENV_REP_CLIENT", 17)) { + /* ^ */ +#ifdef DB_ENV_REP_CLIENT + *iv_return = DB_ENV_REP_CLIENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOG_SILENT_ERR", 17)) { + /* ^ */ +#ifdef DB_LOG_SILENT_ERR + *iv_return = DB_LOG_SILENT_ERR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_RPC_SERVERVERS", 17)) { + /* ^ */ +#ifdef DB_RPC_SERVERVERS + *iv_return = DB_RPC_SERVERVERS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_ELECTSEND", 17)) { + /* ^ */ +#ifdef DB_TEST_ELECTSEND + *iv_return = DB_TEST_ELECTSEND; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_VERSION_STRING", 17)) { + /* ^ */ +#ifdef DB_VERSION_STRING + *pv_return = DB_VERSION_STRING; + return PERL_constant_ISPV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_ENV_DIRECT_LOG", 17)) { + /* ^ */ +#ifdef DB_ENV_DIRECT_LOG + *iv_return = DB_ENV_DIRECT_LOG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ENV_USER_ALLOC", 17)) { + /* ^ */ +#ifdef DB_ENV_USER_ALLOC + *iv_return = DB_ENV_USER_ALLOC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_POPENFILES", 17)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 3 && \ + DB_VERSION_PATCH >= 4) + *iv_return = DB_TXN_POPENFILES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_ENV_SYSTEM_MEM", 17)) { + /* ^ */ +#ifdef DB_ENV_SYSTEM_MEM + *iv_return = DB_ENV_SYSTEM_MEM; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_GET_BOTH_RANGE", 17)) { + /* ^ */ +#ifdef DB_GET_BOTH_RANGE + *iv_return = DB_GET_BOTH_RANGE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_ELECTINIT", 17)) { + /* ^ */ +#ifdef DB_TEST_ELECTINIT + *iv_return = DB_TEST_ELECTINIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_ENV_STANDALONE", 17)) { + /* ^ */ +#ifdef DB_ENV_STANDALONE + *iv_return = DB_ENV_STANDALONE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_RPC_SERVERPROG", 17)) { + /* ^ */ +#ifdef DB_RPC_SERVERPROG + *iv_return = DB_RPC_SERVERPROG; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_ENV_REP_MASTER", 17)) { + /* ^ */ +#ifdef DB_ENV_REP_MASTER + *iv_return = DB_ENV_REP_MASTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'Y': + if (memEQ(name, "DB_ENV_TXN_NOSYNC", 17)) { + /* ^ */ +#ifdef DB_ENV_TXN_NOSYNC + *iv_return = DB_ENV_TXN_NOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_18 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_ALREADY_ABORTED DB_ENV_AUTO_COMMIT DB_ENV_OPEN_CALLED + DB_ENV_REGION_INIT DB_LOCK_NOTGRANTED DB_MPOOL_NEW_GROUP + DB_PR_RECOVERYTEST DB_SET_TXN_TIMEOUT DB_TEST_ELECTVOTE1 + DB_TEST_ELECTVOTE2 DB_TEST_ELECTWAIT1 DB_TEST_ELECTWAIT2 + DB_TEST_POSTRENAME DB_TEST_PREDESTROY DB_TEST_PREEXTOPEN */ + /* Offset 13 gives the best switch position. */ + switch (name[13]) { + case 'A': + if (memEQ(name, "DB_ENV_OPEN_CALLED", 18)) { + /* ^ */ +#ifdef DB_ENV_OPEN_CALLED + *iv_return = DB_ENV_OPEN_CALLED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_NOTGRANTED", 18)) { + /* ^ */ +#ifdef DB_LOCK_NOTGRANTED + *iv_return = DB_LOCK_NOTGRANTED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_TEST_POSTRENAME", 18)) { + /* ^ */ +#ifdef DB_TEST_POSTRENAME + *iv_return = DB_TEST_POSTRENAME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_MPOOL_NEW_GROUP", 18)) { + /* ^ */ +#ifdef DB_MPOOL_NEW_GROUP + *iv_return = DB_MPOOL_NEW_GROUP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "DB_SET_TXN_TIMEOUT", 18)) { + /* ^ */ +#ifdef DB_SET_TXN_TIMEOUT + *iv_return = DB_SET_TXN_TIMEOUT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_ALREADY_ABORTED", 18)) { + /* ^ */ +#ifdef DB_ALREADY_ABORTED + *iv_return = DB_ALREADY_ABORTED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_ENV_AUTO_COMMIT", 18)) { + /* ^ */ +#ifdef DB_ENV_AUTO_COMMIT + *iv_return = DB_ENV_AUTO_COMMIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "DB_TEST_PREDESTROY", 18)) { + /* ^ */ +#ifdef DB_TEST_PREDESTROY + *iv_return = DB_TEST_PREDESTROY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_TEST_PREEXTOPEN", 18)) { + /* ^ */ +#ifdef DB_TEST_PREEXTOPEN + *iv_return = DB_TEST_PREEXTOPEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'V': + if (memEQ(name, "DB_TEST_ELECTVOTE1", 18)) { + /* ^ */ +#ifdef DB_TEST_ELECTVOTE1 + *iv_return = DB_TEST_ELECTVOTE1; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_ELECTVOTE2", 18)) { + /* ^ */ +#ifdef DB_TEST_ELECTVOTE2 + *iv_return = DB_TEST_ELECTVOTE2; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'W': + if (memEQ(name, "DB_TEST_ELECTWAIT1", 18)) { + /* ^ */ +#ifdef DB_TEST_ELECTWAIT1 + *iv_return = DB_TEST_ELECTWAIT1; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_ELECTWAIT2", 18)) { + /* ^ */ +#ifdef DB_TEST_ELECTWAIT2 + *iv_return = DB_TEST_ELECTWAIT2; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'Y': + if (memEQ(name, "DB_PR_RECOVERYTEST", 18)) { + /* ^ */ +#ifdef DB_PR_RECOVERYTEST + *iv_return = DB_PR_RECOVERYTEST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_ENV_REGION_INIT", 18)) { + /* ^ */ +#ifdef DB_ENV_REGION_INIT + *iv_return = DB_ENV_REGION_INIT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_19 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_ENV_REP_LOGSONLY DB_LOCK_FREE_LOCKER DB_LOCK_GET_TIMEOUT + DB_LOCK_SET_TIMEOUT DB_PRIORITY_DEFAULT DB_REP_HOLDELECTION + DB_SET_LOCK_TIMEOUT DB_TEST_POSTDESTROY DB_TEST_POSTEXTOPEN + DB_TEST_POSTLOGMETA DB_TEST_SUBDB_LOCKS DB_TXN_FORWARD_ROLL + DB_TXN_LOG_UNDOREDO DB_TXN_WRITE_NOSYNC DB_UNRESOLVED_CHILD + DB_UPDATE_SECONDARY DB_USE_ENVIRON_ROOT DB_VERB_REPLICATION */ + /* Offset 9 gives the best switch position. */ + switch (name[9]) { + case 'C': + if (memEQ(name, "DB_SET_LOCK_TIMEOUT", 19)) { + /* ^ */ +#ifdef DB_SET_LOCK_TIMEOUT + *iv_return = DB_SET_LOCK_TIMEOUT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_LOCK_GET_TIMEOUT", 19)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \ + DB_VERSION_PATCH >= 7) + *iv_return = DB_LOCK_GET_TIMEOUT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_LOCK_SET_TIMEOUT", 19)) { + /* ^ */ +#ifdef DB_LOCK_SET_TIMEOUT + *iv_return = DB_LOCK_SET_TIMEOUT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_VERB_REPLICATION", 19)) { + /* ^ */ +#ifdef DB_VERB_REPLICATION + *iv_return = DB_VERB_REPLICATION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'G': + if (memEQ(name, "DB_TXN_LOG_UNDOREDO", 19)) { + /* ^ */ +#ifdef DB_TXN_LOG_UNDOREDO + *iv_return = DB_TXN_LOG_UNDOREDO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'I': + if (memEQ(name, "DB_TXN_WRITE_NOSYNC", 19)) { + /* ^ */ +#ifdef DB_TXN_WRITE_NOSYNC + *iv_return = DB_TXN_WRITE_NOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_REP_HOLDELECTION", 19)) { + /* ^ */ +#ifdef DB_REP_HOLDELECTION + *iv_return = DB_REP_HOLDELECTION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_UNRESOLVED_CHILD", 19)) { + /* ^ */ +#ifdef DB_UNRESOLVED_CHILD + *iv_return = DB_UNRESOLVED_CHILD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_TEST_POSTDESTROY", 19)) { + /* ^ */ +#ifdef DB_TEST_POSTDESTROY + *iv_return = DB_TEST_POSTDESTROY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_POSTEXTOPEN", 19)) { + /* ^ */ +#ifdef DB_TEST_POSTEXTOPEN + *iv_return = DB_TEST_POSTEXTOPEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TEST_POSTLOGMETA", 19)) { + /* ^ */ +#ifdef DB_TEST_POSTLOGMETA + *iv_return = DB_TEST_POSTLOGMETA; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_ENV_REP_LOGSONLY", 19)) { + /* ^ */ +#ifdef DB_ENV_REP_LOGSONLY + *iv_return = DB_ENV_REP_LOGSONLY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_LOCK_FREE_LOCKER", 19)) { + /* ^ */ +#ifdef DB_LOCK_FREE_LOCKER + *iv_return = DB_LOCK_FREE_LOCKER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_FORWARD_ROLL", 19)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 12) + *iv_return = DB_TXN_FORWARD_ROLL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_PRIORITY_DEFAULT", 19)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_PRIORITY_DEFAULT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_TEST_SUBDB_LOCKS", 19)) { + /* ^ */ +#ifdef DB_TEST_SUBDB_LOCKS + *iv_return = DB_TEST_SUBDB_LOCKS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'V': + if (memEQ(name, "DB_USE_ENVIRON_ROOT", 19)) { + /* ^ */ +#ifdef DB_USE_ENVIRON_ROOT + *iv_return = DB_USE_ENVIRON_ROOT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_UPDATE_SECONDARY", 19)) { + /* ^ */ +#ifdef DB_UPDATE_SECONDARY + *iv_return = DB_UPDATE_SECONDARY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_20 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_CXX_NO_EXCEPTIONS DB_LOGFILEID_INVALID DB_PANIC_ENVIRONMENT + DB_PRIORITY_VERY_LOW DB_TEST_PREEXTDELETE DB_TEST_PREEXTUNLINK + DB_TXN_BACKWARD_ROLL DB_TXN_LOCK_OPTIMIST */ + /* Offset 14 gives the best switch position. */ + switch (name[14]) { + case 'D': + if (memEQ(name, "DB_TEST_PREEXTDELETE", 20)) { + /* ^ */ +#ifdef DB_TEST_PREEXTDELETE + *iv_return = DB_TEST_PREEXTDELETE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + if (memEQ(name, "DB_TXN_BACKWARD_ROLL", 20)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 12) + *iv_return = DB_TXN_BACKWARD_ROLL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_LOGFILEID_INVALID", 20)) { + /* ^ */ +#ifdef DB_LOGFILEID_INVALID + *iv_return = DB_LOGFILEID_INVALID; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "DB_PANIC_ENVIRONMENT", 20)) { + /* ^ */ +#ifdef DB_PANIC_ENVIRONMENT + *iv_return = DB_PANIC_ENVIRONMENT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_CXX_NO_EXCEPTIONS", 20)) { + /* ^ */ +#ifdef DB_CXX_NO_EXCEPTIONS + *iv_return = DB_CXX_NO_EXCEPTIONS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "DB_PRIORITY_VERY_LOW", 20)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_PRIORITY_VERY_LOW; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "DB_TXN_LOCK_OPTIMIST", 20)) { + /* ^ */ +#ifdef DB_TXN_LOCK_OPTIMIST + *iv_return = DB_TXN_LOCK_OPTIMIST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'U': + if (memEQ(name, "DB_TEST_PREEXTUNLINK", 20)) { + /* ^ */ +#ifdef DB_TEST_PREEXTUNLINK + *iv_return = DB_TEST_PREEXTUNLINK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_21 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_LOCK_UPGRADE_WRITE DB_PRIORITY_VERY_HIGH DB_TEST_POSTEXTDELETE + DB_TEST_POSTEXTUNLINK DB_TXN_BACKWARD_ALLOC */ + /* Offset 16 gives the best switch position. */ + switch (name[16]) { + case 'A': + if (memEQ(name, "DB_TXN_BACKWARD_ALLOC", 21)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_TXN_BACKWARD_ALLOC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'E': + if (memEQ(name, "DB_TEST_POSTEXTDELETE", 21)) { + /* ^ */ +#ifdef DB_TEST_POSTEXTDELETE + *iv_return = DB_TEST_POSTEXTDELETE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "DB_TEST_POSTEXTUNLINK", 21)) { + /* ^ */ +#ifdef DB_TEST_POSTEXTUNLINK + *iv_return = DB_TEST_POSTEXTUNLINK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'W': + if (memEQ(name, "DB_LOCK_UPGRADE_WRITE", 21)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 3) || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 3 && \ + DB_VERSION_PATCH >= 4) + *iv_return = DB_LOCK_UPGRADE_WRITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_PRIORITY_VERY_HIGH", 21)) { + /* ^ */ +#if (DB_VERSION_MAJOR > 4) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \ + (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \ + DB_VERSION_PATCH >= 17) + *iv_return = DB_PRIORITY_VERY_HIGH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant (pTHX_ const char *name, STRLEN len, IV *iv_return, const char **pv_return) { + /* Initially switch on the length of the name. */ + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!/home/paul/perl/install/redhat6.1/5.8.0/bin/perl5.8.0 -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +my $types = {map {($_, 1)} qw(IV PV)}; +my @names = (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_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_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_EXPIRE + DB_LOCK_FREE_LOCKER 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_RANDOM DB_LOCK_RECORD DB_LOCK_REMOVE DB_LOCK_RIW_N + DB_LOCK_RW_N DB_LOCK_SET_TIMEOUT DB_LOCK_SWITCH DB_LOCK_UPGRADE + 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_PRIVATE DB_PR_HEADERS DB_PR_PAGE DB_PR_RECOVERYTEST + DB_QAMMAGIC DB_QAMOLDVER DB_QAMVERSION DB_RDONLY DB_RDWRMASTER + 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_CKP + 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_REDO DB_TXN_SYNC DB_TXN_UNDO + DB_TXN_WRITE_NOSYNC 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_VRFY_FLAGMASK DB_WRITECURSOR DB_WRITELOCK DB_WRITEOPEN + DB_WRNOSYNC DB_XA_CREATE DB_XIDDATASIZE DB_YIELDCPU), + {name=>"DB_BTREE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_HASH", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_LOCK_DUMP", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_LOCK_GET", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_LOCK_GET_TIMEOUT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 7)\n", "#endif\n"]}, + {name=>"DB_LOCK_INHERIT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 7) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 7 && \\\n DB_VERSION_PATCH >= 1)\n", "#endif\n"]}, + {name=>"DB_LOCK_PUT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_LOCK_PUT_ALL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_LOCK_PUT_OBJ", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_LOCK_PUT_READ", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 7)\n", "#endif\n"]}, + {name=>"DB_LOCK_TIMEOUT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 7)\n", "#endif\n"]}, + {name=>"DB_LOCK_TRADE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_LOCK_UPGRADE_WRITE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 4)\n", "#endif\n"]}, + {name=>"DB_PRIORITY_DEFAULT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_PRIORITY_HIGH", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_PRIORITY_LOW", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_PRIORITY_VERY_HIGH", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_PRIORITY_VERY_LOW", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_QUEUE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 55)\n", "#endif\n"]}, + {name=>"DB_RECNO", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_TXN_ABORT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 12)\n", "#endif\n"]}, + {name=>"DB_TXN_APPLY", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 7)\n", "#endif\n"]}, + {name=>"DB_TXN_BACKWARD_ALLOC", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_TXN_BACKWARD_ROLL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 12)\n", "#endif\n"]}, + {name=>"DB_TXN_FORWARD_ROLL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 12)\n", "#endif\n"]}, + {name=>"DB_TXN_GETPGNOS", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_TXN_OPENFILES", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 12)\n", "#endif\n"]}, + {name=>"DB_TXN_POPENFILES", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 4)\n", "#endif\n"]}, + {name=>"DB_TXN_PRINT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 17)\n", "#endif\n"]}, + {name=>"DB_UNKNOWN", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 0)\n", "#endif\n"]}, + {name=>"DB_VERSION_STRING", type=>"PV"}); + +print constant_types(); # macro defs +foreach (C_constant ("BerkeleyDB", 'constant', 'IV', $types, undef, 3, @names) ) { + print $_, "\n"; # C constant subs +} +print "#### XS Section:\n"; +print XS_constant ("BerkeleyDB", $types); +__END__ + */ + + switch (len) { + case 6: + return constant_6 (aTHX_ name, iv_return); + break; + case 7: + return constant_7 (aTHX_ name, iv_return); + break; + case 8: + return constant_8 (aTHX_ name, iv_return); + break; + case 9: + return constant_9 (aTHX_ name, iv_return); + break; + case 10: + return constant_10 (aTHX_ name, iv_return); + break; + case 11: + return constant_11 (aTHX_ name, iv_return); + break; + case 12: + return constant_12 (aTHX_ name, iv_return); + break; + case 13: + return constant_13 (aTHX_ name, iv_return); + break; + case 14: + return constant_14 (aTHX_ name, iv_return); + break; + case 15: + return constant_15 (aTHX_ name, iv_return); + break; + case 16: + return constant_16 (aTHX_ name, iv_return); + break; + case 17: + return constant_17 (aTHX_ name, iv_return, pv_return); + break; + case 18: + return constant_18 (aTHX_ name, iv_return); + break; + case 19: + return constant_19 (aTHX_ name, iv_return); + break; + case 20: + return constant_20 (aTHX_ name, iv_return); + break; + case 21: + return constant_21 (aTHX_ name, iv_return); + break; + case 22: + /* Names all of length 22. */ + /* DB_ENV_RPCCLIENT_GIVEN DB_TXN_LOCK_OPTIMISTIC */ + /* Offset 8 gives the best switch position. */ + switch (name[8]) { + case 'O': + if (memEQ(name, "DB_TXN_LOCK_OPTIMISTIC", 22)) { + /* ^ */ +#ifdef DB_TXN_LOCK_OPTIMISTIC + *iv_return = DB_TXN_LOCK_OPTIMISTIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "DB_ENV_RPCCLIENT_GIVEN", 22)) { + /* ^ */ +#ifdef DB_ENV_RPCCLIENT_GIVEN + *iv_return = DB_ENV_RPCCLIENT_GIVEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + break; + case 23: + if (memEQ(name, "DB_ENV_TXN_WRITE_NOSYNC", 23)) { +#ifdef DB_ENV_TXN_WRITE_NOSYNC + *iv_return = DB_ENV_TXN_WRITE_NOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + diff --git a/bdb/perl/BerkeleyDB/constants.xs b/bdb/perl/BerkeleyDB/constants.xs new file mode 100644 index 00000000000..1b2c8b2c3c8 --- /dev/null +++ b/bdb/perl/BerkeleyDB/constants.xs @@ -0,0 +1,87 @@ +void +constant(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; + IV iv; + /* NV nv; Uncomment this if you need to return NVs */ + const char *pv; + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: + /* Change this to constant(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ + type = constant(aTHX_ s, len, &iv, &pv); + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = sv_2mortal(newSVpvf("%s is not a valid BerkeleyDB macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined BerkeleyDB macro %s, used", s)); + PUSHs(sv); + break; + case PERL_constant_ISIV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHi(iv); + break; + /* Uncomment this if you need to return NOs + case PERL_constant_ISNO: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_no); + break; */ + /* Uncomment this if you need to return NVs + case PERL_constant_ISNV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHn(nv); + break; */ + case PERL_constant_ISPV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, strlen(pv)); + break; + /* Uncomment this if you need to return PVNs + case PERL_constant_ISPVN: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, iv); + break; */ + /* Uncomment this if you need to return SVs + case PERL_constant_ISSV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(sv); + break; */ + /* Uncomment this if you need to return UNDEFs + case PERL_constant_ISUNDEF: + break; */ + /* Uncomment this if you need to return UVs + case PERL_constant_ISUV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHu((UV)iv); + break; */ + /* Uncomment this if you need to return YESs + case PERL_constant_ISYES: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_yes); + break; */ + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing BerkeleyDB macro %s, used", + type, s)); + PUSHs(sv); + } diff --git a/bdb/perl/BerkeleyDB/dbinfo b/bdb/perl/BerkeleyDB/dbinfo new file mode 100755 index 00000000000..af2c45facf5 --- /dev/null +++ b/bdb/perl/BerkeleyDB/dbinfo @@ -0,0 +1,112 @@ +#!/usr/local/bin/perl + +# Name: dbinfo -- identify berkeley DB version used to create +# a database file +# +# Author: Paul Marquess <Paul.Marquess@btinternet.com> +# Version: 1.03 +# Date 17th September 2000 +# +# Copyright (c) 1998-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. + +# Todo: Print more stats on a db file, e.g. no of records +# add log/txn/lock files + +use strict ; + +my %Data = + ( + 0x053162 => { + Type => "Btree", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "Unknown (older than 1.71)", + 3 => "1.71 -> 1.85, 1.86", + 4 => "Unknown", + 5 => "2.0.0 -> 2.3.0", + 6 => "2.3.1 -> 2.7.7", + 7 => "3.0.x", + 8 => "3.1.x -> 4.0.x", + 9 => "4.1.x or greater", + } + }, + 0x061561 => { + Type => "Hash", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "1.71 -> 1.85", + 3 => "1.86", + 4 => "2.0.0 -> 2.1.0", + 5 => "2.2.6 -> 2.7.7", + 6 => "3.0.x", + 7 => "3.1.x -> 4.0.x", + 8 => "4.1.x or greater", + } + }, + 0x042253 => { + Type => "Queue", + Versions => + { + 1 => "3.0.x", + 2 => "3.1.x", + 3 => "3.2.x -> 4.0.x", + 4 => "4.1.x or greater", + } + }, + ) ; + +die "Usage: dbinfo file\n" unless @ARGV == 1 ; + +print "testing file $ARGV[0]...\n\n" ; +open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ; + +my $buff ; +read F, $buff, 20 ; + +my (@info) = unpack("NNNNN", $buff) ; +my (@info1) = unpack("VVVVV", $buff) ; +my ($magic, $version, $endian) ; + +if ($Data{$info[0]}) # first try DB 1.x format +{ + $magic = $info[0] ; + $version = $info[1] ; + $endian = "Unknown" ; +} +elsif ($Data{$info[3]}) # next DB 2.x big endian +{ + $magic = $info[3] ; + $version = $info[4] ; + $endian = "Big Endian" ; +} +elsif ($Data{$info1[3]}) # next DB 2.x little endian +{ + $magic = $info1[3] ; + $version = $info1[4] ; + $endian = "Little Endian" ; +} +else + { die "not a Berkeley DB database file.\n" } + +my $type = $Data{$magic} ; +$magic = sprintf "%06X", $magic ; + +my $ver_string = "Unknown" ; +$ver_string = $type->{Versions}{$version} + if defined $type->{Versions}{$version} ; + +print <<EOM ; +File Type: Berkeley DB $type->{Type} file. +File Version ID: $version +Built with Berkeley DB: $ver_string +Byte Order: $endian +Magic: $magic +EOM + +close F ; + +exit ; diff --git a/bdb/perl/BerkeleyDB/hints/dec_osf.pl b/bdb/perl/BerkeleyDB/hints/dec_osf.pl new file mode 100644 index 00000000000..6d7faeed2e2 --- /dev/null +++ b/bdb/perl/BerkeleyDB/hints/dec_osf.pl @@ -0,0 +1 @@ +$self->{LIBS} = [ "@{$self->{LIBS}} -lpthreads" ]; diff --git a/bdb/perl/BerkeleyDB/hints/irix_6_5.pl b/bdb/perl/BerkeleyDB/hints/irix_6_5.pl new file mode 100644 index 00000000000..b531673e6e0 --- /dev/null +++ b/bdb/perl/BerkeleyDB/hints/irix_6_5.pl @@ -0,0 +1 @@ +$self->{LIBS} = [ "@{$self->{LIBS}} -lthread" ]; diff --git a/bdb/perl/BerkeleyDB/hints/solaris.pl b/bdb/perl/BerkeleyDB/hints/solaris.pl new file mode 100644 index 00000000000..ddd941d634a --- /dev/null +++ b/bdb/perl/BerkeleyDB/hints/solaris.pl @@ -0,0 +1 @@ +$self->{LIBS} = [ "@{$self->{LIBS}} -lmt" ]; diff --git a/bdb/perl/BerkeleyDB/mkconsts b/bdb/perl/BerkeleyDB/mkconsts new file mode 100644 index 00000000000..7e0964333cc --- /dev/null +++ b/bdb/perl/BerkeleyDB/mkconsts @@ -0,0 +1,770 @@ +#!/usr/bin/perl + +use ExtUtils::Constant qw(WriteConstants); + +use constant DEFINE => 'define' ; +use constant STRING => 'string' ; +use constant IGNORE => 'ignore' ; + +%constants = ( + + ######### + # 2.0.0 + ######### + + DBM_INSERT => IGNORE, + DBM_REPLACE => IGNORE, + DBM_SUFFIX => IGNORE, + DB_AFTER => DEFINE, + DB_AM_DUP => IGNORE, + DB_AM_INMEM => IGNORE, + DB_AM_LOCKING => IGNORE, + DB_AM_LOGGING => IGNORE, + DB_AM_MLOCAL => IGNORE, + DB_AM_PGDEF => IGNORE, + DB_AM_RDONLY => IGNORE, + DB_AM_RECOVER => IGNORE, + DB_AM_SWAP => IGNORE, + DB_AM_TXN => IGNORE, + DB_APP_INIT => DEFINE, + DB_BEFORE => DEFINE, + DB_BTREEMAGIC => DEFINE, + DB_BTREEVERSION => DEFINE, + DB_BT_DELIMITER => IGNORE, + DB_BT_EOF => IGNORE, + DB_BT_FIXEDLEN => IGNORE, + DB_BT_PAD => IGNORE, + DB_BT_SNAPSHOT => IGNORE, + DB_CHECKPOINT => DEFINE, + DB_CREATE => DEFINE, + DB_CURRENT => DEFINE, + DB_DBT_INTERNAL => IGNORE, + DB_DBT_MALLOC => IGNORE, + DB_DBT_PARTIAL => IGNORE, + DB_DBT_USERMEM => IGNORE, + DB_DELETED => DEFINE, + DB_DELIMITER => DEFINE, + DB_DUP => DEFINE, + DB_EXCL => DEFINE, + DB_FIRST => DEFINE, + DB_FIXEDLEN => DEFINE, + DB_FLUSH => DEFINE, + DB_HASHMAGIC => DEFINE, + DB_HASHVERSION => DEFINE, + DB_HS_DIRTYMETA => IGNORE, + DB_INCOMPLETE => DEFINE, + DB_INIT_LOCK => DEFINE, + DB_INIT_LOG => DEFINE, + DB_INIT_MPOOL => DEFINE, + DB_INIT_TXN => DEFINE, + DB_KEYEXIST => DEFINE, + DB_KEYFIRST => DEFINE, + DB_KEYLAST => DEFINE, + DB_LAST => DEFINE, + DB_LOCKMAGIC => DEFINE, + DB_LOCKVERSION => DEFINE, + DB_LOCK_DEADLOCK => DEFINE, + DB_LOCK_NOTGRANTED => DEFINE, + DB_LOCK_NOTHELD => DEFINE, + DB_LOCK_NOWAIT => DEFINE, + DB_LOCK_RIW_N => DEFINE, + DB_LOCK_RW_N => DEFINE, + DB_LOGMAGIC => DEFINE, + DB_LOGVERSION => DEFINE, + DB_MAX_PAGES => DEFINE, + DB_MAX_RECORDS => DEFINE, + DB_MPOOL_CLEAN => DEFINE, + DB_MPOOL_CREATE => DEFINE, + DB_MPOOL_DIRTY => DEFINE, + DB_MPOOL_DISCARD => DEFINE, + DB_MPOOL_LAST => DEFINE, + DB_MPOOL_NEW => DEFINE, + DB_MPOOL_PRIVATE => DEFINE, + DB_MUTEXDEBUG => DEFINE, + DB_NEEDSPLIT => DEFINE, + DB_NEXT => DEFINE, + DB_NOOVERWRITE => DEFINE, + DB_NORECURSE => DEFINE, + DB_NOSYNC => DEFINE, + DB_NOTFOUND => DEFINE, + DB_PAD => DEFINE, + DB_PREV => DEFINE, + DB_RDONLY => DEFINE, + DB_REGISTERED => DEFINE, + DB_RE_MODIFIED => IGNORE, + DB_SET => DEFINE, + DB_SET_RANGE => DEFINE, + DB_SNAPSHOT => DEFINE, + DB_SWAPBYTES => DEFINE, + DB_TRUNCATE => DEFINE, + DB_TXNMAGIC => DEFINE, + DB_TXNVERSION => DEFINE, + DB_TXN_BACKWARD_ROLL => DEFINE, + DB_TXN_FORWARD_ROLL => DEFINE, + DB_TXN_LOCK_2PL => DEFINE, + DB_TXN_LOCK_MASK => DEFINE, + DB_TXN_LOCK_OPTIMISTIC => DEFINE, + DB_TXN_LOG_MASK => DEFINE, + DB_TXN_LOG_REDO => DEFINE, + DB_TXN_LOG_UNDO => DEFINE, + DB_TXN_LOG_UNDOREDO => DEFINE, + DB_TXN_OPENFILES => DEFINE, + DB_TXN_REDO => DEFINE, + DB_TXN_UNDO => DEFINE, + DB_USE_ENVIRON => DEFINE, + DB_USE_ENVIRON_ROOT => DEFINE, + DB_VERSION_MAJOR => DEFINE, + DB_VERSION_MINOR => DEFINE, + DB_VERSION_PATCH => DEFINE, + DB_VERSION_STRING => STRING, + _DB_H_ => IGNORE, + __BIT_TYPES_DEFINED__ => IGNORE, + const => IGNORE, + + # enum DBTYPE + DB_BTREE => '2.0.0', + DB_HASH => '2.0.0', + DB_RECNO => '2.0.0', + DB_UNKNOWN => '2.0.0', + + # enum db_lockop_t + DB_LOCK_DUMP => '2.0.0', + DB_LOCK_GET => '2.0.0', + DB_LOCK_PUT => '2.0.0', + DB_LOCK_PUT_ALL => '2.0.0', + DB_LOCK_PUT_OBJ => '2.0.0', + + # enum db_lockmode_t + DB_LOCK_NG => IGNORE, # 2.0.0 + DB_LOCK_READ => IGNORE, # 2.0.0 + DB_LOCK_WRITE => IGNORE, # 2.0.0 + DB_LOCK_IREAD => IGNORE, # 2.0.0 + DB_LOCK_IWRITE => IGNORE, # 2.0.0 + DB_LOCK_IWR => IGNORE, # 2.0.0 + + # enum ACTION + FIND => IGNORE, # 2.0.0 + ENTER => IGNORE, # 2.0.0 + + ######### + # 2.0.3 + ######### + + DB_SEQUENTIAL => DEFINE, + DB_TEMPORARY => DEFINE, + + ######### + # 2.1.0 + ######### + + DB_NOMMAP => DEFINE, + + ######### + # 2.2.6 + ######### + + DB_AM_THREAD => IGNORE, + DB_ARCH_ABS => DEFINE, + DB_ARCH_DATA => DEFINE, + DB_ARCH_LOG => DEFINE, + DB_LOCK_CONFLICT => DEFINE, + DB_LOCK_DEFAULT => DEFINE, + DB_LOCK_NORUN => DEFINE, + DB_LOCK_OLDEST => DEFINE, + DB_LOCK_RANDOM => DEFINE, + DB_LOCK_YOUNGEST => DEFINE, + DB_RECOVER => DEFINE, + DB_RECOVER_FATAL => DEFINE, + DB_THREAD => DEFINE, + DB_TXN_NOSYNC => DEFINE, + + ######### + # 2.3.0 + ######### + + DB_BTREEOLDVER => DEFINE, + DB_BT_RECNUM => IGNORE, + DB_FILE_ID_LEN => DEFINE, + DB_GETREC => DEFINE, + DB_HASHOLDVER => DEFINE, + DB_KEYEMPTY => DEFINE, + DB_LOGOLDVER => DEFINE, + DB_RECNUM => DEFINE, + DB_RECORDCOUNT => DEFINE, + DB_RENUMBER => DEFINE, + DB_RE_DELIMITER => IGNORE, + DB_RE_FIXEDLEN => IGNORE, + DB_RE_PAD => IGNORE, + DB_RE_RENUMBER => IGNORE, + DB_RE_SNAPSHOT => IGNORE, + + ######### + # 2.3.1 + ######### + + DB_GET_RECNO => DEFINE, + DB_SET_RECNO => DEFINE, + + ######### + # 2.3.3 + ######### + + DB_APPEND => DEFINE, + + ######### + # 2.3.6 + ######### + + DB_TXN_CKP => DEFINE, + + ######### + # 2.3.11 + ######### + + DB_ENV_APPINIT => DEFINE, + DB_ENV_STANDALONE => DEFINE, + DB_ENV_THREAD => DEFINE, + + ######### + # 2.3.12 + ######### + + DB_FUNC_CALLOC => IGNORE, + DB_FUNC_CLOSE => IGNORE, + DB_FUNC_DIRFREE => IGNORE, + DB_FUNC_DIRLIST => IGNORE, + DB_FUNC_EXISTS => IGNORE, + DB_FUNC_FREE => IGNORE, + DB_FUNC_FSYNC => IGNORE, + DB_FUNC_IOINFO => IGNORE, + DB_FUNC_MALLOC => IGNORE, + DB_FUNC_MAP => IGNORE, + DB_FUNC_OPEN => IGNORE, + DB_FUNC_READ => IGNORE, + DB_FUNC_REALLOC => IGNORE, + DB_FUNC_SEEK => IGNORE, + DB_FUNC_SLEEP => IGNORE, + DB_FUNC_STRDUP => IGNORE, + DB_FUNC_UNLINK => IGNORE, + DB_FUNC_UNMAP => IGNORE, + DB_FUNC_WRITE => IGNORE, + DB_FUNC_YIELD => IGNORE, + + ######### + # 2.3.14 + ######### + + DB_TSL_SPINS => IGNORE, + + ######### + # 2.3.16 + ######### + + DB_DBM_HSEARCH => IGNORE, + firstkey => IGNORE, + hdestroy => IGNORE, + + ######### + # 2.4.10 + ######### + + DB_CURLSN => DEFINE, + DB_FUNC_RUNLINK => IGNORE, + DB_REGION_ANON => DEFINE, + DB_REGION_INIT => DEFINE, + DB_REGION_NAME => DEFINE, + DB_TXN_LOCK_OPTIMIST => DEFINE, + __CURRENTLY_UNUSED => IGNORE, + + # enum db_status_t + DB_LSTAT_ABORTED => IGNORE, # 2.4.10 + DB_LSTAT_ERR => IGNORE, # 2.4.10 + DB_LSTAT_FREE => IGNORE, # 2.4.10 + DB_LSTAT_HELD => IGNORE, # 2.4.10 + DB_LSTAT_NOGRANT => IGNORE, # 2.4.10 + DB_LSTAT_PENDING => IGNORE, # 2.4.10 + DB_LSTAT_WAITING => IGNORE, # 2.4.10 + + ######### + # 2.4.14 + ######### + + DB_MUTEXLOCKS => DEFINE, + DB_PAGEYIELD => DEFINE, + __UNUSED_100 => IGNORE, + __UNUSED_4000 => IGNORE, + + ######### + # 2.5.2 + ######### + + DBC_CONTINUE => IGNORE, + DBC_KEYSET => IGNORE, + DBC_RECOVER => IGNORE, + DBC_RMW => IGNORE, + DB_DBM_ERROR => IGNORE, + DB_GET_BOTH => DEFINE, + DB_NEXT_DUP => DEFINE, + DB_OPFLAGS_MASK => DEFINE, + DB_RMW => DEFINE, + DB_RUNRECOVERY => DEFINE, + dbmclose => IGNORE, + + ######### + # 2.5.9 + ######### + + DB_DUPSORT => DEFINE, + DB_JOIN_ITEM => DEFINE, + + ######### + # 2.6.4 + ######### + + DBC_WRITER => IGNORE, + DB_AM_CDB => IGNORE, + DB_ENV_CDB => DEFINE, + DB_INIT_CDB => DEFINE, + DB_LOCK_UPGRADE => DEFINE, + DB_WRITELOCK => DEFINE, + + ######### + # 2.7.1 + ######### + + + # enum db_lockop_t + DB_LOCK_INHERIT => '2.7.1', + + ######### + # 2.7.7 + ######### + + DB_FCNTL_LOCKING => DEFINE, + + ######### + # 3.0.55 + ######### + + DBC_WRITECURSOR => IGNORE, + DB_AM_DISCARD => IGNORE, + DB_AM_SUBDB => IGNORE, + DB_BT_REVSPLIT => IGNORE, + DB_CONSUME => DEFINE, + DB_CXX_NO_EXCEPTIONS => DEFINE, + DB_DBT_REALLOC => IGNORE, + DB_DUPCURSOR => DEFINE, + DB_ENV_CREATE => DEFINE, + DB_ENV_DBLOCAL => DEFINE, + DB_ENV_LOCKDOWN => DEFINE, + DB_ENV_LOCKING => DEFINE, + DB_ENV_LOGGING => DEFINE, + DB_ENV_NOMMAP => DEFINE, + DB_ENV_OPEN_CALLED => DEFINE, + DB_ENV_PRIVATE => DEFINE, + DB_ENV_SYSTEM_MEM => DEFINE, + DB_ENV_TXN => DEFINE, + DB_ENV_TXN_NOSYNC => DEFINE, + DB_ENV_USER_ALLOC => DEFINE, + DB_FORCE => DEFINE, + DB_LOCKDOWN => DEFINE, + DB_LOCK_RECORD => DEFINE, + DB_LOGFILEID_INVALID => DEFINE, + DB_MPOOL_NEW_GROUP => DEFINE, + DB_NEXT_NODUP => DEFINE, + DB_OK_BTREE => DEFINE, + DB_OK_HASH => DEFINE, + DB_OK_QUEUE => DEFINE, + DB_OK_RECNO => DEFINE, + DB_OLD_VERSION => DEFINE, + DB_OPEN_CALLED => DEFINE, + DB_PAGE_LOCK => DEFINE, + DB_POSITION => DEFINE, + DB_POSITIONI => DEFINE, + DB_PRIVATE => DEFINE, + DB_QAMMAGIC => DEFINE, + DB_QAMOLDVER => DEFINE, + DB_QAMVERSION => DEFINE, + DB_RECORD_LOCK => DEFINE, + DB_REVSPLITOFF => DEFINE, + DB_SYSTEM_MEM => DEFINE, + DB_TEST_POSTLOG => DEFINE, + DB_TEST_POSTLOGMETA => DEFINE, + DB_TEST_POSTOPEN => DEFINE, + DB_TEST_POSTRENAME => DEFINE, + DB_TEST_POSTSYNC => DEFINE, + DB_TEST_PREOPEN => DEFINE, + DB_TEST_PRERENAME => DEFINE, + DB_TXN_NOWAIT => DEFINE, + DB_TXN_SYNC => DEFINE, + DB_UPGRADE => DEFINE, + DB_VERB_CHKPOINT => DEFINE, + DB_VERB_DEADLOCK => DEFINE, + DB_VERB_RECOVERY => DEFINE, + DB_VERB_WAITSFOR => DEFINE, + DB_WRITECURSOR => DEFINE, + DB_XA_CREATE => DEFINE, + + # enum DBTYPE + DB_QUEUE => '3.0.55', + + ######### + # 3.1.12 + ######### + + DBC_ACTIVE => IGNORE, + DBC_OPD => IGNORE, + DBC_TRANSIENT => IGNORE, + DBC_WRITEDUP => IGNORE, + DB_AGGRESSIVE => DEFINE, + DB_AM_DUPSORT => IGNORE, + DB_CACHED_COUNTS => DEFINE, + DB_CLIENT => DEFINE, + DB_DBT_DUPOK => IGNORE, + DB_DBT_ISSET => IGNORE, + DB_ENV_RPCCLIENT => DEFINE, + DB_GET_BOTHC => DEFINE, + DB_JOIN_NOSORT => DEFINE, + DB_NODUPDATA => DEFINE, + DB_NOORDERCHK => DEFINE, + DB_NOSERVER => DEFINE, + DB_NOSERVER_HOME => DEFINE, + DB_NOSERVER_ID => DEFINE, + DB_ODDFILESIZE => DEFINE, + DB_ORDERCHKONLY => DEFINE, + DB_PREV_NODUP => DEFINE, + DB_PR_HEADERS => DEFINE, + DB_PR_PAGE => DEFINE, + DB_PR_RECOVERYTEST => DEFINE, + DB_RDWRMASTER => DEFINE, + DB_SALVAGE => DEFINE, + DB_VERIFY_BAD => DEFINE, + DB_VERIFY_FATAL => DEFINE, + DB_VRFY_FLAGMASK => DEFINE, + + # enum db_recops + DB_TXN_ABORT => '3.1.12', + DB_TXN_BACKWARD_ROLL => '3.1.12', + DB_TXN_FORWARD_ROLL => '3.1.12', + DB_TXN_OPENFILES => '3.1.12', + + ######### + # 3.2.3 + ######### + + DBC_COMPENSATE => IGNORE, + DB_AM_VERIFYING => IGNORE, + DB_CDB_ALLDB => DEFINE, + DB_ENV_CDB_ALLDB => DEFINE, + DB_EXTENT => DEFINE, + DB_JOINENV => DEFINE, + DB_LOCK_SWITCH => DEFINE, + DB_MPOOL_EXTENT => DEFINE, + DB_REGION_MAGIC => DEFINE, + DB_UNRESOLVED_CHILD => DEFINE, + DB_VERIFY => DEFINE, + + # enum db_notices + DB_NOTICE_LOGFILE_CHANGED => IGNORE, # 3.2.3 + + ######### + # 3.2.6 + ######### + + DB_ALREADY_ABORTED => DEFINE, + DB_CONSUME_WAIT => DEFINE, + DB_JAVA_CALLBACK => DEFINE, + DB_TEST_POSTEXTDELETE => DEFINE, + DB_TEST_POSTEXTOPEN => DEFINE, + DB_TEST_POSTEXTUNLINK => DEFINE, + DB_TEST_PREEXTDELETE => DEFINE, + DB_TEST_PREEXTOPEN => DEFINE, + DB_TEST_PREEXTUNLINK => DEFINE, + + # enum db_lockmode_t + DB_LOCK_WAIT => IGNORE, # 3.2.6 + + ######### + # 3.3.4 + ######### + + DBC_DIRTY_READ => IGNORE, + DBC_MULTIPLE => IGNORE, + DBC_MULTIPLE_KEY => IGNORE, + DB_AM_DIRTY => IGNORE, + DB_AM_SECONDARY => IGNORE, + DB_COMMIT => DEFINE, + DB_DBT_APPMALLOC => IGNORE, + DB_DIRTY_READ => DEFINE, + DB_DONOTINDEX => DEFINE, + DB_ENV_PANIC_OK => DEFINE, + DB_ENV_RPCCLIENT_GIVEN => DEFINE, + DB_FAST_STAT => DEFINE, + DB_LOCK_MAXLOCKS => DEFINE, + DB_LOCK_MINLOCKS => DEFINE, + DB_LOCK_MINWRITE => DEFINE, + DB_MULTIPLE => DEFINE, + DB_MULTIPLE_KEY => DEFINE, + DB_PAGE_NOTFOUND => DEFINE, + DB_RPC_SERVERPROG => DEFINE, + DB_RPC_SERVERVERS => DEFINE, + DB_UPDATE_SECONDARY => DEFINE, + DB_XIDDATASIZE => DEFINE, + + # enum db_recops + DB_TXN_POPENFILES => '3.3.4', + + # enum db_lockop_t + DB_LOCK_UPGRADE_WRITE => '3.3.4', + + # enum db_lockmode_t + DB_LOCK_DIRTY => IGNORE, # 3.3.4 + DB_LOCK_WWRITE => IGNORE, # 3.3.4 + + ######### + # 3.3.11 + ######### + + DB_SECONDARY_BAD => DEFINE, + DB_SURPRISE_KID => DEFINE, + DB_TEST_POSTDESTROY => DEFINE, + DB_TEST_PREDESTROY => DEFINE, + + ######### + # 4.0.7 + ######### + + DB_APPLY_LOGREG => DEFINE, + DB_BROADCAST_EID => DEFINE, + DB_CL_WRITER => DEFINE, + DB_ENV_NOLOCKING => DEFINE, + DB_ENV_NOPANIC => DEFINE, + DB_ENV_REGION_INIT => DEFINE, + DB_ENV_REP_CLIENT => DEFINE, + DB_ENV_REP_LOGSONLY => DEFINE, + DB_ENV_REP_MASTER => DEFINE, + DB_ENV_YIELDCPU => DEFINE, + DB_GET_BOTH_RANGE => DEFINE, + DB_INVALID_EID => DEFINE, + DB_LOCK_EXPIRE => DEFINE, + DB_LOCK_FREE_LOCKER => DEFINE, + DB_LOCK_SET_TIMEOUT => DEFINE, + DB_LOGC_BUF_SIZE => DEFINE, + DB_LOG_DISK => DEFINE, + DB_LOG_LOCKED => DEFINE, + DB_LOG_SILENT_ERR => DEFINE, + DB_NOLOCKING => DEFINE, + DB_NOPANIC => DEFINE, + DB_PANIC_ENVIRONMENT => DEFINE, + DB_REP_CLIENT => DEFINE, + DB_REP_DUPMASTER => DEFINE, + DB_REP_HOLDELECTION => DEFINE, + DB_REP_LOGSONLY => DEFINE, + DB_REP_MASTER => DEFINE, + DB_REP_NEWMASTER => DEFINE, + DB_REP_NEWSITE => DEFINE, + DB_REP_OUTDATED => DEFINE, + DB_REP_PERMANENT => DEFINE, + DB_REP_UNAVAIL => DEFINE, + DB_SET_LOCK_TIMEOUT => DEFINE, + DB_SET_TXN_NOW => DEFINE, + DB_SET_TXN_TIMEOUT => DEFINE, + DB_STAT_CLEAR => DEFINE, + DB_TIMEOUT => DEFINE, + DB_YIELDCPU => DEFINE, + MP_FLUSH => IGNORE, + MP_OPEN_CALLED => IGNORE, + MP_READONLY => IGNORE, + MP_UPGRADE => IGNORE, + MP_UPGRADE_FAIL => IGNORE, + TXN_CHILDCOMMIT => IGNORE, + TXN_COMPENSATE => IGNORE, + TXN_DIRTY_READ => IGNORE, + TXN_LOCKTIMEOUT => IGNORE, + TXN_MALLOC => IGNORE, + TXN_NOSYNC => IGNORE, + TXN_NOWAIT => IGNORE, + TXN_SYNC => IGNORE, + + # enum db_recops + DB_TXN_APPLY => '4.0.7', + + # enum db_lockop_t + DB_LOCK_GET_TIMEOUT => '4.0.7', + DB_LOCK_PUT_READ => '4.0.7', + DB_LOCK_TIMEOUT => '4.0.7', + + # enum db_status_t + DB_LSTAT_EXPIRED => IGNORE, # 4.0.7 + + ######### + # 4.0.14 + ######### + + DB_EID_BROADCAST => DEFINE, + DB_EID_INVALID => DEFINE, + DB_VERB_REPLICATION => DEFINE, + + ######### + # 4.1.17 + ######### + + DBC_OWN_LID => IGNORE, + DB_AM_CHKSUM => IGNORE, + DB_AM_CL_WRITER => IGNORE, + DB_AM_COMPENSATE => IGNORE, + DB_AM_CREATED => IGNORE, + DB_AM_CREATED_MSTR => IGNORE, + DB_AM_DBM_ERROR => IGNORE, + DB_AM_DELIMITER => IGNORE, + DB_AM_ENCRYPT => IGNORE, + DB_AM_FIXEDLEN => IGNORE, + DB_AM_IN_RENAME => IGNORE, + DB_AM_OPEN_CALLED => IGNORE, + DB_AM_PAD => IGNORE, + DB_AM_RECNUM => IGNORE, + DB_AM_RENUMBER => IGNORE, + DB_AM_REVSPLITOFF => IGNORE, + DB_AM_SNAPSHOT => IGNORE, + DB_AUTO_COMMIT => DEFINE, + DB_CHKSUM_SHA1 => DEFINE, + DB_DIRECT => DEFINE, + DB_DIRECT_DB => DEFINE, + DB_DIRECT_LOG => DEFINE, + DB_ENCRYPT => DEFINE, + DB_ENCRYPT_AES => DEFINE, + DB_ENV_AUTO_COMMIT => DEFINE, + DB_ENV_DIRECT_DB => DEFINE, + DB_ENV_DIRECT_LOG => DEFINE, + DB_ENV_FATAL => DEFINE, + DB_ENV_OVERWRITE => DEFINE, + DB_ENV_TXN_WRITE_NOSYNC => DEFINE, + DB_HANDLE_LOCK => DEFINE, + DB_LOCK_NOTEXIST => DEFINE, + DB_LOCK_REMOVE => DEFINE, + DB_NOCOPY => DEFINE, + DB_OVERWRITE => DEFINE, + DB_PERMANENT => DEFINE, + DB_PRINTABLE => DEFINE, + DB_RENAMEMAGIC => DEFINE, + DB_TEST_ELECTINIT => DEFINE, + DB_TEST_ELECTSEND => DEFINE, + DB_TEST_ELECTVOTE1 => DEFINE, + DB_TEST_ELECTVOTE2 => DEFINE, + DB_TEST_ELECTWAIT1 => DEFINE, + DB_TEST_ELECTWAIT2 => DEFINE, + DB_TEST_SUBDB_LOCKS => DEFINE, + DB_TXN_LOCK => DEFINE, + DB_TXN_WRITE_NOSYNC => DEFINE, + DB_WRITEOPEN => DEFINE, + DB_WRNOSYNC => DEFINE, + _DB_EXT_PROT_IN_ => IGNORE, + + # enum db_lockop_t + DB_LOCK_TRADE => '4.1.17', + + # enum db_status_t + DB_LSTAT_NOTEXIST => IGNORE, # 4.1.17 + + # enum DB_CACHE_PRIORITY + DB_PRIORITY_VERY_LOW => '4.1.17', + DB_PRIORITY_LOW => '4.1.17', + DB_PRIORITY_DEFAULT => '4.1.17', + DB_PRIORITY_HIGH => '4.1.17', + DB_PRIORITY_VERY_HIGH => '4.1.17', + + # enum db_recops + DB_TXN_BACKWARD_ALLOC => '4.1.17', + DB_TXN_GETPGNOS => '4.1.17', + DB_TXN_PRINT => '4.1.17', + + ) ; + +sub enum_Macro +{ + my $str = shift ; + my ($major, $minor, $patch) = split /\./, $str ; + + my $macro = + "#if (DB_VERSION_MAJOR > $major) || \\\n" . + " (DB_VERSION_MAJOR == $major && DB_VERSION_MINOR > $minor) || \\\n" . + " (DB_VERSION_MAJOR == $major && DB_VERSION_MINOR == $minor && \\\n" . + " DB_VERSION_PATCH >= $patch)\n" ; + + return $macro; + +} + +sub OutputXS +{ + + my @names = () ; + + foreach my $key (sort keys %constants) + { + my $val = $constants{$key} ; + next if $val eq IGNORE; + + if ($val eq STRING) + { push @names, { name => $key, type => "PV" } } + elsif ($val eq DEFINE) + { push @names, $key } + else + { push @names, { name => $key, macro => [enum_Macro($val), "#endif\n"] } } + } + + warn "Updating constants.xs & constants.h...\n"; + WriteConstants( + NAME => BerkeleyDB, + NAMES => \@names, + C_FILE => 'constants.h', + XS_FILE => 'constants.xs', + ) ; +} + +sub OutputPM +{ + my $filename = 'BerkeleyDB.pm'; + warn "Updating $filename...\n"; + open IN, "<$filename" || die "Cannot open $filename: $!\n"; + open OUT, ">$filename.tmp" || die "Cannot open $filename.tmp: $!\n"; + + my $START = '@EXPORT = qw(' ; + my $START_re = quotemeta $START ; + my $END = ');'; + my $END_re = quotemeta $END ; + + # skip to the @EXPORT declaration + OUTER: while (<IN>) + { + if ( /^\s*$START_re/ ) + { + # skip to the end marker. + while (<IN>) + { last OUTER if /^\s*$END_re/ } + } + print OUT ; + } + + print OUT "$START\n"; + foreach my $key (sort keys %constants) + { + next if $constants{$key} eq IGNORE; + print OUT "\t$key\n"; + } + print OUT "\t$END\n"; + + while (<IN>) + { + print OUT ; + } + + close IN; + close OUT; + + rename $filename, "$filename.bak" || die "Cannot rename $filename: $!\n" ; + rename "$filename.tmp", $filename || die "Cannot rename $filename.tmp: $!\n" ; +} + +OutputXS() ; +OutputPM() ; diff --git a/bdb/perl/BerkeleyDB/mkpod b/bdb/perl/BerkeleyDB/mkpod new file mode 100755 index 00000000000..44bbf3fbf4f --- /dev/null +++ b/bdb/perl/BerkeleyDB/mkpod @@ -0,0 +1,146 @@ +#!/usr/local/bin/perl5 + +# Filename: mkpod +# +# Author: Paul Marquess + +# File types +# +# Macro files end with .M +# Tagged source files end with .T +# Output from the code ends with .O +# Pre-Pod file ends with .P +# +# Tags +# +# ## BEGIN tagname +# ... +# ## END tagname +# +# ## 0 +# ## 1 +# + +# Constants + +$TOKEN = '##' ; +$Verbose = 1 if $ARGV[0] =~ /^-v/i ; + +# Macros files first +foreach $file (glob("*.M")) +{ + open (F, "<$file") or die "Cannot open '$file':$!\n" ; + print " Processing Macro file $file\n" ; + while (<F>) + { + # Skip blank & comment lines + next if /^\s*$/ || /^\s*#/ ; + + # + ($name, $expand) = split (/\t+/, $_, 2) ; + + $expand =~ s/^\s*// ; + $expand =~ s/\s*$// ; + + if ($expand =~ /\[#/ ) + { + } + + $Macros{$name} = $expand ; + } + close F ; +} + +# Suck up all the code files +foreach $file (glob("t/*.T")) +{ + ($newfile = $file) =~ s/\.T$// ; + open (F, "<$file") or die "Cannot open '$file':$!\n" ; + open (N, ">$newfile") or die "Cannot open '$newfile':$!\n" ; + + print " Processing $file -> $newfile\n" ; + + while ($line = <F>) + { + if ($line =~ /^$TOKEN\s*BEGIN\s+(\w+)\s*$/ or + $line =~ m[\s*/\*$TOKEN\s*BEGIN\s+(\w+)\s*$] ) + { + print " Section $1 begins\n" if $Verbose ; + $InSection{$1} ++ ; + $Section{$1} = '' unless $Section{$1} ; + } + elsif ($line =~ /^$TOKEN\s*END\s+(\w+)\s*$/ or + $line =~ m[^\s*/\*$TOKEN\s*END\s+(\w+)\s*$] ) + { + warn "Encountered END without a begin [$line]\n" + unless $InSection{$1} ; + + delete $InSection{$1} ; + print " Section $1 ends\n" if $Verbose ; + } + else + { + print N $line ; + chop $line ; + $line =~ s/\s*$// ; + + # Save the current line in each of the sections + foreach( keys %InSection) + { + if ($line !~ /^\s*$/ ) + #{ $Section{$_} .= " $line" } + { $Section{$_} .= $line } + $Section{$_} .= "\n" ; + } + } + + } + + if (%InSection) + { + # Check for unclosed sections + print "The following Sections are not terminated\n" ; + foreach (sort keys %InSection) + { print "\t$_\n" } + exit 1 ; + } + + close F ; + close N ; +} + +print "\n\nCreating pod file(s)\n\n" if $Verbose ; + +@ppods = glob('*.P') ; +#$ppod = $ARGV[0] ; +#$pod = $ARGV[1] ; + +# Now process the pre-pod file +foreach $ppod (@ppods) +{ + ($pod = $ppod) =~ s/\.P$// ; + open (PPOD, "<$ppod") or die "Cannot open file '$ppod': $!\n" ; + open (POD, ">$pod") or die "Cannot open file '$pod': $!\n" ; + + print " $ppod -> $pod\n" ; + + while ($line = <PPOD>) + { + if ( $line =~ /^\s*$TOKEN\s*(\w+)\s*$/) + { + warn "No code insert '$1' available\n" + unless $Section{$1} ; + + print "Expanding section $1\n" if $Verbose ; + print POD $Section{$1} ; + } + else + { +# $line =~ s/\[#([^\]])]/$Macros{$1}/ge ; + print POD $line ; + } + } + + close PPOD ; + close POD ; +} diff --git a/bdb/perl/BerkeleyDB/patches/5.004 b/bdb/perl/BerkeleyDB/patches/5.004 new file mode 100644 index 00000000000..143ec95afbc --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.004 @@ -0,0 +1,44 @@ +diff perl5.004.orig/Configure perl5.004/Configure +190a191 +> perllibs='' +9904a9906,9913 +> : Remove libraries needed only for extensions +> : The appropriate ext/Foo/Makefile.PL will add them back in, if +> : necessary. +> set X `echo " $libs " | +> sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` +> shift +> perllibs="$*" +> +10372a10382 +> perllibs='$perllibs' +diff perl5.004.orig/Makefile.SH perl5.004/Makefile.SH +122c122 +< libs = $libs $cryptlib +--- +> libs = $perllibs $cryptlib +Common subdirectories: perl5.004.orig/Porting and perl5.004/Porting +Common subdirectories: perl5.004.orig/cygwin32 and perl5.004/cygwin32 +Common subdirectories: perl5.004.orig/eg and perl5.004/eg +Common subdirectories: perl5.004.orig/emacs and perl5.004/emacs +Common subdirectories: perl5.004.orig/ext and perl5.004/ext +Common subdirectories: perl5.004.orig/h2pl and perl5.004/h2pl +Common subdirectories: perl5.004.orig/hints and perl5.004/hints +Common subdirectories: perl5.004.orig/lib and perl5.004/lib +diff perl5.004.orig/myconfig perl5.004/myconfig +38c38 +< libs=$libs +--- +> libs=$perllibs +Common subdirectories: perl5.004.orig/os2 and perl5.004/os2 +diff perl5.004.orig/patchlevel.h perl5.004/patchlevel.h +40a41 +> ,"NODB-1.0 - remove -ldb from core perl binary." +Common subdirectories: perl5.004.orig/plan9 and perl5.004/plan9 +Common subdirectories: perl5.004.orig/pod and perl5.004/pod +Common subdirectories: perl5.004.orig/qnx and perl5.004/qnx +Common subdirectories: perl5.004.orig/t and perl5.004/t +Common subdirectories: perl5.004.orig/utils and perl5.004/utils +Common subdirectories: perl5.004.orig/vms and perl5.004/vms +Common subdirectories: perl5.004.orig/win32 and perl5.004/win32 +Common subdirectories: perl5.004.orig/x2p and perl5.004/x2p diff --git a/bdb/perl/BerkeleyDB/patches/5.004_01 b/bdb/perl/BerkeleyDB/patches/5.004_01 new file mode 100644 index 00000000000..1b05eb4e02b --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.004_01 @@ -0,0 +1,217 @@ +diff -rc perl5.004_01.orig/Configure perl5.004_01/Configure +*** perl5.004_01.orig/Configure Wed Jun 11 00:28:03 1997 +--- perl5.004_01/Configure Sun Nov 12 22:12:35 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9907,9912 **** +--- 9908,9921 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10375,10380 **** +--- 10384,10390 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_01.orig/Makefile.SH perl5.004_01/Makefile.SH +*** perl5.004_01.orig/Makefile.SH Thu Jun 12 23:27:56 1997 +--- perl5.004_01/Makefile.SH Sun Nov 12 22:12:35 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_01.orig/lib/ExtUtils/Embed.pm perl5.004_01/lib/ExtUtils/Embed.pm +*** perl5.004_01.orig/lib/ExtUtils/Embed.pm Wed Apr 2 22:12:04 1997 +--- perl5.004_01/lib/ExtUtils/Embed.pm Sun Nov 12 22:12:35 2000 +*************** +*** 170,176 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 170,176 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_01.orig/lib/ExtUtils/Liblist.pm perl5.004_01/lib/ExtUtils/Liblist.pm +*** perl5.004_01.orig/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997 +--- perl5.004_01/lib/ExtUtils/Liblist.pm Sun Nov 12 22:13:27 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm perl5.004_01/lib/ExtUtils/MM_Unix.pm +*** perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997 +--- perl5.004_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:12:35 2000 +*************** +*** 2137,2143 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2137,2143 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_01.orig/myconfig perl5.004_01/myconfig +*** perl5.004_01.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_01/myconfig Sun Nov 12 22:12:35 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_01.orig/patchlevel.h perl5.004_01/patchlevel.h +*** perl5.004_01.orig/patchlevel.h Wed Jun 11 03:06:10 1997 +--- perl5.004_01/patchlevel.h Sun Nov 12 22:12:35 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/patches/5.004_02 b/bdb/perl/BerkeleyDB/patches/5.004_02 new file mode 100644 index 00000000000..238f8737941 --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.004_02 @@ -0,0 +1,217 @@ +diff -rc perl5.004_02.orig/Configure perl5.004_02/Configure +*** perl5.004_02.orig/Configure Thu Aug 7 15:08:44 1997 +--- perl5.004_02/Configure Sun Nov 12 22:06:24 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_02.orig/Makefile.SH perl5.004_02/Makefile.SH +*** perl5.004_02.orig/Makefile.SH Thu Aug 7 13:10:53 1997 +--- perl5.004_02/Makefile.SH Sun Nov 12 22:06:24 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_02.orig/lib/ExtUtils/Embed.pm perl5.004_02/lib/ExtUtils/Embed.pm +*** perl5.004_02.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_02/lib/ExtUtils/Embed.pm Sun Nov 12 22:06:24 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_02.orig/lib/ExtUtils/Liblist.pm perl5.004_02/lib/ExtUtils/Liblist.pm +*** perl5.004_02.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_02/lib/ExtUtils/Liblist.pm Sun Nov 12 22:06:24 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm perl5.004_02/lib/ExtUtils/MM_Unix.pm +*** perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm Tue Aug 5 14:28:08 1997 +--- perl5.004_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:06:25 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_02.orig/myconfig perl5.004_02/myconfig +*** perl5.004_02.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_02/myconfig Sun Nov 12 22:06:25 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_02.orig/patchlevel.h perl5.004_02/patchlevel.h +*** perl5.004_02.orig/patchlevel.h Fri Aug 1 15:07:34 1997 +--- perl5.004_02/patchlevel.h Sun Nov 12 22:06:25 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/patches/5.004_03 b/bdb/perl/BerkeleyDB/patches/5.004_03 new file mode 100644 index 00000000000..06331eac922 --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.004_03 @@ -0,0 +1,223 @@ +diff -rc perl5.004_03.orig/Configure perl5.004_03/Configure +*** perl5.004_03.orig/Configure Wed Aug 13 16:09:46 1997 +--- perl5.004_03/Configure Sun Nov 12 21:56:18 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.004_03: Configure.orig +diff -rc perl5.004_03.orig/Makefile.SH perl5.004_03/Makefile.SH +*** perl5.004_03.orig/Makefile.SH Mon Aug 18 19:24:29 1997 +--- perl5.004_03/Makefile.SH Sun Nov 12 21:56:18 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.004_03: Makefile.SH.orig +diff -rc perl5.004_03.orig/lib/ExtUtils/Embed.pm perl5.004_03/lib/ExtUtils/Embed.pm +*** perl5.004_03.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_03/lib/ExtUtils/Embed.pm Sun Nov 12 21:56:18 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_03.orig/lib/ExtUtils/Liblist.pm perl5.004_03/lib/ExtUtils/Liblist.pm +*** perl5.004_03.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_03/lib/ExtUtils/Liblist.pm Sun Nov 12 21:57:17 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.orig +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.rej +diff -rc perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm perl5.004_03/lib/ExtUtils/MM_Unix.pm +*** perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm Mon Aug 18 19:16:12 1997 +--- perl5.004_03/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:56:19 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.004_03/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.004_03.orig/myconfig perl5.004_03/myconfig +*** perl5.004_03.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_03/myconfig Sun Nov 12 21:56:19 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_03.orig/patchlevel.h perl5.004_03/patchlevel.h +*** perl5.004_03.orig/patchlevel.h Wed Aug 13 11:42:01 1997 +--- perl5.004_03/patchlevel.h Sun Nov 12 21:56:19 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + +Only in perl5.004_03: patchlevel.h.orig diff --git a/bdb/perl/BerkeleyDB/patches/5.004_04 b/bdb/perl/BerkeleyDB/patches/5.004_04 new file mode 100644 index 00000000000..a227dc700d9 --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.004_04 @@ -0,0 +1,209 @@ +diff -rc perl5.004_04.orig/Configure perl5.004_04/Configure +*** perl5.004_04.orig/Configure Fri Oct 3 18:57:39 1997 +--- perl5.004_04/Configure Sun Nov 12 21:50:51 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9910,9915 **** +--- 9911,9924 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10378,10383 **** +--- 10387,10393 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_04.orig/Makefile.SH perl5.004_04/Makefile.SH +*** perl5.004_04.orig/Makefile.SH Wed Oct 15 10:33:16 1997 +--- perl5.004_04/Makefile.SH Sun Nov 12 21:50:51 2000 +*************** +*** 129,135 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 129,135 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_04.orig/lib/ExtUtils/Embed.pm perl5.004_04/lib/ExtUtils/Embed.pm +*** perl5.004_04.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_04/lib/ExtUtils/Embed.pm Sun Nov 12 21:50:51 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_04.orig/lib/ExtUtils/Liblist.pm perl5.004_04/lib/ExtUtils/Liblist.pm +*** perl5.004_04.orig/lib/ExtUtils/Liblist.pm Tue Sep 9 17:41:32 1997 +--- perl5.004_04/lib/ExtUtils/Liblist.pm Sun Nov 12 21:51:33 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 189,195 **** + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 189,195 ---- + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 539,545 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 539,545 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm perl5.004_04/lib/ExtUtils/MM_Unix.pm +*** perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm Wed Oct 8 14:13:51 1997 +--- perl5.004_04/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:50:51 2000 +*************** +*** 2229,2235 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2229,2235 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_04.orig/myconfig perl5.004_04/myconfig +*** perl5.004_04.orig/myconfig Mon Oct 6 18:26:49 1997 +--- perl5.004_04/myconfig Sun Nov 12 21:50:51 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_04.orig/patchlevel.h perl5.004_04/patchlevel.h +*** perl5.004_04.orig/patchlevel.h Wed Oct 15 10:55:19 1997 +--- perl5.004_04/patchlevel.h Sun Nov 12 21:50:51 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/patches/5.004_05 b/bdb/perl/BerkeleyDB/patches/5.004_05 new file mode 100644 index 00000000000..51c8bf35009 --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.004_05 @@ -0,0 +1,209 @@ +diff -rc perl5.004_05.orig/Configure perl5.004_05/Configure +*** perl5.004_05.orig/Configure Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Configure Sun Nov 12 21:36:25 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 10164,10169 **** +--- 10165,10178 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10648,10653 **** +--- 10657,10663 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_05.orig/Makefile.SH perl5.004_05/Makefile.SH +*** perl5.004_05.orig/Makefile.SH Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Makefile.SH Sun Nov 12 21:36:25 2000 +*************** +*** 151,157 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 151,157 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_05.orig/lib/ExtUtils/Embed.pm perl5.004_05/lib/ExtUtils/Embed.pm +*** perl5.004_05.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_05/lib/ExtUtils/Embed.pm Sun Nov 12 21:36:25 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_05.orig/lib/ExtUtils/Liblist.pm perl5.004_05/lib/ExtUtils/Liblist.pm +*** perl5.004_05.orig/lib/ExtUtils/Liblist.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/Liblist.pm Sun Nov 12 21:45:31 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 590,596 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 590,596 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm perl5.004_05/lib/ExtUtils/MM_Unix.pm +*** perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:36:25 2000 +*************** +*** 2246,2252 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2246,2252 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_05.orig/myconfig perl5.004_05/myconfig +*** perl5.004_05.orig/myconfig Thu Jan 6 22:05:55 2000 +--- perl5.004_05/myconfig Sun Nov 12 21:43:54 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_05.orig/patchlevel.h perl5.004_05/patchlevel.h +*** perl5.004_05.orig/patchlevel.h Thu Jan 6 22:05:48 2000 +--- perl5.004_05/patchlevel.h Sun Nov 12 21:36:25 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/patches/5.005 b/bdb/perl/BerkeleyDB/patches/5.005 new file mode 100644 index 00000000000..effee3e8275 --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.005 @@ -0,0 +1,209 @@ +diff -rc perl5.005.orig/Configure perl5.005/Configure +*** perl5.005.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005/Configure Sun Nov 12 21:30:40 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005.orig/Makefile.SH perl5.005/Makefile.SH +*** perl5.005.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005/Makefile.SH Sun Nov 12 21:30:40 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005.orig/lib/ExtUtils/Embed.pm perl5.005/lib/ExtUtils/Embed.pm +*** perl5.005.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005/lib/ExtUtils/Embed.pm Sun Nov 12 21:30:40 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005.orig/lib/ExtUtils/Liblist.pm perl5.005/lib/ExtUtils/Liblist.pm +*** perl5.005.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005/lib/ExtUtils/Liblist.pm Sun Nov 12 21:30:40 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005.orig/lib/ExtUtils/MM_Unix.pm perl5.005/lib/ExtUtils/MM_Unix.pm +*** perl5.005.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:30:41 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005.orig/myconfig perl5.005/myconfig +*** perl5.005.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005/myconfig Sun Nov 12 21:30:41 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005.orig/patchlevel.h perl5.005/patchlevel.h +*** perl5.005.orig/patchlevel.h Wed Jul 22 19:22:01 1998 +--- perl5.005/patchlevel.h Sun Nov 12 21:30:41 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/patches/5.005_01 b/bdb/perl/BerkeleyDB/patches/5.005_01 new file mode 100644 index 00000000000..2a05dd545f6 --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.005_01 @@ -0,0 +1,209 @@ +diff -rc perl5.005_01.orig/Configure perl5.005_01/Configure +*** perl5.005_01.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005_01/Configure Sun Nov 12 20:55:58 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_01.orig/Makefile.SH perl5.005_01/Makefile.SH +*** perl5.005_01.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_01/Makefile.SH Sun Nov 12 20:55:58 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_01.orig/lib/ExtUtils/Embed.pm perl5.005_01/lib/ExtUtils/Embed.pm +*** perl5.005_01.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_01/lib/ExtUtils/Embed.pm Sun Nov 12 20:55:58 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_01.orig/lib/ExtUtils/Liblist.pm perl5.005_01/lib/ExtUtils/Liblist.pm +*** perl5.005_01.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005_01/lib/ExtUtils/Liblist.pm Sun Nov 12 20:55:58 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm perl5.005_01/lib/ExtUtils/MM_Unix.pm +*** perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:55:58 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005_01.orig/myconfig perl5.005_01/myconfig +*** perl5.005_01.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_01/myconfig Sun Nov 12 20:55:58 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_01.orig/patchlevel.h perl5.005_01/patchlevel.h +*** perl5.005_01.orig/patchlevel.h Mon Jan 3 11:07:45 2000 +--- perl5.005_01/patchlevel.h Sun Nov 12 20:55:58 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/patches/5.005_02 b/bdb/perl/BerkeleyDB/patches/5.005_02 new file mode 100644 index 00000000000..5dd57ddc03f --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.005_02 @@ -0,0 +1,264 @@ +diff -rc perl5.005_02.orig/Configure perl5.005_02/Configure +*** perl5.005_02.orig/Configure Mon Jan 3 11:12:20 2000 +--- perl5.005_02/Configure Sun Nov 12 20:50:51 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11334,11339 **** +--- 11335,11348 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11859,11864 **** +--- 11868,11874 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.005_02: Configure.orig +diff -rc perl5.005_02.orig/Makefile.SH perl5.005_02/Makefile.SH +*** perl5.005_02.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_02/Makefile.SH Sun Nov 12 20:50:51 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.005_02: Makefile.SH.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/Embed.pm perl5.005_02/lib/ExtUtils/Embed.pm +*** perl5.005_02.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_02/lib/ExtUtils/Embed.pm Sun Nov 12 20:50:51 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_02.orig/lib/ExtUtils/Liblist.pm perl5.005_02/lib/ExtUtils/Liblist.pm +*** perl5.005_02.orig/lib/ExtUtils/Liblist.pm Mon Jan 3 11:12:21 2000 +--- perl5.005_02/lib/ExtUtils/Liblist.pm Sun Nov 12 20:50:51 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 333,339 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 333,339 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 623,629 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 623,629 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +*************** +*** 666,672 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 666,672 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 676,682 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 676,682 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +Only in perl5.005_02/lib/ExtUtils: Liblist.pm.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm perl5.005_02/lib/ExtUtils/MM_Unix.pm +*** perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:50:51 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.005_02/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.005_02.orig/myconfig perl5.005_02/myconfig +*** perl5.005_02.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_02/myconfig Sun Nov 12 20:50:51 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_02.orig/patchlevel.h perl5.005_02/patchlevel.h +*** perl5.005_02.orig/patchlevel.h Mon Jan 3 11:12:19 2000 +--- perl5.005_02/patchlevel.h Sun Nov 12 20:50:51 2000 +*************** +*** 40,45 **** +--- 40,46 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/patches/5.005_03 b/bdb/perl/BerkeleyDB/patches/5.005_03 new file mode 100644 index 00000000000..115f9f5b909 --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.005_03 @@ -0,0 +1,250 @@ +diff -rc perl5.005_03.orig/Configure perl5.005_03/Configure +*** perl5.005_03.orig/Configure Sun Mar 28 17:12:57 1999 +--- perl5.005_03/Configure Sun Sep 17 22:19:16 2000 +*************** +*** 208,213 **** +--- 208,214 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11642,11647 **** +--- 11643,11656 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 12183,12188 **** +--- 12192,12198 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_03.orig/Makefile.SH perl5.005_03/Makefile.SH +*** perl5.005_03.orig/Makefile.SH Thu Mar 4 02:35:25 1999 +--- perl5.005_03/Makefile.SH Sun Sep 17 22:21:01 2000 +*************** +*** 58,67 **** + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +--- 58,67 ---- + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $perllibs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $perllibs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +*************** +*** 155,161 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 155,161 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_03.orig/lib/ExtUtils/Embed.pm perl5.005_03/lib/ExtUtils/Embed.pm +*** perl5.005_03.orig/lib/ExtUtils/Embed.pm Wed Jan 6 02:17:50 1999 +--- perl5.005_03/lib/ExtUtils/Embed.pm Sun Sep 17 22:19:16 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_03.orig/lib/ExtUtils/Liblist.pm perl5.005_03/lib/ExtUtils/Liblist.pm +*** perl5.005_03.orig/lib/ExtUtils/Liblist.pm Wed Jan 6 02:17:47 1999 +--- perl5.005_03/lib/ExtUtils/Liblist.pm Sun Sep 17 22:19:16 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 336,342 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 336,342 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 626,632 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 626,632 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 670,676 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 670,676 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 680,686 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 680,686 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -rc perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm perl5.005_03/lib/ExtUtils/MM_Unix.pm +*** perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm Fri Mar 5 00:34:20 1999 +--- perl5.005_03/lib/ExtUtils/MM_Unix.pm Sun Sep 17 22:19:16 2000 +*************** +*** 2284,2290 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2284,2290 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { diff --git a/bdb/perl/BerkeleyDB/patches/5.6.0 b/bdb/perl/BerkeleyDB/patches/5.6.0 new file mode 100644 index 00000000000..1f9b3b620de --- /dev/null +++ b/bdb/perl/BerkeleyDB/patches/5.6.0 @@ -0,0 +1,294 @@ +diff -cr perl-5.6.0.orig/Configure perl-5.6.0/Configure +*** perl-5.6.0.orig/Configure Wed Mar 22 20:36:37 2000 +--- perl-5.6.0/Configure Sun Sep 17 23:40:15 2000 +*************** +*** 217,222 **** +--- 217,223 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 14971,14976 **** +--- 14972,14985 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 15640,15645 **** +--- 15649,15655 ---- + path_sep='$path_sep' + perl5='$perl5' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -cr perl-5.6.0.orig/Makefile.SH perl-5.6.0/Makefile.SH +*** perl-5.6.0.orig/Makefile.SH Sat Mar 11 16:05:24 2000 +--- perl-5.6.0/Makefile.SH Sun Sep 17 23:40:15 2000 +*************** +*** 70,76 **** + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $libs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +--- 70,76 ---- + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +*************** +*** 176,182 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 176,182 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +*************** +*** 333,339 **** + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $libs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +--- 333,339 ---- + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $perllibs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +diff -cr perl-5.6.0.orig/lib/ExtUtils/Embed.pm perl-5.6.0/lib/ExtUtils/Embed.pm +*** perl-5.6.0.orig/lib/ExtUtils/Embed.pm Sun Jan 23 12:08:32 2000 +--- perl-5.6.0/lib/ExtUtils/Embed.pm Sun Sep 17 23:40:15 2000 +*************** +*** 193,199 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 193,199 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -cr perl-5.6.0.orig/lib/ExtUtils/Liblist.pm perl-5.6.0/lib/ExtUtils/Liblist.pm +*** perl-5.6.0.orig/lib/ExtUtils/Liblist.pm Wed Mar 22 16:16:31 2000 +--- perl-5.6.0/lib/ExtUtils/Liblist.pm Sun Sep 17 23:40:15 2000 +*************** +*** 17,34 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 17,34 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 198,204 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 198,204 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 338,344 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 338,344 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 624,630 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 624,630 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 668,674 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 668,674 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 678,684 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 678,684 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -cr perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm perl-5.6.0/lib/ExtUtils/MM_Unix.pm +*** perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm Thu Mar 2 17:52:52 2000 +--- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Sun Sep 17 23:40:15 2000 +*************** +*** 2450,2456 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2450,2456 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -cr perl-5.6.0.orig/myconfig.SH perl-5.6.0/myconfig.SH +*** perl-5.6.0.orig/myconfig.SH Sat Feb 26 06:34:49 2000 +--- perl-5.6.0/myconfig.SH Sun Sep 17 23:41:17 2000 +*************** +*** 48,54 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 48,54 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -cr perl-5.6.0.orig/patchlevel.h perl-5.6.0/patchlevel.h +*** perl-5.6.0.orig/patchlevel.h Wed Mar 22 20:23:11 2000 +--- perl-5.6.0/patchlevel.h Sun Sep 17 23:40:15 2000 +*************** +*** 70,75 **** +--- 70,76 ---- + #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/BerkeleyDB/ppport.h b/bdb/perl/BerkeleyDB/ppport.h new file mode 100644 index 00000000000..0887c2159a9 --- /dev/null +++ b/bdb/perl/BerkeleyDB/ppport.h @@ -0,0 +1,329 @@ +/* This file is Based on output from + * Perl/Pollution/Portability Version 2.0000 */ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef PERL_REVISION +# ifndef __PATCHLEVEL_H_INCLUDED__ +# include "patchlevel.h" +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +#ifndef ERRSV +# define ERRSV perl_get_sv("@",FALSE) +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_defgv defgv +# define PL_dirty dirty +# define PL_hints hints +# define PL_na na +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stdingv stdingv +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +/* Replace: 0 */ +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + +#ifndef PTR2IV +# define PTR2IV(d) (IV)(d) +#endif + +#ifndef INT2PTR +# define INT2PTR(any,d) (any)(d) +#endif + +#ifndef dTHR +# ifdef WIN32 +# define dTHR extern int Perl___notused +# else +# define dTHR extern int errno +# endif +#endif + +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) +#endif + +#ifndef newSVpvn +# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) +#endif + +#ifndef newRV_inc +/* Replace: 1 */ +# define newRV_inc(sv) newRV(sv) +/* Replace: 0 */ +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef newRV_noinc +# ifdef __GNUC__ +# define newRV_noinc(sv) \ + ({ \ + SV *nsv = (SV*)newRV(sv); \ + SvREFCNT_dec(sv); \ + nsv; \ + }) +# else +# if defined(CRIPPLED_CC) || defined(USE_THREADS) +static SV * newRV_noinc (SV * sv) +{ + SV *nsv = (SV*)newRV(sv); + SvREFCNT_dec(sv); + return nsv; +} +# else +# define newRV_noinc(sv) \ + ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv) +# endif +# endif +#endif + +/* Provide: newCONSTSUB */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63)) + +#if defined(NEED_newCONSTSUB) +static +#else +extern void newCONSTSUB _((HV * stash, char * name, SV *sv)); +#endif + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) +void +newCONSTSUB(stash,name,sv) +HV *stash; +char *name; +SV *sv; +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)) + /* before 5.003_22 */ + start_subparse(), +#else +# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22) + /* 5.003_22 */ + start_subparse(0), +# else + /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +# endif +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif + +#endif /* newCONSTSUB */ + + +#ifndef START_MY_CXT + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if PERL_REVISION == 5 && \ + (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#else /* single interpreter */ + +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifdef HASATTRIBUTE +# define PERL_UNUSED_DECL __attribute__((unused)) +#else +# define PERL_UNUSED_DECL +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif + +#endif /* START_MY_CXT */ + + +#ifndef DBM_setFilter + +/* + The DBM_setFilter & DBM_ckFilter macros are only used by + the *DB*_File modules +*/ + +#define DBM_setFilter(db_type,code) \ + { \ + if (db_type) \ + RETVAL = sv_mortalcopy(db_type) ; \ + ST(0) = RETVAL ; \ + if (db_type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db_type) ; \ + db_type = NULL ; \ + } \ + else if (code) { \ + if (db_type) \ + sv_setsv(db_type, code) ; \ + else \ + db_type = newSVsv(code) ; \ + } \ + } + +#define DBM_ckFilter(arg,type,name) \ + if (db->type) { \ + if (db->filtering) { \ + croak("recursion detected in %s", name) ; \ + } \ + ENTER ; \ + SAVETMPS ; \ + SAVEINT(db->filtering) ; \ + db->filtering = TRUE ; \ + SAVESPTR(DEFSV) ; \ + DEFSV = arg ; \ + SvTEMP_off(arg) ; \ + PUSHMARK(SP) ; \ + PUTBACK ; \ + (void) perl_call_sv(db->type, G_DISCARD); \ + SPAGAIN ; \ + PUTBACK ; \ + FREETMPS ; \ + LEAVE ; \ + } + +#endif /* DBM_setFilter */ + +#endif /* _P_P_PORTABILITY_H_ */ diff --git a/bdb/perl/BerkeleyDB/scan b/bdb/perl/BerkeleyDB/scan new file mode 100644 index 00000000000..eb064950b2e --- /dev/null +++ b/bdb/perl/BerkeleyDB/scan @@ -0,0 +1,229 @@ +#!/usr/local/bin/perl + +my $ignore_re = '^(' . join("|", + qw( + _ + [a-z] + DBM + DBC + DB_AM_ + DB_BT_ + DB_RE_ + DB_HS_ + DB_FUNC_ + DB_DBT_ + DB_DBM + DB_TSL + MP + TXN + )) . ')' ; + +my %ignore_def = map {$_, 1} qw() ; + +%ignore_enums = map {$_, 1} qw( ACTION db_status_t db_notices db_lockmode_t ) ; + +my $filler = ' ' x 26 ; + +chdir "libraries" || die "Cannot chdir into './libraries': $!\n"; + +foreach my $name (sort tuple glob "[2-9]*") +{ + my $inc = "$name/include/db.h" ; + next unless -f $inc ; + + my $file = readFile($inc) ; + StripCommentsAndStrings($file) ; + my $result = scan($name, $file) ; + print "\n\t#########\n\t# $name\n\t#########\n\n$result" + if $result; +} +exit ; + + +sub scan +{ + my $version = shift ; + my $file = shift ; + + my %seen_define = () ; + my $result = "" ; + + if (1) { + # Preprocess all tri-graphs + # including things stuck in quoted string constants. + $file =~ s/\?\?=/#/g; # | ??=| #| + $file =~ s/\?\?\!/|/g; # | ??!| || + $file =~ s/\?\?'/^/g; # | ??'| ^| + $file =~ s/\?\?\(/[/g; # | ??(| [| + $file =~ s/\?\?\)/]/g; # | ??)| ]| + $file =~ s/\?\?\-/~/g; # | ??-| ~| + $file =~ s/\?\?\//\\/g; # | ??/| \| + $file =~ s/\?\?</{/g; # | ??<| {| + $file =~ s/\?\?>/}/g; # | ??>| }| + } + + while ( $file =~ /^\s*#\s*define\s+([\$\w]+)\b(?!\()\s*(.*)/gm ) + { + my $def = $1; + my $rest = $2; + my $ignore = 0 ; + + $ignore = 1 if $ignore_def{$def} || $def =~ /$ignore_re/o ; + + # Cannot do: (-1) and ((LHANDLE)3) are OK: + #print("Skip non-wordy $def => $rest\n"), + + $rest =~ s/\s*$//; + #next if $rest =~ /[^\w\$]/; + + #print "Matched $_ ($def)\n" ; + + next if $before{$def} ++ ; + + if ($ignore) + { $seen_define{$def} = 'IGNORE' } + elsif ($rest =~ /"/) + { $seen_define{$def} = 'STRING' } + else + { $seen_define{$def} = 'DEFINE' } + } + + foreach $define (sort keys %seen_define) + { + my $out = $filler ; + substr($out,0, length $define) = $define; + $result .= "\t$out => $seen_define{$define},\n" ; + } + + while ($file =~ /\btypedef\s+enum\s*{(.*?)}\s*(\w+)/gs ) + { + my $enum = $1 ; + my $name = $2 ; + my $ignore = 0 ; + + $ignore = 1 if $ignore_enums{$name} ; + + #$enum =~ s/\s*=\s*\S+\s*(,?)\s*\n/$1/g; + $enum =~ s/^\s*//; + $enum =~ s/\s*$//; + + my @tokens = map { s/\s*=.*// ; $_} split /\s*,\s*/, $enum ; + my @new = grep { ! $Enums{$_}++ } @tokens ; + if (@new) + { + my $value ; + if ($ignore) + { $value = "IGNORE, # $version" } + else + { $value = "'$version'," } + + $result .= "\n\t# enum $name\n"; + my $out = $filler ; + foreach $name (@new) + { + $out = $filler ; + substr($out,0, length $name) = $name; + $result .= "\t$out => $value\n" ; + } + } + } + + return $result ; +} + + +sub StripCommentsAndStrings +{ + + # Strip C & C++ coments + # From the perlfaq + $_[0] =~ + + s{ + /\* ## Start of /* ... */ comment + [^*]*\*+ ## Non-* followed by 1-or-more *'s + ( + [^/*][^*]*\*+ + )* ## 0-or-more things which don't start with / + ## but do end with '*' + / ## End of /* ... */ comment + + | ## OR C++ Comment + // ## Start of C++ comment // + [^\n]* ## followed by 0-or-more non end of line characters + + | ## OR various things which aren't comments: + + ( + " ## Start of " ... " string + ( + \\. ## Escaped char + | ## OR + [^"\\] ## Non "\ + )* + " ## End of " ... " string + + | ## OR + + ' ## Start of ' ... ' string + ( + \\. ## Escaped char + | ## OR + [^'\\] ## Non '\ + )* + ' ## End of ' ... ' string + + | ## OR + + . ## Anything other char + [^/"'\\]* ## Chars which doesn't start a comment, string or escape + ) + }{$2}gxs; + + + + # Remove double-quoted strings. + #$_[0] =~ s#"(\\.|[^"\\])*"##g; + + # Remove single-quoted strings. + #$_[0] =~ s#'(\\.|[^'\\])*'##g; + + # Remove leading whitespace. + $_[0] =~ s/\A\s+//m ; + + # Remove trailing whitespace. + $_[0] =~ s/\s+\Z//m ; + + # Replace all multiple whitespace by a single space. + #$_[0] =~ s/\s+/ /g ; +} + + +sub readFile +{ + my $filename = shift ; + open F, "<$filename" || die "Cannot open $filename: $!\n" ; + local $/ ; + my $x = <F> ; + close F ; + return $x ; +} + +sub tuple +{ + my (@a) = split(/\./, $a) ; + my (@b) = split(/\./, $b) ; + if (@a != @b) { + my $diff = @a - @b ; + push @b, (0 x $diff) if $diff > 0 ; + push @a, (0 x -$diff) if $diff < 0 ; + } + foreach $A (@a) { + $B = shift @b ; + $A == $B or return $A <=> $B ; + } + return 0; +} + +__END__ + diff --git a/bdb/perl/BerkeleyDB/t/btree.t b/bdb/perl/BerkeleyDB/t/btree.t new file mode 100644 index 00000000000..fd6ed8f1268 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/btree.t @@ -0,0 +1,931 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..244\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Btree -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Btree -Txn => "x" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Btree -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to Btree + +{ + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put("some key", "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get("some key", $value) == 0 ; + ok 10, $value eq "some value" ; + ok 11, $db->db_put("key", "value") == 0 ; + ok 12, $db->db_get("key", $value) == 0 ; + ok 13, $value eq "value" ; + ok 14, $db->db_del("some key") == 0 ; + ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ; + ok 16, $db->status() == DB_NOTFOUND ; + ok 17, $db->status() eq $DB_errors{'DB_NOTFOUND'} ; + + ok 18, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 19, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 20, $db->status() eq $DB_errors{'DB_KEYEXIST'} ; + ok 21, $db->status() == DB_KEYEXIST ; + + + # check that the value of the key has not been changed by the + # previous test + ok 22, $db->db_get("key", $value) == 0 ; + ok 23, $value eq "value" ; + + # test DB_GET_BOTH + my ($k, $v) = ("key", "value") ; + ok 24, $db->db_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("key", "fred") ; + ok 25, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("another", "value") ; + ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + +} + +{ + # Check simple env works with a hash. + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + ok 27, my $lexD = new LexDir($home) ; + + ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL, + -Home => $home ; + ok 29, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + ok 30, $db->db_put("some key", "some value") == 0 ; + ok 31, $db->db_get("some key", $value) == 0 ; + ok 32, $value eq "some value" ; + undef $db ; + undef $env ; +} + + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my %hash ; + my ($k, $v) ; + ok 33, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => 2, + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 34, $ret == 0 ; + + # create the cursor + ok 35, my $cursor = $db->db_cursor() ; + + $k = $v = "" ; + my %copy = %data ; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 36, $cursor->status() == DB_NOTFOUND ; + ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'}; + ok 38, keys %copy == 0 ; + ok 39, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 40, $status == DB_NOTFOUND ; + ok 41, $status eq $DB_errors{'DB_NOTFOUND'}; + ok 42, $cursor->status() == $status ; + ok 43, $cursor->status() eq $status ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; + + ($k, $v) = ("green", "house") ; + ok 46, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("green", "door") ; + ok 47, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("black", "house") ; + ok 48, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + +} + +{ + # Tied Hash interface + + my $lex = new LexFile $Dfile ; + my %hash ; + ok 49, tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # check "each" with an empty database + my $count = 0 ; + while (my ($k, $v) = each %hash) { + ++ $count ; + } + ok 50, (tied %hash)->status() == DB_NOTFOUND ; + ok 51, $count == 0 ; + + # Add a k/v pair + my $value ; + $hash{"some key"} = "some value"; + ok 52, (tied %hash)->status() == 0 ; + ok 53, $hash{"some key"} eq "some value"; + ok 54, defined $hash{"some key"} ; + ok 55, (tied %hash)->status() == 0 ; + ok 56, exists $hash{"some key"} ; + ok 57, !defined $hash{"jimmy"} ; + ok 58, (tied %hash)->status() == DB_NOTFOUND ; + ok 59, !exists $hash{"jimmy"} ; + ok 60, (tied %hash)->status() == DB_NOTFOUND ; + + delete $hash{"some key"} ; + ok 61, (tied %hash)->status() == 0 ; + ok 62, ! defined $hash{"some key"} ; + ok 63, (tied %hash)->status() == DB_NOTFOUND ; + ok 64, ! exists $hash{"some key"} ; + ok 65, (tied %hash)->status() == DB_NOTFOUND ; + + $hash{1} = 2 ; + $hash{10} = 20 ; + $hash{1000} = 2000 ; + + my ($keys, $values) = (0,0); + $count = 0 ; + while (my ($k, $v) = each %hash) { + $keys += $k ; + $values += $v ; + ++ $count ; + } + ok 66, $count == 3 ; + ok 67, $keys == 1011 ; + ok 68, $values == 2022 ; + + # now clear the hash + %hash = () ; + ok 69, keys %hash == 0 ; + + untie %hash ; +} + +{ + # override default compare + my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ; + my $value ; + my (%h, %g, %k) ; + my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; + ok 70, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, + -Compare => sub { $_[0] <=> $_[1] }, + -Flags => DB_CREATE ; + + ok 71, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, + -Compare => sub { $_[0] cmp $_[1] }, + -Flags => DB_CREATE ; + + ok 72, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, + -Compare => sub { length $_[0] <=> length $_[1] }, + -Flags => DB_CREATE ; + + my @srt_1 ; + { local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; + } + my @srt_2 = sort { $a cmp $b } @Keys ; + my @srt_3 = sort { length $a <=> length $b } @Keys ; + + foreach (@Keys) { + local $^W = 0 ; + $h{$_} = 1 ; + $g{$_} = 1 ; + $k{$_} = 1 ; + } + + sub ArrayCompare + { + my($a, $b) = @_ ; + + return 0 if @$a != @$b ; + + foreach (1 .. length @$a) + { + return 0 unless $$a[$_] eq $$b[$_] ; + } + + 1 ; + } + + ok 73, ArrayCompare (\@srt_1, [keys %h]); + ok 74, ArrayCompare (\@srt_2, [keys %g]); + ok 75, ArrayCompare (\@srt_3, [keys %k]); + +} + +{ + # override default compare, with duplicates, don't sort values + my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ; + my $value ; + my (%h, %g, %k) ; + my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ; + my @Values = qw( 1 0 3 dd x abc 0 ) ; + ok 76, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, + -Compare => sub { $_[0] <=> $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + ok 77, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, + -Compare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + ok 78, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, + -Compare => sub { length $_[0] <=> length $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + my @srt_1 ; + { local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; + } + my @srt_2 = sort { $a cmp $b } @Keys ; + my @srt_3 = sort { length $a <=> length $b } @Keys ; + + foreach (@Keys) { + local $^W = 0 ; + my $value = shift @Values ; + $h{$_} = $value ; + $g{$_} = $value ; + $k{$_} = $value ; + } + + sub getValues + { + my $hash = shift ; + my $db = tied %$hash ; + my $cursor = $db->db_cursor() ; + my @values = () ; + my ($k, $v) = (0,0) ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + push @values, $v ; + } + return @values ; + } + + ok 79, ArrayCompare (\@srt_1, [keys %h]); + ok 80, ArrayCompare (\@srt_2, [keys %g]); + ok 81, ArrayCompare (\@srt_3, [keys %k]); + ok 82, ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]); + ok 83, ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]); + ok 84, ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]); + + # test DB_DUP_NEXT + ok 85, my $cur = (tied %g)->db_cursor() ; + my ($k, $v) = (9, "") ; + ok 86, $cur->c_get($k, $v, DB_SET) == 0 ; + ok 87, $k == 9 && $v == 0 ; + ok 88, $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ; + ok 89, $k == 9 && $v eq "x" ; + ok 90, $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ; +} + +{ + # override default compare, with duplicates, sort values + my $lex = new LexFile $Dfile, $Dfile2; + my $value ; + my (%h, %g) ; + my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ; + my @Values = qw( 1 11 3 dd x abc 2 0 ) ; + ok 91, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, + -Compare => sub { $_[0] <=> $_[1] }, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + ok 92, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, + -Compare => sub { $_[0] cmp $_[1] }, + -DupCompare => sub { $_[0] <=> $_[1] }, + -Property => DB_DUP, + + + + -Flags => DB_CREATE ; + + my @srt_1 ; + { local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; + } + my @srt_2 = sort { $a cmp $b } @Keys ; + + foreach (@Keys) { + local $^W = 0 ; + my $value = shift @Values ; + $h{$_} = $value ; + $g{$_} = $value ; + } + + ok 93, ArrayCompare (\@srt_1, [keys %h]); + ok 94, ArrayCompare (\@srt_2, [keys %g]); + ok 95, ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]); + ok 96, ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]); + +} + +{ + # get_dup etc + my $lex = new LexFile $Dfile; + my %hh ; + + ok 97, my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + $hh{'Wall'} = 'Larry' ; + $hh{'Wall'} = 'Stone' ; # Note the duplicate key + $hh{'Wall'} = 'Brick' ; # Note the duplicate key + $hh{'Smith'} = 'John' ; + $hh{'mouse'} = 'mickey' ; + + # first work in scalar context + ok 98, scalar $YY->get_dup('Unknown') == 0 ; + ok 99, scalar $YY->get_dup('Smith') == 1 ; + ok 100, scalar $YY->get_dup('Wall') == 3 ; + + # now in list context + my @unknown = $YY->get_dup('Unknown') ; + ok 101, "@unknown" eq "" ; + + my @smith = $YY->get_dup('Smith') ; + ok 102, "@smith" eq "John" ; + + { + my @wall = $YY->get_dup('Wall') ; + my %wall ; + @wall{@wall} = @wall ; + ok 103, (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}); + } + + # hash + my %unknown = $YY->get_dup('Unknown', 1) ; + ok 104, keys %unknown == 0 ; + + my %smith = $YY->get_dup('Smith', 1) ; + ok 105, keys %smith == 1 && $smith{'John'} ; + + my %wall = $YY->get_dup('Wall', 1) ; + ok 106, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 + && $wall{'Brick'} == 1 ; + + undef $YY ; + untie %hh ; + +} + +{ + # in-memory file + + my $lex = new LexFile $Dfile ; + my %hash ; + my $fd ; + my $value ; + ok 107, my $db = tie %hash, 'BerkeleyDB::Btree' ; + + ok 108, $db->db_put("some key", "some value") == 0 ; + ok 109, $db->db_get("some key", $value) == 0 ; + ok 110, $value eq "some value" ; + +} + +{ + # partial + # check works via API + + my $lex = new LexFile $Dfile ; + my $value ; + ok 111, my $db = new BerkeleyDB::Btree, -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 112, $ret == 0 ; + + + # do a partial get + my ($pon, $off, $len) = $db->partial_set(0,2) ; + ok 113, ! $pon && $off == 0 && $len == 0 ; + ok 114, $db->db_get("red", $value) == 0 && $value eq "bo" ; + ok 115, $db->db_get("green", $value) == 0 && $value eq "ho" ; + ok 116, $db->db_get("blue", $value) == 0 && $value eq "se" ; + + # do a partial get, off end of data + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 117, $pon ; + ok 118, $off == 0 ; + ok 119, $len == 2 ; + ok 120, $db->db_get("red", $value) == 0 && $value eq "t" ; + ok 121, $db->db_get("green", $value) == 0 && $value eq "se" ; + ok 122, $db->db_get("blue", $value) == 0 && $value eq "" ; + + # switch of partial mode + ($pon, $off, $len) = $db->partial_clear() ; + ok 123, $pon ; + ok 124, $off == 3 ; + ok 125, $len == 2 ; + ok 126, $db->db_get("red", $value) == 0 && $value eq "boat" ; + ok 127, $db->db_get("green", $value) == 0 && $value eq "house" ; + ok 128, $db->db_get("blue", $value) == 0 && $value eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 129, $db->db_put("red", "") == 0 ; + ok 130, $db->db_put("green", "AB") == 0 ; + ok 131, $db->db_put("blue", "XYZ") == 0 ; + ok 132, $db->db_put("new", "KLM") == 0 ; + + ($pon, $off, $len) = $db->partial_clear() ; + ok 133, $pon ; + ok 134, $off == 0 ; + ok 135, $len == 2 ; + ok 136, $db->db_get("red", $value) == 0 && $value eq "at" ; + ok 137, $db->db_get("green", $value) == 0 && $value eq "ABuse" ; + ok 138, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ; + ok 139, $db->db_get("new", $value) == 0 && $value eq "KLM" ; + + # now partial put + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 140, ! $pon ; + ok 141, $off == 0 ; + ok 142, $len == 0 ; + ok 143, $db->db_put("red", "PPP") == 0 ; + ok 144, $db->db_put("green", "Q") == 0 ; + ok 145, $db->db_put("blue", "XYZ") == 0 ; + ok 146, $db->db_put("new", "TU") == 0 ; + + $db->partial_clear() ; + ok 147, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ; + ok 148, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ; + ok 149, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ; + ok 150, $db->db_get("new", $value) == 0 && $value eq "KLMTU" ; +} + +{ + # partial + # check works via tied hash + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + ok 151, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + while (my ($k, $v) = each %data) { + $hash{$k} = $v ; + } + + + # do a partial get + $db->partial_set(0,2) ; + ok 152, $hash{"red"} eq "bo" ; + ok 153, $hash{"green"} eq "ho" ; + ok 154, $hash{"blue"} eq "se" ; + + # do a partial get, off end of data + $db->partial_set(3,2) ; + ok 155, $hash{"red"} eq "t" ; + ok 156, $hash{"green"} eq "se" ; + ok 157, $hash{"blue"} eq "" ; + + # switch of partial mode + $db->partial_clear() ; + ok 158, $hash{"red"} eq "boat" ; + ok 159, $hash{"green"} eq "house" ; + ok 160, $hash{"blue"} eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 161, $hash{"red"} = "" ; + ok 162, $hash{"green"} = "AB" ; + ok 163, $hash{"blue"} = "XYZ" ; + ok 164, $hash{"new"} = "KLM" ; + + $db->partial_clear() ; + ok 165, $hash{"red"} eq "at" ; + ok 166, $hash{"green"} eq "ABuse" ; + ok 167, $hash{"blue"} eq "XYZa" ; + ok 168, $hash{"new"} eq "KLM" ; + + # now partial put + $db->partial_set(3,2) ; + ok 169, $hash{"red"} = "PPP" ; + ok 170, $hash{"green"} = "Q" ; + ok 171, $hash{"blue"} = "XYZ" ; + ok 172, $hash{"new"} = "TU" ; + + $db->partial_clear() ; + ok 173, $hash{"red"} eq "at\0PPP" ; + ok 174, $hash{"green"} eq "ABuQ" ; + ok 175, $hash{"blue"} eq "XYZXYZ" ; + ok 176, $hash{"new"} eq "KLMTU" ; +} + +{ + # transaction + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 177, my $lexD = new LexDir($home) ; + ok 178, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 179, my $txn = $env->txn_begin() ; + ok 180, my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + ok 181, (my $Z = $txn->txn_commit()) == 0 ; + ok 182, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db1->db_put($k, $v) ; + } + ok 183, $ret == 0 ; + + # should be able to see all the records + + ok 184, my $cursor = $db1->db_cursor() ; + my ($k, $v) = ("", "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 185, $count == 3 ; + undef $cursor ; + + # now abort the transaction + #ok 151, $txn->txn_abort() == 0 ; + ok 186, ($Z = $txn->txn_abort()) == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 187, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 188, $count == 0 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $env ; + untie %hash ; +} + +{ + # DB_DUP + + my $lex = new LexFile $Dfile ; + my %hash ; + ok 189, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + $hash{'Wall'} = 'Larry' ; + $hash{'Wall'} = 'Stone' ; + $hash{'Smith'} = 'John' ; + $hash{'Wall'} = 'Brick' ; + $hash{'Wall'} = 'Brick' ; + $hash{'mouse'} = 'mickey' ; + + ok 190, keys %hash == 6 ; + + # create a cursor + ok 191, my $cursor = $db->db_cursor() ; + + my $key = "Wall" ; + my $value ; + ok 192, $cursor->c_get($key, $value, DB_SET) == 0 ; + ok 193, $key eq "Wall" && $value eq "Larry" ; + ok 194, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 195, $key eq "Wall" && $value eq "Stone" ; + ok 196, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 197, $key eq "Wall" && $value eq "Brick" ; + ok 198, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 199, $key eq "Wall" && $value eq "Brick" ; + + #my $ref = $db->db_stat() ; + #ok 200, ($ref->{bt_flags} | DB_DUP) == DB_DUP ; +#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n"; + + undef $db ; + undef $cursor ; + untie %hash ; + +} + +{ + # db_stat + + my $lex = new LexFile $Dfile ; + my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ; + my %hash ; + my ($k, $v) ; + ok 200, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Flags => DB_CREATE, + -Minkey =>3 , + -Pagesize => 2 **12 + ; + + my $ref = $db->db_stat() ; + ok 201, $ref->{$recs} == 0; + ok 202, $ref->{'bt_minkey'} == 3; + ok 203, $ref->{'bt_pagesize'} == 2 ** 12; + + # create some data + my %data = ( + "red" => 2, + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 204, $ret == 0 ; + + $ref = $db->db_stat() ; + ok 205, $ref->{$recs} == 3; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use BerkeleyDB; + @ISA=qw(BerkeleyDB::Btree); + @EXPORT = @BerkeleyDB::EXPORT ; + + sub db_put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::db_put($key, $value * 3) ; + } + + sub db_get { + my $self = shift ; + $self->SUPER::db_get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok 206, $@ eq "" ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB", -Filename => "dbbtree.tmp", + -Flags => DB_CREATE, + -Mode => 0640 ); + ' ; + + main::ok 207, $@ eq "" && $X ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok 208, $@ eq "" ; + main::ok 209, $ret == 7 ; + + my $value = 0; + $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ; + main::ok 210, $@ eq "" ; + main::ok 211, $ret == 10 ; + + $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; + main::ok 212, $@ eq "" ; + main::ok 213, $ret == 1 ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok 214, $@ eq "" ; + main::ok 215, $ret eq "[[10]]" ; + + undef $X; + untie %h; + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + +{ + # DB_RECNUM, DB_SET_RECNO & DB_GET_RECNO + + my $lex = new LexFile $Dfile ; + my %hash ; + my ($k, $v) = ("", ""); + ok 216, my $db = new BerkeleyDB::Btree + -Filename => $Dfile, + -Flags => DB_CREATE, + -Property => DB_RECNUM ; + + + # create some data + my @data = ( + "A zero", + "B one", + "C two", + "D three", + "E four" + ) ; + + my $ix = 0 ; + my $ret = 0 ; + foreach (@data) { + $ret += $db->db_put($_, $ix) ; + ++ $ix ; + } + ok 217, $ret == 0 ; + + # db_get & DB_SET_RECNO + $k = 1 ; + ok 218, $db->db_get($k, $v, DB_SET_RECNO) == 0; + ok 219, $k eq "B one" && $v == 1 ; + + $k = 3 ; + ok 220, $db->db_get($k, $v, DB_SET_RECNO) == 0; + ok 221, $k eq "D three" && $v == 3 ; + + $k = 4 ; + ok 222, $db->db_get($k, $v, DB_SET_RECNO) == 0; + ok 223, $k eq "E four" && $v == 4 ; + + $k = 0 ; + ok 224, $db->db_get($k, $v, DB_SET_RECNO) == 0; + ok 225, $k eq "A zero" && $v == 0 ; + + # cursor & DB_SET_RECNO + + # create the cursor + ok 226, my $cursor = $db->db_cursor() ; + + $k = 2 ; + ok 227, $db->db_get($k, $v, DB_SET_RECNO) == 0; + ok 228, $k eq "C two" && $v == 2 ; + + $k = 0 ; + ok 229, $cursor->c_get($k, $v, DB_SET_RECNO) == 0; + ok 230, $k eq "A zero" && $v == 0 ; + + $k = 3 ; + ok 231, $db->db_get($k, $v, DB_SET_RECNO) == 0; + ok 232, $k eq "D three" && $v == 3 ; + + # cursor & DB_GET_RECNO + ok 233, $cursor->c_get($k, $v, DB_FIRST) == 0 ; + ok 234, $k eq "A zero" && $v == 0 ; + ok 235, $cursor->c_get($k, $v, DB_GET_RECNO) == 0; + ok 236, $v == 0 ; + + ok 237, $cursor->c_get($k, $v, DB_NEXT) == 0 ; + ok 238, $k eq "B one" && $v == 1 ; + ok 239, $cursor->c_get($k, $v, DB_GET_RECNO) == 0; + ok 240, $v == 1 ; + + ok 241, $cursor->c_get($k, $v, DB_LAST) == 0 ; + ok 242, $k eq "E four" && $v == 4 ; + ok 243, $cursor->c_get($k, $v, DB_GET_RECNO) == 0; + ok 244, $v == 4 ; + +} + diff --git a/bdb/perl/BerkeleyDB/t/destroy.t b/bdb/perl/BerkeleyDB/t/destroy.t new file mode 100644 index 00000000000..7457d36c583 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/destroy.t @@ -0,0 +1,105 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..15\n"; + +my $Dfile = "dbhash.tmp"; +my $home = "./fred" ; + +umask(0); + +{ + # let object destruction kill everything + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + ok 1, my $lexD = new LexDir($home) ; + ok 2, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 3, my $txn = $env->txn_begin() ; + ok 4, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + ok 5, $txn->txn_commit() == 0 ; + ok 6, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db1->db_put($k, $v) ; + } + ok 7, $ret == 0 ; + + # should be able to see all the records + + ok 8, my $cursor = $db1->db_cursor() ; + my ($k, $v) = ("", "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 9, $count == 3 ; + undef $cursor ; + + # now abort the transaction + ok 10, $txn->txn_abort() == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 11, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 12, $count == 0 ; + + #undef $txn ; + #undef $cursor ; + #undef $db1 ; + #undef $env ; + #untie %hash ; + +} + +{ + my $lex = new LexFile $Dfile ; + my %hash ; + my $cursor ; + my ($k, $v) = ("", "") ; + ok 13, my $db1 = tie %hash, 'BerkeleyDB::Hash', + -Filename => $Dfile, + -Flags => DB_CREATE ; + my $count = 0 ; + # sequence forwards + ok 14, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 15, $count == 0 ; +} + + diff --git a/bdb/perl/BerkeleyDB/t/env.t b/bdb/perl/BerkeleyDB/t/env.t new file mode 100644 index 00000000000..3905abfae43 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/env.t @@ -0,0 +1,217 @@ +#!./perl -w + +# ID: 1.2, 7/17/97 + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..47\n"; + +my $Dfile = "dbhash.tmp"; + +umask(0); + +{ + # db version stuff + my ($major, $minor, $patch) = (0, 0, 0) ; + + ok 1, my $VER = BerkeleyDB::DB_VERSION_STRING ; + ok 2, my $ver = BerkeleyDB::db_version($major, $minor, $patch) ; + ok 3, $VER eq $ver ; + ok 4, $major > 1 ; + ok 5, defined $minor ; + ok 6, defined $patch ; +} + +{ + # Check for invalid parameters + my $env ; + eval ' $env = new BerkeleyDB::Env( -Stupid => 3) ; ' ; + ok 7, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $env = new BerkeleyDB::Env( -Bad => 2, -Home => "/tmp", -Stupid => 3) ; ' ; + ok 8, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $env = new BerkeleyDB::Env (-Config => {"fred" => " "} ) ; ' ; + ok 9, !$env ; + ok 10, $BerkeleyDB::Error =~ /^illegal name-value pair/ ; +} + +{ + # create a very simple environment + my $home = "./fred" ; + ok 11, my $lexD = new LexDir($home) ; + chdir "./fred" ; + ok 12, my $env = new BerkeleyDB::Env -Flags => DB_CREATE ; + chdir ".." ; + undef $env ; +} + +{ + # create an environment with a Home + my $home = "./fred" ; + ok 13, my $lexD = new LexDir($home) ; + ok 14, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE ; + + undef $env ; +} + +{ + # make new fail. + my $home = "./not_there" ; + rmtree $home ; + ok 15, ! -d $home ; + my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_INIT_LOCK ; + ok 16, ! $env ; + ok 17, $! != 0 || $^E != 0 ; + + rmtree $home ; +} + +{ + # Config + use Cwd ; + my $cwd = cwd() ; + my $home = "$cwd/fred" ; + my $data_dir = "$home/data_dir" ; + my $log_dir = "$home/log_dir" ; + my $data_file = "data.db" ; + ok 18, my $lexD = new LexDir($home) ; + ok 19, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ; + ok 20, -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ; + my $env = new BerkeleyDB::Env -Home => $home, + -Config => { DB_DATA_DIR => $data_dir, + DB_LOG_DIR => $log_dir + }, + -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 21, $env ; + + ok 22, my $txn = $env->txn_begin() ; + + my %hash ; + ok 23, tie %hash, 'BerkeleyDB::Hash', -Filename => $data_file, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + $hash{"abc"} = 123 ; + $hash{"def"} = 456 ; + + $txn->txn_commit() ; + + untie %hash ; + + undef $txn ; + undef $env ; +} + +{ + # -ErrFile with a filename + my $errfile = "./errfile" ; + my $home = "./fred" ; + ok 24, my $lexD = new LexDir($home) ; + my $lex = new LexFile $errfile ; + ok 25, my $env = new BerkeleyDB::Env( -ErrFile => $errfile, + -Flags => DB_CREATE, + -Home => $home) ; + my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Env => $env, + -Flags => -1; + ok 26, !$db ; + + ok 27, $BerkeleyDB::Error =~ /^illegal flag specified to (db_open|DB->open)/; + ok 28, -e $errfile ; + my $contents = docat($errfile) ; + chomp $contents ; + ok 29, $BerkeleyDB::Error eq $contents ; + + undef $env ; +} + +{ + # -ErrFile with a filehandle/reference -- should fail + my $home = "./fred" ; + ok 30, my $lexD = new LexDir($home) ; + eval { my $env = new BerkeleyDB::Env( -ErrFile => [], + -Flags => DB_CREATE, + -Home => $home) ; }; + ok 31, $@ =~ /ErrFile parameter must be a file name/; +} + +{ + # -ErrPrefix + use IO ; + my $home = "./fred" ; + ok 32, my $lexD = new LexDir($home) ; + my $errfile = "./errfile" ; + my $lex = new LexFile $errfile ; + ok 33, my $env = new BerkeleyDB::Env( -ErrFile => $errfile, + -ErrPrefix => "PREFIX", + -Flags => DB_CREATE, + -Home => $home) ; + my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Env => $env, + -Flags => -1; + ok 34, !$db ; + + ok 35, $BerkeleyDB::Error =~ /^PREFIX: illegal flag specified to (db_open|DB->open)/; + ok 36, -e $errfile ; + my $contents = docat($errfile) ; + chomp $contents ; + ok 37, $BerkeleyDB::Error eq $contents ; + + # change the prefix on the fly + my $old = $env->errPrefix("NEW ONE") ; + ok 38, $old eq "PREFIX" ; + + $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Env => $env, + -Flags => -1; + ok 39, !$db ; + ok 40, $BerkeleyDB::Error =~ /^NEW ONE: illegal flag specified to (db_open|DB->open)/; + $contents = docat($errfile) ; + chomp $contents ; + ok 41, $contents =~ /$BerkeleyDB::Error$/ ; + undef $env ; +} + +{ + # test db_appexit + use Cwd ; + my $cwd = cwd() ; + my $home = "$cwd/fred" ; + my $data_dir = "$home/data_dir" ; + my $log_dir = "$home/log_dir" ; + my $data_file = "data.db" ; + ok 42, my $lexD = new LexDir($home); + ok 43, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ; + ok 44, -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ; + my $env = new BerkeleyDB::Env -Home => $home, + -Config => { DB_DATA_DIR => $data_dir, + DB_LOG_DIR => $log_dir + }, + -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 45, $env ; + + ok 46, my $txn_mgr = $env->TxnMgr() ; + + ok 47, $env->db_appexit() == 0 ; + +} + +# test -Verbose +# test -Flags +# db_value_set diff --git a/bdb/perl/BerkeleyDB/t/examples.t b/bdb/perl/BerkeleyDB/t/examples.t new file mode 100644 index 00000000000..69b7f8ff8c5 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/examples.t @@ -0,0 +1,401 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util; + +print "1..7\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +my $redirect = "xyzt" ; + + +{ +my $x = $BerkeleyDB::Error; +my $redirect = "xyzt" ; + { + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + use vars qw( %h $k $v ) ; + + my $filename = "fruit" ; + unlink $filename ; + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(1, docat_del($redirect) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("apple", "red") ; + $db->db_put("orange", "orange") ; + $db->db_put("banana", "yellow") ; + $db->db_put("tomato", "red") ; + + # Check for existence of a key + print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0; + + # Delete a key/value pair. + $db->db_del("apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(2, docat_del($redirect) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my $filename = "tree" ; + unlink $filename ; + my %h ; + tie %h, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]\n" ; + ok(3, docat_del($redirect) eq <<'EOM') ; +Smith +Wall +mouse +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my $filename = "tree" ; + unlink $filename ; + my %h ; + tie %h, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE, + -Compare => sub { lc $_[0] cmp lc $_[1] } + or die "Cannot open $filename: $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]\n" ; + ok(4, docat_del($redirect) eq <<'EOM') ; +mouse +Smith +Wall +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my %hash ; + my $filename = "filt.db" ; + unlink $filename ; + + my $db = tie %hash, 'BerkeleyDB::Hash', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; + $db = tie %hash, 'BerkeleyDB::Hash', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + while (($k, $v) = each %hash) + { print "$k -> $v\n" } + undef $db ; + untie %hash ; + + unlink $filename ; + } + + #print "[" . docat($redirect) . "]\n" ; + ok(5, docat_del($redirect) eq <<"EOM") ; +abc\x00 -> def\x00 +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + my %hash ; + my $filename = "filt.db" ; + unlink $filename ; + + + my $db = tie %hash, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; + $db = tie %hash, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot Open $filename: $!\n" ; + while (($k, $v) = each %hash) + { print "$k -> $v\n" } + undef $db ; + untie %hash ; + + unlink $filename ; + } + + my $val = pack("i", 123) ; + #print "[" . docat($redirect) . "]\n" ; + ok(6, docat_del($redirect) eq <<"EOM") ; +$val -> def +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + if ($FA) { + use strict ; + use BerkeleyDB ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + tie @h, 'BerkeleyDB::Recno', + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_RENUMBER + or die "Cannot open $filename: $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + push @h, "green", "black" ; + + my $elements = scalar @h ; + print "The array contains $elements entries\n" ; + + my $last = pop @h ; + print "popped $last\n" ; + + unshift @h, "white" ; + my $first = shift @h ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + untie @h ; + unlink $filename ; + } else { + use strict ; + use BerkeleyDB ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $db = tie @h, 'BerkeleyDB::Recno', + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_RENUMBER + or die "Cannot open $filename: $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $db->push("green", "black") ; + + my $elements = $db->length() ; + print "The array contains $elements entries\n" ; + + my $last = $db->pop ; + print "popped $last\n" ; + + $db->unshift("white") ; + my $first = $db->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + undef $db ; + untie @h ; + unlink $filename ; + } + + } + + #print "[" . docat($redirect) . "]\n" ; + ok(7, docat_del($redirect) eq <<"EOM") ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +EOM + +} + diff --git a/bdb/perl/BerkeleyDB/t/examples.t.T b/bdb/perl/BerkeleyDB/t/examples.t.T new file mode 100644 index 00000000000..fe9bdf76b06 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/examples.t.T @@ -0,0 +1,415 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util; + +print "1..7\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +my $redirect = "xyzt" ; + + +{ +my $x = $BerkeleyDB::Error; +my $redirect = "xyzt" ; + { + my $redirectObj = new Redirect $redirect ; + +## BEGIN simpleHash + use strict ; + use BerkeleyDB ; + use vars qw( %h $k $v ) ; + + my $filename = "fruit" ; + unlink $filename ; + tie %h, "BerkeleyDB::Hash", + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; +## END simpleHash + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(1, docat_del($redirect) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + +## BEGIN simpleHash2 + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("apple", "red") ; + $db->db_put("orange", "orange") ; + $db->db_put("banana", "yellow") ; + $db->db_put("tomato", "red") ; + + # Check for existence of a key + print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0; + + # Delete a key/value pair. + $db->db_del("apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; +## END simpleHash2 + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(2, docat_del($redirect) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + +## BEGIN btreeSimple + use strict ; + use BerkeleyDB ; + + my $filename = "tree" ; + unlink $filename ; + my %h ; + tie %h, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; +## END btreeSimple + unlink $filename ; + } + + #print "[" . docat($redirect) . "]\n" ; + ok(3, docat_del($redirect) eq <<'EOM') ; +Smith +Wall +mouse +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + +## BEGIN btreeSortOrder + use strict ; + use BerkeleyDB ; + + my $filename = "tree" ; + unlink $filename ; + my %h ; + tie %h, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE, + -Compare => sub { lc $_[0] cmp lc $_[1] } + or die "Cannot open $filename: $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; +## END btreeSortOrder + unlink $filename ; + } + + #print "[" . docat($redirect) . "]\n" ; + ok(4, docat_del($redirect) eq <<'EOM') ; +mouse +Smith +Wall +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + +## BEGIN nullFilter + use strict ; + use BerkeleyDB ; + + my %hash ; + my $filename = "filt.db" ; + unlink $filename ; + + my $db = tie %hash, 'BerkeleyDB::Hash', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; +## END nullFilter + $db = tie %hash, 'BerkeleyDB::Hash', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + while (($k, $v) = each %hash) + { print "$k -> $v\n" } + undef $db ; + untie %hash ; + + unlink $filename ; + } + + #print "[" . docat($redirect) . "]\n" ; + ok(5, docat_del($redirect) eq <<"EOM") ; +abc\x00 -> def\x00 +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + +## BEGIN intFilter + use strict ; + use BerkeleyDB ; + my %hash ; + my $filename = "filt.db" ; + unlink $filename ; + + + my $db = tie %hash, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; +## END intFilter + $db = tie %hash, 'BerkeleyDB::Btree', + -Filename => $filename, + -Flags => DB_CREATE + or die "Cannot Open $filename: $!\n" ; + while (($k, $v) = each %hash) + { print "$k -> $v\n" } + undef $db ; + untie %hash ; + + unlink $filename ; + } + + my $val = pack("i", 123) ; + #print "[" . docat($redirect) . "]\n" ; + ok(6, docat_del($redirect) eq <<"EOM") ; +$val -> def +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + if ($FA) { +## BEGIN simpleRecno + use strict ; + use BerkeleyDB ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + tie @h, 'BerkeleyDB::Recno', + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_RENUMBER + or die "Cannot open $filename: $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + push @h, "green", "black" ; + + my $elements = scalar @h ; + print "The array contains $elements entries\n" ; + + my $last = pop @h ; + print "popped $last\n" ; + + unshift @h, "white" ; + my $first = shift @h ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + untie @h ; +## END simpleRecno + unlink $filename ; + } else { + use strict ; + use BerkeleyDB ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $db = tie @h, 'BerkeleyDB::Recno', + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_RENUMBER + or die "Cannot open $filename: $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $db->push("green", "black") ; + + my $elements = $db->length() ; + print "The array contains $elements entries\n" ; + + my $last = $db->pop ; + print "popped $last\n" ; + + $db->unshift("white") ; + my $first = $db->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + undef $db ; + untie @h ; + unlink $filename ; + } + + } + + #print "[" . docat($redirect) . "]\n" ; + ok(7, docat_del($redirect) eq <<"EOM") ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +EOM + +} + diff --git a/bdb/perl/BerkeleyDB/t/examples3.t b/bdb/perl/BerkeleyDB/t/examples3.t new file mode 100644 index 00000000000..22e94b770e1 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/examples3.t @@ -0,0 +1,132 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3) { + print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ; + exit 0 ; + } +} + + +print "1..2\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +my $redirect = "xyzt" ; + + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(1, docat_del($redirect) eq <<'EOM') ; +orange -> orange +yellow -> banana +red -> apple +red -> tomato +green -> banana +green -> apple +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP | DB_DUPSORT + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(2, docat_del($redirect) eq <<'EOM') ; +orange -> orange +yellow -> banana +red -> apple +red -> tomato +green -> apple +green -> banana +EOM + +} + + diff --git a/bdb/perl/BerkeleyDB/t/examples3.t.T b/bdb/perl/BerkeleyDB/t/examples3.t.T new file mode 100644 index 00000000000..5eeaa14d00c --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/examples3.t.T @@ -0,0 +1,136 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3) { + print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ; + exit 0 ; + } +} + + +print "1..2\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +my $redirect = "xyzt" ; + + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + +## BEGIN dupHash + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; +## END dupHash + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(1, docat_del($redirect) eq <<'EOM') ; +orange -> orange +yellow -> banana +red -> apple +red -> tomato +green -> banana +green -> apple +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + +## BEGIN dupSortHash + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP | DB_DUPSORT + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; +## END dupSortHash + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(2, docat_del($redirect) eq <<'EOM') ; +orange -> orange +yellow -> banana +red -> apple +red -> tomato +green -> apple +green -> banana +EOM + +} + + diff --git a/bdb/perl/BerkeleyDB/t/filter.t b/bdb/perl/BerkeleyDB/t/filter.t new file mode 100644 index 00000000000..47a7c107acf --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/filter.t @@ -0,0 +1,217 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..46\n"; + +my $Dfile = "dbhash.tmp"; +unlink $Dfile; + +umask(0) ; + + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok 1, $db = tie %h, 'BerkeleyDB::Hash', + -Filename => $Dfile, + -Flags => DB_CREATE; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok 2, checkOutput( "", "fred", "", "joe") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 3, $h{"fred"} eq "joe"; + # fk sk fv sv + ok 4, checkOutput( "", "fred", "joe", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 5, $db->FIRSTKEY() eq "fred" ; + # fk sk fv sv + ok 6, checkOutput( "fred", "", "", "") ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok 7, checkOutput( "", "fred", "", "Jxe") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 8, $h{"Fred"} eq "[Jxe]"; + # fk sk fv sv + ok 9, checkOutput( "", "fred", "[Jxe]", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 10, $db->FIRSTKEY() eq "FRED" ; + # fk sk fv sv + ok 11, checkOutput( "FRED", "", "", "") ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok 12, checkOutput( "", "fred", "", "joe") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 13, $h{"fred"} eq "joe"; + ok 14, checkOutput( "", "fred", "joe", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 15, $db->FIRSTKEY() eq "fred" ; + ok 16, checkOutput( "fred", "", "", "") ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok 17, checkOutput( "", "", "", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 18, $h{"fred"} eq "joe"; + ok 19, checkOutput( "", "", "", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 20, $db->FIRSTKEY() eq "fred" ; + ok 21, checkOutput( "", "", "", "") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok 22, $db = tie %h, 'BerkeleyDB::Hash', + -Filename => $Dfile, + -Flags => DB_CREATE; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok 23, $result{"store key"} eq "store key - 1: [fred]" ; + ok 24, $result{"store value"} eq "store value - 1: [joe]" ; + ok 25, ! defined $result{"fetch key"} ; + ok 26, ! defined $result{"fetch value"} ; + ok 27, $_ eq "original" ; + + ok 28, $db->FIRSTKEY() eq "fred" ; + ok 29, $result{"store key"} eq "store key - 1: [fred]" ; + ok 30, $result{"store value"} eq "store value - 1: [joe]" ; + ok 31, $result{"fetch key"} eq "fetch key - 1: [fred]" ; + ok 32, ! defined $result{"fetch value"} ; + ok 33, $_ eq "original" ; + + $h{"jim"} = "john" ; + ok 34, $result{"store key"} eq "store key - 2: [fred jim]" ; + ok 35, $result{"store value"} eq "store value - 2: [joe john]" ; + ok 36, $result{"fetch key"} eq "fetch key - 1: [fred]" ; + ok 37, ! defined $result{"fetch value"} ; + ok 38, $_ eq "original" ; + + ok 39, $h{"fred"} eq "joe" ; + ok 40, $result{"store key"} eq "store key - 3: [fred jim fred]" ; + ok 41, $result{"store value"} eq "store value - 2: [joe john]" ; + ok 42, $result{"fetch key"} eq "fetch key - 1: [fred]" ; + ok 43, $result{"fetch value"} eq "fetch value - 1: [joe]" ; + ok 44, $_ eq "original" ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok 45, $db = tie %h, 'BerkeleyDB::Hash', + -Filename => $Dfile, + -Flags => DB_CREATE; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok 46, $@ =~ /^BerkeleyDB Aborting: recursion detected in filter_store_key at/ ; + #print "[$@]\n" ; + + undef $db ; + untie %h; + unlink $Dfile; +} + diff --git a/bdb/perl/BerkeleyDB/t/hash.t b/bdb/perl/BerkeleyDB/t/hash.t new file mode 100644 index 00000000000..0e683851c3d --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/hash.t @@ -0,0 +1,728 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..212\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Hash -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Hash -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $db = new BerkeleyDB::Hash -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Hash -Txn => "fred" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Hash -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to HASH + +{ + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put("some key", "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get("some key", $value) == 0 ; + ok 10, $value eq "some value" ; + ok 11, $db->db_put("key", "value") == 0 ; + ok 12, $db->db_get("key", $value) == 0 ; + ok 13, $value eq "value" ; + ok 14, $db->db_del("some key") == 0 ; + ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ; + ok 16, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 17, $db->status() == DB_NOTFOUND ; + ok 18, $db->status() eq $DB_errors{'DB_NOTFOUND'}; + + ok 19, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 20, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 21, $db->status() eq $DB_errors{'DB_KEYEXIST'}; + ok 22, $db->status() == DB_KEYEXIST ; + + # check that the value of the key has not been changed by the + # previous test + ok 23, $db->db_get("key", $value) == 0 ; + ok 24, $value eq "value" ; + + # test DB_GET_BOTH + my ($k, $v) = ("key", "value") ; + ok 25, $db->db_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("key", "fred") ; + ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("another", "value") ; + ok 27, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + +} + +{ + # Check simple env works with a hash. + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + ok 28, my $lexD = new LexDir($home); + + ok 29, my $env = new BerkeleyDB::Env -Flags => DB_CREATE| DB_INIT_MPOOL, + -Home => $home ; + ok 30, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + ok 31, $db->db_put("some key", "some value") == 0 ; + ok 32, $db->db_get("some key", $value) == 0 ; + ok 33, $value eq "some value" ; + undef $db ; + undef $env ; +} + +{ + # override default hash + my $lex = new LexFile $Dfile ; + my $value ; + $::count = 0 ; + ok 34, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Hash => sub { ++$::count ; length $_[0] }, + -Flags => DB_CREATE ; + + ok 35, $db->db_put("some key", "some value") == 0 ; + ok 36, $db->db_get("some key", $value) == 0 ; + ok 37, $value eq "some value" ; + ok 38, $::count > 0 ; + +} + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my %hash ; + my ($k, $v) ; + ok 39, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => 2, + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 40, $ret == 0 ; + + # create the cursor + ok 41, my $cursor = $db->db_cursor() ; + + $k = $v = "" ; + my %copy = %data ; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 42, $cursor->status() == DB_NOTFOUND ; + ok 43, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 46, $status == DB_NOTFOUND ; + ok 47, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 48, $cursor->status() == $status ; + ok 49, $cursor->status() eq $status ; + ok 50, keys %copy == 0 ; + ok 51, $extras == 0 ; + + ($k, $v) = ("green", "house") ; + ok 52, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("green", "door") ; + ok 53, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("black", "house") ; + ok 54, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + +} + +{ + # Tied Hash interface + + my $lex = new LexFile $Dfile ; + my %hash ; + ok 55, tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # check "each" with an empty database + my $count = 0 ; + while (my ($k, $v) = each %hash) { + ++ $count ; + } + ok 56, (tied %hash)->status() == DB_NOTFOUND ; + ok 57, $count == 0 ; + + # Add a k/v pair + my $value ; + $hash{"some key"} = "some value"; + ok 58, (tied %hash)->status() == 0 ; + ok 59, $hash{"some key"} eq "some value"; + ok 60, defined $hash{"some key"} ; + ok 61, (tied %hash)->status() == 0 ; + ok 62, exists $hash{"some key"} ; + ok 63, !defined $hash{"jimmy"} ; + ok 64, (tied %hash)->status() == DB_NOTFOUND ; + ok 65, !exists $hash{"jimmy"} ; + ok 66, (tied %hash)->status() == DB_NOTFOUND ; + + delete $hash{"some key"} ; + ok 67, (tied %hash)->status() == 0 ; + ok 68, ! defined $hash{"some key"} ; + ok 69, (tied %hash)->status() == DB_NOTFOUND ; + ok 70, ! exists $hash{"some key"} ; + ok 71, (tied %hash)->status() == DB_NOTFOUND ; + + $hash{1} = 2 ; + $hash{10} = 20 ; + $hash{1000} = 2000 ; + + my ($keys, $values) = (0,0); + $count = 0 ; + while (my ($k, $v) = each %hash) { + $keys += $k ; + $values += $v ; + ++ $count ; + } + ok 72, $count == 3 ; + ok 73, $keys == 1011 ; + ok 74, $values == 2022 ; + + # now clear the hash + %hash = () ; + ok 75, keys %hash == 0 ; + + untie %hash ; +} + +{ + # in-memory file + + my $lex = new LexFile $Dfile ; + my %hash ; + my $fd ; + my $value ; + ok 76, my $db = tie %hash, 'BerkeleyDB::Hash' ; + + ok 77, $db->db_put("some key", "some value") == 0 ; + ok 78, $db->db_get("some key", $value) == 0 ; + ok 79, $value eq "some value" ; + + undef $db ; + untie %hash ; +} + +{ + # partial + # check works via API + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + ok 80, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 81, $ret == 0 ; + + + # do a partial get + my($pon, $off, $len) = $db->partial_set(0,2) ; + ok 82, $pon == 0 && $off == 0 && $len == 0 ; + ok 83, ( $db->db_get("red", $value) == 0) && $value eq "bo" ; + ok 84, ( $db->db_get("green", $value) == 0) && $value eq "ho" ; + ok 85, ( $db->db_get("blue", $value) == 0) && $value eq "se" ; + + # do a partial get, off end of data + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 86, $pon ; + ok 87, $off == 0 ; + ok 88, $len == 2 ; + ok 89, $db->db_get("red", $value) == 0 && $value eq "t" ; + ok 90, $db->db_get("green", $value) == 0 && $value eq "se" ; + ok 91, $db->db_get("blue", $value) == 0 && $value eq "" ; + + # switch of partial mode + ($pon, $off, $len) = $db->partial_clear() ; + ok 92, $pon ; + ok 93, $off == 3 ; + ok 94, $len == 2 ; + ok 95, $db->db_get("red", $value) == 0 && $value eq "boat" ; + ok 96, $db->db_get("green", $value) == 0 && $value eq "house" ; + ok 97, $db->db_get("blue", $value) == 0 && $value eq "sea" ; + + # now partial put + ($pon, $off, $len) = $db->partial_set(0,2) ; + ok 98, ! $pon ; + ok 99, $off == 0 ; + ok 100, $len == 0 ; + ok 101, $db->db_put("red", "") == 0 ; + ok 102, $db->db_put("green", "AB") == 0 ; + ok 103, $db->db_put("blue", "XYZ") == 0 ; + ok 104, $db->db_put("new", "KLM") == 0 ; + + $db->partial_clear() ; + ok 105, $db->db_get("red", $value) == 0 && $value eq "at" ; + ok 106, $db->db_get("green", $value) == 0 && $value eq "ABuse" ; + ok 107, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ; + ok 108, $db->db_get("new", $value) == 0 && $value eq "KLM" ; + + # now partial put + $db->partial_set(3,2) ; + ok 109, $db->db_put("red", "PPP") == 0 ; + ok 110, $db->db_put("green", "Q") == 0 ; + ok 111, $db->db_put("blue", "XYZ") == 0 ; + ok 112, $db->db_put("new", "--") == 0 ; + + ($pon, $off, $len) = $db->partial_clear() ; + ok 113, $pon ; + ok 114, $off == 3 ; + ok 115, $len == 2 ; + ok 116, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ; + ok 117, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ; + ok 118, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ; + ok 119, $db->db_get("new", $value) == 0 && $value eq "KLM--" ; +} + +{ + # partial + # check works via tied hash + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + ok 120, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + while (my ($k, $v) = each %data) { + $hash{$k} = $v ; + } + + + # do a partial get + $db->partial_set(0,2) ; + ok 121, $hash{"red"} eq "bo" ; + ok 122, $hash{"green"} eq "ho" ; + ok 123, $hash{"blue"} eq "se" ; + + # do a partial get, off end of data + $db->partial_set(3,2) ; + ok 124, $hash{"red"} eq "t" ; + ok 125, $hash{"green"} eq "se" ; + ok 126, $hash{"blue"} eq "" ; + + # switch of partial mode + $db->partial_clear() ; + ok 127, $hash{"red"} eq "boat" ; + ok 128, $hash{"green"} eq "house" ; + ok 129, $hash{"blue"} eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 130, $hash{"red"} = "" ; + ok 131, $hash{"green"} = "AB" ; + ok 132, $hash{"blue"} = "XYZ" ; + ok 133, $hash{"new"} = "KLM" ; + + $db->partial_clear() ; + ok 134, $hash{"red"} eq "at" ; + ok 135, $hash{"green"} eq "ABuse" ; + ok 136, $hash{"blue"} eq "XYZa" ; + ok 137, $hash{"new"} eq "KLM" ; + + # now partial put + $db->partial_set(3,2) ; + ok 138, $hash{"red"} = "PPP" ; + ok 139, $hash{"green"} = "Q" ; + ok 140, $hash{"blue"} = "XYZ" ; + ok 141, $hash{"new"} = "TU" ; + + $db->partial_clear() ; + ok 142, $hash{"red"} eq "at\0PPP" ; + ok 143, $hash{"green"} eq "ABuQ" ; + ok 144, $hash{"blue"} eq "XYZXYZ" ; + ok 145, $hash{"new"} eq "KLMTU" ; +} + +{ + # transaction + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 146, my $lexD = new LexDir($home); + ok 147, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 148, my $txn = $env->txn_begin() ; + ok 149, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + ok 150, $txn->txn_commit() == 0 ; + ok 151, $txn = $env->txn_begin() ; + $db1->Txn($txn); + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db1->db_put($k, $v) ; + } + ok 152, $ret == 0 ; + + # should be able to see all the records + + ok 153, my $cursor = $db1->db_cursor() ; + my ($k, $v) = ("", "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 154, $count == 3 ; + undef $cursor ; + + # now abort the transaction + ok 155, $txn->txn_abort() == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 156, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 157, $count == 0 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $env ; + untie %hash ; +} + + +{ + # DB_DUP + + my $lex = new LexFile $Dfile ; + my %hash ; + ok 158, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + $hash{'Wall'} = 'Larry' ; + $hash{'Wall'} = 'Stone' ; + $hash{'Smith'} = 'John' ; + $hash{'Wall'} = 'Brick' ; + $hash{'Wall'} = 'Brick' ; + $hash{'mouse'} = 'mickey' ; + + ok 159, keys %hash == 6 ; + + # create a cursor + ok 160, my $cursor = $db->db_cursor() ; + + my $key = "Wall" ; + my $value ; + ok 161, $cursor->c_get($key, $value, DB_SET) == 0 ; + ok 162, $key eq "Wall" && $value eq "Larry" ; + ok 163, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 164, $key eq "Wall" && $value eq "Stone" ; + ok 165, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 166, $key eq "Wall" && $value eq "Brick" ; + ok 167, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 168, $key eq "Wall" && $value eq "Brick" ; + + #my $ref = $db->db_stat() ; + #ok 143, $ref->{bt_flags} | DB_DUP ; + + # test DB_DUP_NEXT + my ($k, $v) = ("Wall", "") ; + ok 169, $cursor->c_get($k, $v, DB_SET) == 0 ; + ok 170, $k eq "Wall" && $v eq "Larry" ; + ok 171, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ; + ok 172, $k eq "Wall" && $v eq "Stone" ; + ok 173, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ; + ok 174, $k eq "Wall" && $v eq "Brick" ; + ok 175, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ; + ok 176, $k eq "Wall" && $v eq "Brick" ; + ok 177, $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ; + + + undef $db ; + undef $cursor ; + untie %hash ; + +} + +{ + # DB_DUP & DupCompare + my $lex = new LexFile $Dfile, $Dfile2; + my ($key, $value) ; + my (%h, %g) ; + my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ; + my @Values = qw( 1 11 3 dd x abc 2 0 ) ; + + ok 178, tie %h, "BerkeleyDB::Hash", -Filename => $Dfile, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Flags => DB_CREATE ; + + ok 179, tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2, + -DupCompare => sub { $_[0] <=> $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Flags => DB_CREATE ; + + foreach (@Keys) { + local $^W = 0 ; + my $value = shift @Values ; + $h{$_} = $value ; + $g{$_} = $value ; + } + + ok 180, my $cursor = (tied %h)->db_cursor() ; + $key = 9 ; $value = ""; + ok 181, $cursor->c_get($key, $value, DB_SET) == 0 ; + ok 182, $key == 9 && $value eq 11 ; + ok 183, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 184, $key == 9 && $value == 2 ; + ok 185, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 186, $key == 9 && $value eq "x" ; + + $cursor = (tied %g)->db_cursor() ; + $key = 9 ; + ok 187, $cursor->c_get($key, $value, DB_SET) == 0 ; + ok 188, $key == 9 && $value eq "x" ; + ok 189, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 190, $key == 9 && $value == 2 ; + ok 191, $cursor->c_get($key, $value, DB_NEXT) == 0 ; + ok 192, $key == 9 && $value == 11 ; + + +} + +{ + # get_dup etc + my $lex = new LexFile $Dfile; + my %hh ; + + ok 193, my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + $hh{'Wall'} = 'Larry' ; + $hh{'Wall'} = 'Stone' ; # Note the duplicate key + $hh{'Wall'} = 'Brick' ; # Note the duplicate key + $hh{'Smith'} = 'John' ; + $hh{'mouse'} = 'mickey' ; + + # first work in scalar context + ok 194, scalar $YY->get_dup('Unknown') == 0 ; + ok 195, scalar $YY->get_dup('Smith') == 1 ; + ok 196, scalar $YY->get_dup('Wall') == 3 ; + + # now in list context + my @unknown = $YY->get_dup('Unknown') ; + ok 197, "@unknown" eq "" ; + + my @smith = $YY->get_dup('Smith') ; + ok 198, "@smith" eq "John" ; + + { + my @wall = $YY->get_dup('Wall') ; + my %wall ; + @wall{@wall} = @wall ; + ok 199, (@wall == 3 && $wall{'Larry'} + && $wall{'Stone'} && $wall{'Brick'}); + } + + # hash + my %unknown = $YY->get_dup('Unknown', 1) ; + ok 200, keys %unknown == 0 ; + + my %smith = $YY->get_dup('Smith', 1) ; + ok 201, keys %smith == 1 && $smith{'John'} ; + + my %wall = $YY->get_dup('Wall', 1) ; + ok 202, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 + && $wall{'Brick'} == 1 ; + + undef $YY ; + untie %hh ; + +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use BerkeleyDB; + @ISA=qw(BerkeleyDB::Hash); + @EXPORT = @BerkeleyDB::EXPORT ; + + sub db_put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::db_put($key, $value * 3) ; + } + + sub db_get { + my $self = shift ; + $self->SUPER::db_get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok 203, $@ eq "" ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB", -Filename => "dbhash.tmp", + -Flags => DB_CREATE, + -Mode => 0640 ); + ' ; + + main::ok 204, $@ eq "" ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok 205, $@ eq "" ; + main::ok 206, $ret == 7 ; + + my $value = 0; + $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ; + main::ok 207, $@ eq "" ; + main::ok 208, $ret == 10 ; + + $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; + main::ok 209, $@ eq "" ; + main::ok 210, $ret == 1 ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok 211, $@ eq "" ; + main::ok 212, $ret eq "[[10]]" ; + + unlink "SubDB.pm", "dbhash.tmp" ; + +} diff --git a/bdb/perl/BerkeleyDB/t/join.t b/bdb/perl/BerkeleyDB/t/join.t new file mode 100644 index 00000000000..ed9b6a269cb --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/join.t @@ -0,0 +1,225 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +if ($BerkeleyDB::db_ver < 2.005002) +{ + print "1..0 # Skip: join needs Berkeley DB 2.5.2 or later\n" ; + exit 0 ; +} + + +print "1..37\n"; + +my $Dfile1 = "dbhash1.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile1, $Dfile2, $Dfile3 ; + +umask(0) ; + +{ + # error cases + my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ; + my %hash1 ; + my $value ; + my $status ; + my $cursor ; + + ok 1, my $db1 = tie %hash1, 'BerkeleyDB::Hash', + -Filename => $Dfile1, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] lt $_[1] }, + -Property => DB_DUP|DB_DUPSORT ; + + # no cursors supplied + eval '$cursor = $db1->db_join() ;' ; + ok 2, $@ =~ /Usage: \$db->BerkeleyDB::Common::db_join\Q([cursors], flags=0)/; + + # empty list + eval '$cursor = $db1->db_join([]) ;' ; + ok 3, $@ =~ /db_join: No cursors in parameter list/; + + # cursor list, isn't a [] + eval '$cursor = $db1->db_join({}) ;' ; + ok 4, $@ =~ /cursors is not an array reference at/ ; + + eval '$cursor = $db1->db_join(\1) ;' ; + ok 5, $@ =~ /cursors is not an array reference at/ ; + +} + +{ + # test a 2-way & 3-way join + + my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ; + my %hash1 ; + my %hash2 ; + my %hash3 ; + my $value ; + my $status ; + + my $home = "./fred" ; + ok 6, my $lexD = new LexDir($home); + ok 7, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN + |DB_INIT_MPOOL; + #|DB_INIT_MPOOL| DB_INIT_LOCK; + ok 8, my $txn = $env->txn_begin() ; + ok 9, my $db1 = tie %hash1, 'BerkeleyDB::Hash', + -Filename => $Dfile1, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Env => $env, + -Txn => $txn ; + ; + + ok 10, my $db2 = tie %hash2, 'BerkeleyDB::Hash', + -Filename => $Dfile2, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Env => $env, + -Txn => $txn ; + + ok 11, my $db3 = tie %hash3, 'BerkeleyDB::Btree', + -Filename => $Dfile3, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Env => $env, + -Txn => $txn ; + + + ok 12, addData($db1, qw( apple Convenience + peach Shopway + pear Farmer + raspberry Shopway + strawberry Shopway + gooseberry Farmer + blueberry Farmer + )); + + ok 13, addData($db2, qw( red apple + red raspberry + red strawberry + yellow peach + yellow pear + green gooseberry + blue blueberry)) ; + + ok 14, addData($db3, qw( expensive apple + reasonable raspberry + expensive strawberry + reasonable peach + reasonable pear + expensive gooseberry + reasonable blueberry)) ; + + ok 15, my $cursor2 = $db2->db_cursor() ; + my $k = "red" ; + my $v = "" ; + ok 16, $cursor2->c_get($k, $v, DB_SET) == 0 ; + + # Two way Join + ok 17, my $cursor1 = $db1->db_join([$cursor2]) ; + + my %expected = qw( apple Convenience + raspberry Shopway + strawberry Shopway + ) ; + + # sequence forwards + while ($cursor1->c_get($k, $v) == 0) { + delete $expected{$k} + if defined $expected{$k} && $expected{$k} eq $v ; + #print "[$k] [$v]\n" ; + } + ok 18, keys %expected == 0 ; + ok 19, $cursor1->status() == DB_NOTFOUND ; + + # Three way Join + ok 20, $cursor2 = $db2->db_cursor() ; + $k = "red" ; + $v = "" ; + ok 21, $cursor2->c_get($k, $v, DB_SET) == 0 ; + + ok 22, my $cursor3 = $db3->db_cursor() ; + $k = "expensive" ; + $v = "" ; + ok 23, $cursor3->c_get($k, $v, DB_SET) == 0 ; + ok 24, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ; + + %expected = qw( apple Convenience + strawberry Shopway + ) ; + + # sequence forwards + while ($cursor1->c_get($k, $v) == 0) { + delete $expected{$k} + if defined $expected{$k} && $expected{$k} eq $v ; + #print "[$k] [$v]\n" ; + } + ok 25, keys %expected == 0 ; + ok 26, $cursor1->status() == DB_NOTFOUND ; + + # test DB_JOIN_ITEM + # ################# + ok 27, $cursor2 = $db2->db_cursor() ; + $k = "red" ; + $v = "" ; + ok 28, $cursor2->c_get($k, $v, DB_SET) == 0 ; + + ok 29, $cursor3 = $db3->db_cursor() ; + $k = "expensive" ; + $v = "" ; + ok 30, $cursor3->c_get($k, $v, DB_SET) == 0 ; + ok 31, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ; + + %expected = qw( apple 1 + strawberry 1 + ) ; + + # sequence forwards + $k = "" ; + $v = "" ; + while ($cursor1->c_get($k, $v, DB_JOIN_ITEM) == 0) { + delete $expected{$k} + if defined $expected{$k} ; + #print "[$k]\n" ; + } + ok 32, keys %expected == 0 ; + ok 33, $cursor1->status() == DB_NOTFOUND ; + + ok 34, $cursor1->c_close() == 0 ; + ok 35, $cursor2->c_close() == 0 ; + ok 36, $cursor3->c_close() == 0 ; + + ok 37, ($status = $txn->txn_commit) == 0; + + undef $txn ; + #undef $cursor1; + #undef $cursor2; + #undef $cursor3; + undef $db1 ; + undef $db2 ; + undef $db3 ; + undef $env ; + untie %hash1 ; + untie %hash2 ; + untie %hash3 ; +} +print "# at the end\n"; diff --git a/bdb/perl/BerkeleyDB/t/mldbm.t b/bdb/perl/BerkeleyDB/t/mldbm.t new file mode 100644 index 00000000000..d35f7e15895 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/mldbm.t @@ -0,0 +1,161 @@ +#!/usr/bin/perl -w + +use strict ; + +BEGIN +{ + if ($] < 5.005) { + print "1..0 # This is Perl $], skipping test\n" ; + exit 0 ; + } + + eval { require Data::Dumper ; }; + if ($@) { + print "1..0 # Data::Dumper is not installed on this system.\n"; + exit 0 ; + } + if ($Data::Dumper::VERSION < 2.08) { + print "1..0 # Data::Dumper 2.08 or better required (found $Data::Dumper::VERSION).\n"; + exit 0 ; + } + eval { require MLDBM ; }; + if ($@) { + print "1..0 # MLDBM is not installed on this system.\n"; + exit 0 ; + } +} + +use t::util ; + +print "1..12\n"; + +{ + package BTREE ; + + use BerkeleyDB ; + use MLDBM qw(BerkeleyDB::Btree) ; + use Data::Dumper; + + my $filename = ""; + my $lex = new LexFile $filename; + + $MLDBM::UseDB = "BerkeleyDB::Btree" ; + my %o ; + my $db = tie %o, 'MLDBM', -Filename => $filename, + -Flags => DB_CREATE + or die $!; + ::ok 1, $db ; + ::ok 2, $db->type() == DB_BTREE ; + + my $c = [\'c']; + my $b = {}; + my $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + @o{qw(a b c)} = ($a, $b, $c); + $o{d} = "{once upon a time}"; + $o{e} = 1024; + $o{f} = 1024.1024; + my $first = Data::Dumper->new([@o{qw(a b c)}], [qw(a b c)])->Quotekeys(0)->Dump; + my $second = <<'EOT'; +$a = [ + 1, + { + a => $a, + b => $a->[1], + c => [ + \'c' + ] + }, + $a->[1]{c} + ]; +$b = { + a => [ + 1, + $b, + [ + \'c' + ] + ], + b => $b, + c => $b->{a}[2] + }; +$c = [ + \'c' + ]; +EOT + + ::ok 3, $first eq $second ; + ::ok 4, $o{d} eq "{once upon a time}" ; + ::ok 5, $o{e} == 1024 ; + ::ok 6, $o{f} eq 1024.1024 ; + +} + +{ + + package HASH ; + + use BerkeleyDB ; + use MLDBM qw(BerkeleyDB::Hash) ; + use Data::Dumper; + + my $filename = ""; + my $lex = new LexFile $filename; + + unlink $filename ; + $MLDBM::UseDB = "BerkeleyDB::Hash" ; + my %o ; + my $db = tie %o, 'MLDBM', -Filename => $filename, + -Flags => DB_CREATE + or die $!; + ::ok 7, $db ; + ::ok 8, $db->type() == DB_HASH ; + + + my $c = [\'c']; + my $b = {}; + my $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + @o{qw(a b c)} = ($a, $b, $c); + $o{d} = "{once upon a time}"; + $o{e} = 1024; + $o{f} = 1024.1024; + my $first = Data::Dumper->new([@o{qw(a b c)}], [qw(a b c)])->Quotekeys(0)->Dump; + my $second = <<'EOT'; +$a = [ + 1, + { + a => $a, + b => $a->[1], + c => [ + \'c' + ] + }, + $a->[1]{c} + ]; +$b = { + a => [ + 1, + $b, + [ + \'c' + ] + ], + b => $b, + c => $b->{a}[2] + }; +$c = [ + \'c' + ]; +EOT + + ::ok 9, $first eq $second ; + ::ok 10, $o{d} eq "{once upon a time}" ; + ::ok 11, $o{e} == 1024 ; + ::ok 12, $o{f} eq 1024.1024 ; + +} diff --git a/bdb/perl/BerkeleyDB/t/queue.t b/bdb/perl/BerkeleyDB/t/queue.t new file mode 100644 index 00000000000..86add129ca4 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/queue.t @@ -0,0 +1,763 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3.3) { + print "1..0 # Skipping test, Queue needs Berkeley DB 3.3.x or better\n" ; + exit 0 ; + } +} + +print "1..201\n"; + +sub fillout +{ + my $var = shift ; + my $length = shift ; + my $pad = shift || " " ; + my $template = $pad x $length ; + substr($template, 0, length($var)) = $var ; + return $template ; +} + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Queue -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) / ; + + eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to Queue + +{ + my $lex = new LexFile $Dfile ; + my $rec_len = 10 ; + my $pad = "x" ; + + ok 6, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -Flags => DB_CREATE, + -Len => $rec_len, + -Pad => $pad; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put(1, "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get(1, $value) == 0 ; + ok 10, $value eq fillout("some value", $rec_len, $pad) ; + ok 11, $db->db_put(2, "value") == 0 ; + ok 12, $db->db_get(2, $value) == 0 ; + ok 13, $value eq fillout("value", $rec_len, $pad) ; + ok 14, $db->db_del(1) == 0 ; + ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ; + ok 16, $db->status() == DB_KEYEMPTY ; + ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ; + + ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ; + ok 19, $db->status() == DB_NOTFOUND ; + ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ; + + ok 21, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ; + ok 24, $db->status() == DB_KEYEXIST ; + + + # check that the value of the key has not been changed by the + # previous test + ok 25, $db->db_get(2, $value) == 0 ; + ok 26, $value eq fillout("value", $rec_len, $pad) ; + + +} + + +{ + # Check simple env works with a array. + # and pad defaults to space + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + my $rec_len = 11 ; + ok 27, my $lexD = new LexDir($home); + + ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL, + -Home => $home ; + ok 29, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE, + -Len => $rec_len; + + # Add a k/v pair + my $value ; + ok 30, $db->db_put(1, "some value") == 0 ; + ok 31, $db->db_get(1, $value) == 0 ; + ok 32, $value eq fillout("some value", $rec_len) ; + undef $db ; + undef $env ; +} + + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my @array ; + my ($k, $v) ; + my $rec_len = 5 ; + ok 33, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Len => $rec_len; + + # create some data + my @data = ( + "red" , + "green" , + "blue" , + ) ; + + my $i ; + my %data ; + my $ret = 0 ; + for ($i = 0 ; $i < @data ; ++$i) { + $ret += $db->db_put($i, $data[$i]) ; + $data{$i} = $data[$i] ; + } + ok 34, $ret == 0 ; + + # create the cursor + ok 35, my $cursor = $db->db_cursor() ; + + $k = 0 ; $v = "" ; + my %copy = %data; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { + if ( fillout($copy{$k}, $rec_len) eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + + ok 36, $cursor->status() == DB_NOTFOUND ; + ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ; + ok 38, keys %copy == 0 ; + ok 39, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( fillout($copy{$k}, $rec_len) eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 40, $status == DB_NOTFOUND ; + ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 42, $cursor->status() == $status ; + ok 43, $cursor->status() eq $status ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; +} + +{ + # Tied Array interface + + my $lex = new LexFile $Dfile ; + my @array ; + my $db ; + my $rec_len = 10 ; + ok 46, $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Len => $rec_len; + + ok 47, my $cursor = (tied @array)->db_cursor() ; + # check the database is empty + my $count = 0 ; + my ($k, $v) = (0,"") ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 48, $cursor->status() == DB_NOTFOUND ; + ok 49, $count == 0 ; + + ok 50, @array == 0 ; + + # Add a k/v pair + my $value ; + $array[1] = "some value"; + ok 51, (tied @array)->status() == 0 ; + ok 52, $array[1] eq fillout("some value", $rec_len); + ok 53, defined $array[1]; + ok 54, (tied @array)->status() == 0 ; + ok 55, !defined $array[3]; + ok 56, (tied @array)->status() == DB_NOTFOUND ; + + ok 57, (tied @array)->db_del(1) == 0 ; + ok 58, (tied @array)->status() == 0 ; + ok 59, ! defined $array[1]; + ok 60, (tied @array)->status() == DB_KEYEMPTY ; + + $array[1] = 2 ; + $array[10] = 20 ; + $array[1000] = 2000 ; + + my ($keys, $values) = (0,0); + $count = 0 ; + for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_NEXT)) { + $keys += $k ; + $values += $v ; + ++ $count ; + } + ok 61, $count == 3 ; + ok 62, $keys == 1011 ; + ok 63, $values == 2022 ; + + # unshift isn't allowed +# eval { +# $FA ? unshift @array, "red", "green", "blue" +# : $db->unshift("red", "green", "blue" ) ; +# } ; +# ok 64, $@ =~ /^unshift is unsupported with Queue databases/ ; + $array[0] = "red" ; + $array[1] = "green" ; + $array[2] = "blue" ; + $array[4] = 2 ; + ok 64, $array[0] eq fillout("red", $rec_len) ; + ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ; + ok 66, $k == 0 ; + ok 67, $v eq fillout("red", $rec_len) ; + ok 68, $array[1] eq fillout("green", $rec_len) ; + ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ; + ok 70, $k == 1 ; + ok 71, $v eq fillout("green", $rec_len) ; + ok 72, $array[2] eq fillout("blue", $rec_len) ; + ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ; + ok 74, $k == 2 ; + ok 75, $v eq fillout("blue", $rec_len) ; + ok 76, $array[4] == 2 ; + ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ; + ok 78, $k == 4 ; + ok 79, $v == 2 ; + + # shift + ok 80, ($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len) ; + ok 81, ($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len) ; + ok 82, ($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len) ; + ok 83, ($FA ? shift @array : $db->shift()) == 2 ; + + # push + $FA ? push @array, "the", "end" + : $db->push("the", "end") ; + ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ; + ok 85, $k == 1002 ; + ok 86, $v eq fillout("end", $rec_len) ; + ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ; + ok 88, $k == 1001 ; + ok 89, $v eq fillout("the", $rec_len) ; + ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ; + ok 91, $k == 1000 ; + ok 92, $v == 2000 ; + + # pop + ok 93, ( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len) ; + ok 94, ( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len) ; + ok 95, ( $FA ? pop @array : $db->pop ) == 2000 ; + + # now clear the array + $FA ? @array = () + : $db->clear() ; + ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ; + + undef $cursor ; + undef $db ; + untie @array ; +} + +{ + # in-memory file + + my @array ; + my $fd ; + my $value ; + my $rec_len = 15 ; + ok 97, my $db = tie @array, 'BerkeleyDB::Queue', + -Len => $rec_len; + + ok 98, $db->db_put(1, "some value") == 0 ; + ok 99, $db->db_get(1, $value) == 0 ; + ok 100, $value eq fillout("some value", $rec_len) ; + +} + +{ + # partial + # check works via API + + my $lex = new LexFile $Dfile ; + my $value ; + my $rec_len = 8 ; + ok 101, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -Flags => DB_CREATE , + -Len => $rec_len, + -Pad => " " ; + + # create some data + my @data = ( + "", + "boat", + "house", + "sea", + ) ; + + my $ret = 0 ; + my $i ; + for ($i = 0 ; $i < @data ; ++$i) { + my $r = $db->db_put($i, $data[$i]) ; + $ret += $r ; + } + ok 102, $ret == 0 ; + + # do a partial get + my ($pon, $off, $len) = $db->partial_set(0,2) ; + ok 103, ! $pon && $off == 0 && $len == 0 ; + ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ; + ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ; + ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ; + + # do a partial get, off end of data + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 107, $pon ; + ok 108, $off == 0 ; + ok 109, $len == 2 ; + ok 110, $db->db_get(1, $value) == 0 && $value eq fillout("t", 2) ; + ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ; + ok 112, $db->db_get(3, $value) == 0 && $value eq " " ; + + # switch of partial mode + ($pon, $off, $len) = $db->partial_clear() ; + ok 113, $pon ; + ok 114, $off == 3 ; + ok 115, $len == 2 ; + ok 116, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ; + ok 117, $db->db_get(2, $value) == 0 && $value eq fillout("house", $rec_len) ; + ok 118, $db->db_get(3, $value) == 0 && $value eq fillout("sea", $rec_len) ; + + # now partial put + $db->partial_set(0,2) ; + ok 119, $db->db_put(1, "") != 0 ; + ok 120, $db->db_put(2, "AB") == 0 ; + ok 121, $db->db_put(3, "XY") == 0 ; + ok 122, $db->db_put(4, "KLM") != 0 ; + ok 123, $db->db_put(4, "KL") == 0 ; + + ($pon, $off, $len) = $db->partial_clear() ; + ok 124, $pon ; + ok 125, $off == 0 ; + ok 126, $len == 2 ; + ok 127, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ; + ok 128, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse", $rec_len) ; + ok 129, $db->db_get(3, $value) == 0 && $value eq fillout("XYa", $rec_len) ; + ok 130, $db->db_get(4, $value) == 0 && $value eq fillout("KL", $rec_len) ; + + # now partial put + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 131, ! $pon ; + ok 132, $off == 0 ; + ok 133, $len == 0 ; + ok 134, $db->db_put(1, "PP") == 0 ; + ok 135, $db->db_put(2, "Q") != 0 ; + ok 136, $db->db_put(3, "XY") == 0 ; + ok 137, $db->db_put(4, "TU") == 0 ; + + $db->partial_clear() ; + ok 138, $db->db_get(1, $value) == 0 && $value eq fillout("boaPP", $rec_len) ; + ok 139, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse",$rec_len) ; + ok 140, $db->db_get(3, $value) == 0 && $value eq fillout("XYaXY", $rec_len) ; + ok 141, $db->db_get(4, $value) == 0 && $value eq fillout("KL TU", $rec_len) ; +} + +{ + # partial + # check works via tied array + + my $lex = new LexFile $Dfile ; + my @array ; + my $value ; + my $rec_len = 8 ; + ok 142, my $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile, + -Flags => DB_CREATE , + -Len => $rec_len, + -Pad => " " ; + + # create some data + my @data = ( + "", + "boat", + "house", + "sea", + ) ; + + my $i ; + my $status = 0 ; + for ($i = 1 ; $i < @data ; ++$i) { + $array[$i] = $data[$i] ; + $status += $db->status() ; + } + + ok 143, $status == 0 ; + + # do a partial get + $db->partial_set(0,2) ; + ok 144, $array[1] eq fillout("bo", 2) ; + ok 145, $array[2] eq fillout("ho", 2) ; + ok 146, $array[3] eq fillout("se", 2) ; + + # do a partial get, off end of data + $db->partial_set(3,2) ; + ok 147, $array[1] eq fillout("t", 2) ; + ok 148, $array[2] eq fillout("se", 2) ; + ok 149, $array[3] eq fillout("", 2) ; + + # switch of partial mode + $db->partial_clear() ; + ok 150, $array[1] eq fillout("boat", $rec_len) ; + ok 151, $array[2] eq fillout("house", $rec_len) ; + ok 152, $array[3] eq fillout("sea", $rec_len) ; + + # now partial put + $db->partial_set(0,2) ; + $array[1] = "" ; + ok 153, $db->status() != 0 ; + $array[2] = "AB" ; + ok 154, $db->status() == 0 ; + $array[3] = "XY" ; + ok 155, $db->status() == 0 ; + $array[4] = "KL" ; + ok 156, $db->status() == 0 ; + + $db->partial_clear() ; + ok 157, $array[1] eq fillout("boat", $rec_len) ; + ok 158, $array[2] eq fillout("ABuse", $rec_len) ; + ok 159, $array[3] eq fillout("XYa", $rec_len) ; + ok 160, $array[4] eq fillout("KL", $rec_len) ; + + # now partial put + $db->partial_set(3,2) ; + $array[1] = "PP" ; + ok 161, $db->status() == 0 ; + $array[2] = "Q" ; + ok 162, $db->status() != 0 ; + $array[3] = "XY" ; + ok 163, $db->status() == 0 ; + $array[4] = "TU" ; + ok 164, $db->status() == 0 ; + + $db->partial_clear() ; + ok 165, $array[1] eq fillout("boaPP", $rec_len) ; + ok 166, $array[2] eq fillout("ABuse", $rec_len) ; + ok 167, $array[3] eq fillout("XYaXY", $rec_len) ; + ok 168, $array[4] eq fillout("KL TU", $rec_len) ; +} + +{ + # transaction + + my $lex = new LexFile $Dfile ; + my @array ; + my $value ; + + my $home = "./fred" ; + ok 169, my $lexD = new LexDir($home); + my $rec_len = 9 ; + ok 170, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 171, my $txn = $env->txn_begin() ; + ok 172, my $db1 = tie @array, 'BerkeleyDB::Queue', + -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn , + -Len => $rec_len, + -Pad => " " ; + + + ok 173, $txn->txn_commit() == 0 ; + ok 174, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my @data = ( + "boat", + "house", + "sea", + ) ; + + my $ret = 0 ; + my $i ; + for ($i = 0 ; $i < @data ; ++$i) { + $ret += $db1->db_put($i, $data[$i]) ; + } + ok 175, $ret == 0 ; + + # should be able to see all the records + + ok 176, my $cursor = $db1->db_cursor() ; + my ($k, $v) = (0, "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 177, $count == 3 ; + undef $cursor ; + + # now abort the transaction + ok 178, $txn->txn_abort() == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 179, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 180, $count == 0 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $env ; + untie @array ; +} + + +{ + # db_stat + + my $lex = new LexFile $Dfile ; + my $recs = ($BerkeleyDB::db_version >= 3.1 ? "qs_ndata" : "qs_nrecs") ; + my @array ; + my ($k, $v) ; + my $rec_len = 7 ; + ok 181, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -Flags => DB_CREATE, + -Pagesize => 4 * 1024, + -Len => $rec_len, + -Pad => " " + ; + + my $ref = $db->db_stat() ; + ok 182, $ref->{$recs} == 0; + ok 183, $ref->{'qs_pagesize'} == 4 * 1024; + + # create some data + my @data = ( + 2, + "house", + "sea", + ) ; + + my $ret = 0 ; + my $i ; + for ($i = $db->ArrayOffset ; @data ; ++$i) { + $ret += $db->db_put($i, shift @data) ; + } + ok 184, $ret == 0 ; + + $ref = $db->db_stat() ; + ok 185, $ref->{$recs} == 3; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use BerkeleyDB; + @ISA=qw(BerkeleyDB::Queue); + @EXPORT = @BerkeleyDB::EXPORT ; + + sub db_put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::db_put($key, $value * 3) ; + } + + sub db_get { + my $self = shift ; + $self->SUPER::db_get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok 186, $@ eq "" ; + my @h ; + my $X ; + my $rec_len = 34 ; + eval ' + $X = tie(@h, "SubDB", -Filename => "dbqueue.tmp", + -Flags => DB_CREATE, + -Mode => 0640 , + -Len => $rec_len, + -Pad => " " + ); + ' ; + + main::ok 187, $@ eq "" ; + + my $ret = eval '$h[1] = 3 ; return $h[1] ' ; + main::ok 188, $@ eq "" ; + main::ok 189, $ret == 7 ; + + my $value = 0; + $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ; + main::ok 190, $@ eq "" ; + main::ok 191, $ret == 10 ; + + $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; + main::ok 192, $@ eq "" ; + main::ok 193, $ret == 1 ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok 194, $@ eq "" ; + main::ok 195, $ret eq "[[10]]" ; + + undef $X ; + untie @h ; + unlink "SubDB.pm", "dbqueue.tmp" ; + +} + +{ + # DB_APPEND + + my $lex = new LexFile $Dfile; + my @array ; + my $value ; + my $rec_len = 21 ; + ok 196, my $db = tie @array, 'BerkeleyDB::Queue', + -Filename => $Dfile, + -Flags => DB_CREATE , + -Len => $rec_len, + -Pad => " " ; + + # create a few records + $array[1] = "def" ; + $array[3] = "ghi" ; + + my $k = 0 ; + ok 197, $db->db_put($k, "fred", DB_APPEND) == 0 ; + ok 198, $k == 4 ; + ok 199, $array[4] eq fillout("fred", $rec_len) ; + + undef $db ; + untie @array ; +} + +{ + # 23 Sept 2001 -- push into an empty array + my $lex = new LexFile $Dfile ; + my @array ; + my $db ; + my $rec_len = 21 ; + ok 200, $db = tie @array, 'BerkeleyDB::Queue', + -Flags => DB_CREATE , + -ArrayBase => 0, + -Len => $rec_len, + -Pad => " " , + -Filename => $Dfile ; + $FA ? push @array, "first" + : $db->push("first") ; + + ok 201, ($FA ? pop @array : $db->pop()) eq fillout("first", $rec_len) ; + + undef $db; + untie @array ; + +} + +__END__ + + +# TODO +# +# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records diff --git a/bdb/perl/BerkeleyDB/t/recno.t b/bdb/perl/BerkeleyDB/t/recno.t new file mode 100644 index 00000000000..64b1803f736 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/recno.t @@ -0,0 +1,913 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..226\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Recno -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Recno -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) / ; + + eval ' $db = new BerkeleyDB::Recno -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Recno -Txn => "x" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Recno -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to Recno + +{ + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put(1, "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get(1, $value) == 0 ; + ok 10, $value eq "some value" ; + ok 11, $db->db_put(2, "value") == 0 ; + ok 12, $db->db_get(2, $value) == 0 ; + ok 13, $value eq "value" ; + ok 14, $db->db_del(1) == 0 ; + ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ; + ok 16, $db->status() == DB_KEYEMPTY ; + ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ; + + ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ; + ok 19, $db->status() == DB_NOTFOUND ; + ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ; + + ok 21, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ; + ok 24, $db->status() == DB_KEYEXIST ; + + + # check that the value of the key has not been changed by the + # previous test + ok 25, $db->db_get(2, $value) == 0 ; + ok 26, $value eq "value" ; + + +} + + +{ + # Check simple env works with a array. + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + ok 27, my $lexD = new LexDir($home); + + ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL, + -Home => $home ; + + ok 29, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + ok 30, $db->db_put(1, "some value") == 0 ; + ok 31, $db->db_get(1, $value) == 0 ; + ok 32, $value eq "some value" ; + undef $db ; + undef $env ; +} + + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my @array ; + my ($k, $v) ; + ok 33, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE ; + + # create some data + my @data = ( + "red" , + "green" , + "blue" , + ) ; + + my $i ; + my %data ; + my $ret = 0 ; + for ($i = 0 ; $i < @data ; ++$i) { + $ret += $db->db_put($i, $data[$i]) ; + $data{$i} = $data[$i] ; + } + ok 34, $ret == 0 ; + + # create the cursor + ok 35, my $cursor = $db->db_cursor() ; + + $k = 0 ; $v = "" ; + my %copy = %data; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + + ok 36, $cursor->status() == DB_NOTFOUND ; + ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ; + ok 38, keys %copy == 0 ; + ok 39, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 40, $status == DB_NOTFOUND ; + ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 42, $cursor->status() == $status ; + ok 43, $cursor->status() eq $status ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; +} + +{ + # Tied Array interface + + + my $lex = new LexFile $Dfile ; + my @array ; + my $db ; + ok 46, $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile, + -Property => DB_RENUMBER, + -ArrayBase => 0, + -Flags => DB_CREATE ; + + ok 47, my $cursor = (tied @array)->db_cursor() ; + # check the database is empty + my $count = 0 ; + my ($k, $v) = (0,"") ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 48, $cursor->status() == DB_NOTFOUND ; + ok 49, $count == 0 ; + + ok 50, @array == 0 ; + + # Add a k/v pair + my $value ; + $array[1] = "some value"; + ok 51, (tied @array)->status() == 0 ; + ok 52, $array[1] eq "some value"; + ok 53, defined $array[1]; + ok 54, (tied @array)->status() == 0 ; + ok 55, !defined $array[3]; + ok 56, (tied @array)->status() == DB_NOTFOUND ; + + ok 57, (tied @array)->db_del(1) == 0 ; + ok 58, (tied @array)->status() == 0 ; + ok 59, ! defined $array[1]; + ok 60, (tied @array)->status() == DB_NOTFOUND ; + + $array[1] = 2 ; + $array[10] = 20 ; + $array[1000] = 2000 ; + + my ($keys, $values) = (0,0); + $count = 0 ; + for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_NEXT)) { + $keys += $k ; + $values += $v ; + ++ $count ; + } + ok 61, $count == 3 ; + ok 62, $keys == 1011 ; + ok 63, $values == 2022 ; + + # unshift + $FA ? unshift @array, "red", "green", "blue" + : $db->unshift("red", "green", "blue" ) ; + ok 64, $array[1] eq "red" ; + ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ; + ok 66, $k == 1 ; + ok 67, $v eq "red" ; + ok 68, $array[2] eq "green" ; + ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ; + ok 70, $k == 2 ; + ok 71, $v eq "green" ; + ok 72, $array[3] eq "blue" ; + ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ; + ok 74, $k == 3 ; + ok 75, $v eq "blue" ; + ok 76, $array[4] == 2 ; + ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ; + ok 78, $k == 4 ; + ok 79, $v == 2 ; + + # shift + ok 80, ($FA ? shift @array : $db->shift()) eq "red" ; + ok 81, ($FA ? shift @array : $db->shift()) eq "green" ; + ok 82, ($FA ? shift @array : $db->shift()) eq "blue" ; + ok 83, ($FA ? shift @array : $db->shift()) == 2 ; + + # push + $FA ? push @array, "the", "end" + : $db->push("the", "end") ; + ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ; + ok 85, $k == 1001 ; + ok 86, $v eq "end" ; + ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ; + ok 88, $k == 1000 ; + ok 89, $v eq "the" ; + ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ; + ok 91, $k == 999 ; + ok 92, $v == 2000 ; + + # pop + ok 93, ( $FA ? pop @array : $db->pop ) eq "end" ; + ok 94, ( $FA ? pop @array : $db->pop ) eq "the" ; + ok 95, ( $FA ? pop @array : $db->pop ) == 2000 ; + + # now clear the array + $FA ? @array = () + : $db->clear() ; + ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ; + + undef $cursor ; + undef $db ; + untie @array ; +} + +{ + # in-memory file + + my @array ; + my $fd ; + my $value ; + ok 97, my $db = tie @array, 'BerkeleyDB::Recno' ; + + ok 98, $db->db_put(1, "some value") == 0 ; + ok 99, $db->db_get(1, $value) == 0 ; + ok 100, $value eq "some value" ; + +} + +{ + # partial + # check works via API + + my $lex = new LexFile $Dfile ; + my $value ; + ok 101, my $db = new BerkeleyDB::Recno, -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my @data = ( + "", + "boat", + "house", + "sea", + ) ; + + my $ret = 0 ; + my $i ; + for ($i = 1 ; $i < @data ; ++$i) { + $ret += $db->db_put($i, $data[$i]) ; + } + ok 102, $ret == 0 ; + + + # do a partial get + my ($pon, $off, $len) = $db->partial_set(0,2) ; + ok 103, ! $pon && $off == 0 && $len == 0 ; + ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ; + ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ; + ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ; + + # do a partial get, off end of data + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 107, $pon ; + ok 108, $off == 0 ; + ok 109, $len == 2 ; + ok 110, $db->db_get(1, $value) == 0 && $value eq "t" ; + ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ; + ok 112, $db->db_get(3, $value) == 0 && $value eq "" ; + + # switch of partial mode + ($pon, $off, $len) = $db->partial_clear() ; + ok 113, $pon ; + ok 114, $off == 3 ; + ok 115, $len == 2 ; + ok 116, $db->db_get(1, $value) == 0 && $value eq "boat" ; + ok 117, $db->db_get(2, $value) == 0 && $value eq "house" ; + ok 118, $db->db_get(3, $value) == 0 && $value eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 119, $db->db_put(1, "") == 0 ; + ok 120, $db->db_put(2, "AB") == 0 ; + ok 121, $db->db_put(3, "XYZ") == 0 ; + ok 122, $db->db_put(4, "KLM") == 0 ; + + ($pon, $off, $len) = $db->partial_clear() ; + ok 123, $pon ; + ok 124, $off == 0 ; + ok 125, $len == 2 ; + ok 126, $db->db_get(1, $value) == 0 && $value eq "at" ; + ok 127, $db->db_get(2, $value) == 0 && $value eq "ABuse" ; + ok 128, $db->db_get(3, $value) == 0 && $value eq "XYZa" ; + ok 129, $db->db_get(4, $value) == 0 && $value eq "KLM" ; + + # now partial put + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 130, ! $pon ; + ok 131, $off == 0 ; + ok 132, $len == 0 ; + ok 133, $db->db_put(1, "PPP") == 0 ; + ok 134, $db->db_put(2, "Q") == 0 ; + ok 135, $db->db_put(3, "XYZ") == 0 ; + ok 136, $db->db_put(4, "TU") == 0 ; + + $db->partial_clear() ; + ok 137, $db->db_get(1, $value) == 0 && $value eq "at\0PPP" ; + ok 138, $db->db_get(2, $value) == 0 && $value eq "ABuQ" ; + ok 139, $db->db_get(3, $value) == 0 && $value eq "XYZXYZ" ; + ok 140, $db->db_get(4, $value) == 0 && $value eq "KLMTU" ; +} + +{ + # partial + # check works via tied array + + my $lex = new LexFile $Dfile ; + my @array ; + my $value ; + ok 141, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my @data = ( + "", + "boat", + "house", + "sea", + ) ; + + my $i ; + for ($i = 1 ; $i < @data ; ++$i) { + $array[$i] = $data[$i] ; + } + + + # do a partial get + $db->partial_set(0,2) ; + ok 142, $array[1] eq "bo" ; + ok 143, $array[2] eq "ho" ; + ok 144, $array[3] eq "se" ; + + # do a partial get, off end of data + $db->partial_set(3,2) ; + ok 145, $array[1] eq "t" ; + ok 146, $array[2] eq "se" ; + ok 147, $array[3] eq "" ; + + # switch of partial mode + $db->partial_clear() ; + ok 148, $array[1] eq "boat" ; + ok 149, $array[2] eq "house" ; + ok 150, $array[3] eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 151, $array[1] = "" ; + ok 152, $array[2] = "AB" ; + ok 153, $array[3] = "XYZ" ; + ok 154, $array[4] = "KLM" ; + + $db->partial_clear() ; + ok 155, $array[1] eq "at" ; + ok 156, $array[2] eq "ABuse" ; + ok 157, $array[3] eq "XYZa" ; + ok 158, $array[4] eq "KLM" ; + + # now partial put + $db->partial_set(3,2) ; + ok 159, $array[1] = "PPP" ; + ok 160, $array[2] = "Q" ; + ok 161, $array[3] = "XYZ" ; + ok 162, $array[4] = "TU" ; + + $db->partial_clear() ; + ok 163, $array[1] eq "at\0PPP" ; + ok 164, $array[2] eq "ABuQ" ; + ok 165, $array[3] eq "XYZXYZ" ; + ok 166, $array[4] eq "KLMTU" ; +} + +{ + # transaction + + my $lex = new LexFile $Dfile ; + my @array ; + my $value ; + + my $home = "./fred" ; + ok 167, my $lexD = new LexDir($home); + ok 168, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 169, my $txn = $env->txn_begin() ; + ok 170, my $db1 = tie @array, 'BerkeleyDB::Recno', + -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + ok 171, $txn->txn_commit() == 0 ; + ok 172, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my @data = ( + "boat", + "house", + "sea", + ) ; + + my $ret = 0 ; + my $i ; + for ($i = 0 ; $i < @data ; ++$i) { + $ret += $db1->db_put($i, $data[$i]) ; + } + ok 173, $ret == 0 ; + + # should be able to see all the records + + ok 174, my $cursor = $db1->db_cursor() ; + my ($k, $v) = (0, "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 175, $count == 3 ; + undef $cursor ; + + # now abort the transaction + ok 176, $txn->txn_abort() == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 177, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 178, $count == 0 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $env ; + untie @array ; +} + + +{ + # db_stat + + my $lex = new LexFile $Dfile ; + my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ; + my @array ; + my ($k, $v) ; + ok 179, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -Flags => DB_CREATE, + -Pagesize => 4 * 1024, + ; + + my $ref = $db->db_stat() ; + ok 180, $ref->{$recs} == 0; + ok 181, $ref->{'bt_pagesize'} == 4 * 1024; + + # create some data + my @data = ( + 2, + "house", + "sea", + ) ; + + my $ret = 0 ; + my $i ; + for ($i = $db->ArrayOffset ; @data ; ++$i) { + $ret += $db->db_put($i, shift @data) ; + } + ok 182, $ret == 0 ; + + $ref = $db->db_stat() ; + ok 183, $ref->{$recs} == 3; +} + +{ + # sub-class test + + package Another ; + + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use BerkeleyDB; + @ISA=qw(BerkeleyDB::Recno); + @EXPORT = @BerkeleyDB::EXPORT ; + + sub db_put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::db_put($key, $value * 3) ; + } + + sub db_get { + my $self = shift ; + $self->SUPER::db_get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok 184, $@ eq "" ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB", -Filename => "dbrecno.tmp", + -Flags => DB_CREATE, + -Mode => 0640 ); + ' ; + + main::ok 185, $@ eq "" ; + + my $ret = eval '$h[1] = 3 ; return $h[1] ' ; + main::ok 186, $@ eq "" ; + main::ok 187, $ret == 7 ; + + my $value = 0; + $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ; + main::ok 188, $@ eq "" ; + main::ok 189, $ret == 10 ; + + $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; + main::ok 190, $@ eq "" ; + main::ok 191, $ret == 1 ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok 192, $@ eq "" ; + main::ok 193, $ret eq "[[10]]" ; + + undef $X; + untie @h; + unlink "SubDB.pm", "dbrecno.tmp" ; + +} + +{ + # variable length records, DB_DELIMETER -- defaults to \n + + my $lex = new LexFile $Dfile, $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 194, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Source => $Dfile2 ; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 195, $x eq "abc\ndef\n\nghi\n" ; +} + +{ + # variable length records, change DB_DELIMETER + + my $lex = new LexFile $Dfile, $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 196, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Source => $Dfile2 , + -Delim => "-"; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 197, $x eq "abc-def--ghi-"; +} + +{ + # fixed length records, default DB_PAD + + my $lex = new LexFile $Dfile, $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 198, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Len => 5, + -Source => $Dfile2 ; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 199, $x eq "abc def ghi " ; +} + +{ + # fixed length records, change Pad + + my $lex = new LexFile $Dfile, $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 200, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Len => 5, + -Pad => "-", + -Source => $Dfile2 ; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 201, $x eq "abc--def-------ghi--" ; +} + +{ + # DB_RENUMBER + + my $lex = new LexFile $Dfile; + my @array ; + my $value ; + ok 202, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile, + -Property => DB_RENUMBER, + -ArrayBase => 0, + -Flags => DB_CREATE ; + # create a few records + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + + ok 203, my ($length, $joined) = joiner($db, "|") ; + ok 204, $length == 3 ; + ok 205, $joined eq "abc|def|ghi"; + + ok 206, $db->db_del(1) == 0 ; + ok 207, ($length, $joined) = joiner($db, "|") ; + ok 208, $length == 2 ; + ok 209, $joined eq "abc|ghi"; + + undef $db ; + untie @array ; + +} + +{ + # DB_APPEND + + my $lex = new LexFile $Dfile; + my @array ; + my $value ; + ok 210, my $db = tie @array, 'BerkeleyDB::Recno', + -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create a few records + $array[1] = "def" ; + $array[3] = "ghi" ; + + my $k = 0 ; + ok 211, $db->db_put($k, "fred", DB_APPEND) == 0 ; + ok 212, $k == 4 ; + + undef $db ; + untie @array ; +} + +{ + # in-memory Btree with an associated text file + + my $lex = new LexFile $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 213, tie @array, 'BerkeleyDB::Recno', -Source => $Dfile2 , + -ArrayBase => 0, + -Property => DB_RENUMBER, + -Flags => DB_CREATE ; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 214, $x eq "abc\ndef\n\nghi\n" ; +} + +{ + # in-memory, variable length records, change DB_DELIMETER + + my $lex = new LexFile $Dfile, $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 215, tie @array, 'BerkeleyDB::Recno', + -ArrayBase => 0, + -Flags => DB_CREATE , + -Source => $Dfile2 , + -Property => DB_RENUMBER, + -Delim => "-"; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 216, $x eq "abc-def--ghi-"; +} + +{ + # in-memory, fixed length records, default DB_PAD + + my $lex = new LexFile $Dfile, $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 217, tie @array, 'BerkeleyDB::Recno', -ArrayBase => 0, + -Flags => DB_CREATE , + -Property => DB_RENUMBER, + -Len => 5, + -Source => $Dfile2 ; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 218, $x eq "abc def ghi " ; +} + +{ + # in-memory, fixed length records, change Pad + + my $lex = new LexFile $Dfile, $Dfile2 ; + touch $Dfile2 ; + my @array ; + my $value ; + ok 219, tie @array, 'BerkeleyDB::Recno', + -ArrayBase => 0, + -Flags => DB_CREATE , + -Property => DB_RENUMBER, + -Len => 5, + -Pad => "-", + -Source => $Dfile2 ; + $array[0] = "abc" ; + $array[1] = "def" ; + $array[3] = "ghi" ; + untie @array ; + + my $x = docat($Dfile2) ; + ok 220, $x eq "abc--def-------ghi--" ; +} + +{ + # 23 Sept 2001 -- push into an empty array + my $lex = new LexFile $Dfile ; + my @array ; + my $db ; + ok 221, $db = tie @array, 'BerkeleyDB::Recno', + -ArrayBase => 0, + -Flags => DB_CREATE , + -Property => DB_RENUMBER, + -Filename => $Dfile ; + $FA ? push @array, "first" + : $db->push("first") ; + + ok 222, $array[0] eq "first" ; + ok 223, $FA ? pop @array : $db->pop() eq "first" ; + + undef $db; + untie @array ; + +} + +{ + # 23 Sept 2001 -- unshift into an empty array + my $lex = new LexFile $Dfile ; + my @array ; + my $db ; + ok 224, $db = tie @array, 'BerkeleyDB::Recno', + -ArrayBase => 0, + -Flags => DB_CREATE , + -Property => DB_RENUMBER, + -Filename => $Dfile ; + $FA ? unshift @array, "first" + : $db->unshift("first") ; + + ok 225, $array[0] eq "first" ; + ok 226, ($FA ? shift @array : $db->shift()) eq "first" ; + + undef $db; + untie @array ; + +} +__END__ + + +# TODO +# +# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records diff --git a/bdb/perl/BerkeleyDB/t/strict.t b/bdb/perl/BerkeleyDB/t/strict.t new file mode 100644 index 00000000000..ab41d44cb41 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/strict.t @@ -0,0 +1,174 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..44\n"; + +my $Dfile = "dbhash.tmp"; +my $home = "./fred" ; + +umask(0); + +{ + # closing a database & an environment in the correct order. + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + + ok 1, my $lexD = new LexDir($home); + ok 2, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 3, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env; + + ok 4, $db1->db_close() == 0 ; + + eval { $status = $env->db_appexit() ; } ; + ok 5, $status == 0 ; + ok 6, $@ eq "" ; + #print "[$@]\n" ; + +} + +{ + # closing an environment with an open database + my $lex = new LexFile $Dfile ; + my %hash ; + + ok 7, my $lexD = new LexDir($home); + ok 8, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 9, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env; + + eval { $env->db_appexit() ; } ; + ok 10, $@ =~ /BerkeleyDB Aborting: attempted to close an environment with 1 open database/ ; + #print "[$@]\n" ; + + undef $db1 ; + untie %hash ; + undef $env ; +} + +{ + # closing a transaction & a database + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + + ok 11, my $lexD = new LexDir($home); + ok 12, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 13, my $txn = $env->txn_begin() ; + ok 14, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + ok 15, $txn->txn_commit() == 0 ; + eval { $status = $db->db_close() ; } ; + ok 16, $status == 0 ; + ok 17, $@ eq "" ; + #print "[$@]\n" ; + eval { $status = $env->db_appexit() ; } ; + ok 18, $status == 0 ; + ok 19, $@ eq "" ; + #print "[$@]\n" ; +} + +{ + # closing a database with an open transaction + my $lex = new LexFile $Dfile ; + my %hash ; + + ok 20, my $lexD = new LexDir($home); + ok 21, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 22, my $txn = $env->txn_begin() ; + ok 23, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + eval { $db->db_close() ; } ; + ok 24, $@ =~ /BerkeleyDB Aborting: attempted to close a database while a transaction was still open at/ ; + #print "[$@]\n" ; +} + +{ + # closing a cursor & a database + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + ok 25, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + ok 26, my $cursor = $db->db_cursor() ; + ok 27, $cursor->c_close() == 0 ; + eval { $status = $db->db_close() ; } ; + ok 28, $status == 0 ; + ok 29, $@ eq "" ; + #print "[$@]\n" ; +} + +{ + # closing a database with an open cursor + my $lex = new LexFile $Dfile ; + my %hash ; + ok 30, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + ok 31, my $cursor = $db->db_cursor() ; + eval { $db->db_close() ; } ; + ok 32, $@ =~ /\QBerkeleyDB Aborting: attempted to close a database with 1 open cursor(s) at/; + #print "[$@]\n" ; +} + +{ + # closing a transaction & a cursor + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + + ok 33, my $lexD = new LexDir($home); + ok 34, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 35, my $txn = $env->txn_begin() ; + ok 36, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + ok 37, my $cursor = $db->db_cursor() ; + eval { $status = $cursor->c_close() ; } ; + ok 38, $status == 0 ; + ok 39, ($status = $txn->txn_commit()) == 0 ; + ok 40, $@ eq "" ; + eval { $status = $db->db_close() ; } ; + ok 41, $status == 0 ; + ok 42, $@ eq "" ; + #print "[$@]\n" ; + eval { $status = $env->db_appexit() ; } ; + ok 43, $status == 0 ; + ok 44, $@ eq "" ; + #print "[$@]\n" ; +} + diff --git a/bdb/perl/BerkeleyDB/t/subdb.t b/bdb/perl/BerkeleyDB/t/subdb.t new file mode 100644 index 00000000000..23016d6463f --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/subdb.t @@ -0,0 +1,243 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3) { + print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ; + exit 0 ; + } +} + +print "1..43\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +# Berkeley DB 3.x specific functionality + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' BerkeleyDB::db_remove -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' BerkeleyDB::db_remove -Bad => 2, -Filename => "fred", -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' BerkeleyDB::db_remove -Filename => "a", -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' BerkeleyDB::db_remove -Subname => "a"' ; + ok 4, $@ =~ /^Must specify a filename/ ; + + my $obj = bless [], "main" ; + eval ' BerkeleyDB::db_remove -Filename => "x", -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +{ + # subdatabases + + # opening a subdatabse in an exsiting database that doesn't have + # subdatabases at all should fail + + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 7, addData($db, %data) ; + + undef $db ; + + $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" ; + ok 8, ! $db ; + + ok 9, -e $Dfile ; + ok 10, ! BerkeleyDB::db_remove(-Filename => $Dfile) ; +} + +{ + # subdatabases + + # opening a subdatabse in an exsiting database that does have + # subdatabases at all, but not this one + + my $lex = new LexFile $Dfile ; + + ok 11, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" , + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 12, addData($db, %data) ; + + undef $db ; + + $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "joe" ; + + ok 13, !$db ; + +} + +{ + # subdatabases + + my $lex = new LexFile $Dfile ; + + ok 14, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" , + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 15, addData($db, %data) ; + + undef $db ; + + ok 16, $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" ; + + ok 17, my $cursor = $db->db_cursor() ; + my ($k, $v) = ("", "") ; + my $status ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + if ($data{$k} eq $v) { + delete $data{$k} ; + } + } + ok 18, $status == DB_NOTFOUND ; + ok 19, keys %data == 0 ; +} + +{ + # subdatabases + + # opening a database with multiple subdatabases - handle should be a list + # of the subdatabase names + + my $lex = new LexFile $Dfile ; + + ok 20, my $db1 = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" , + -Flags => DB_CREATE ; + + ok 21, my $db2 = new BerkeleyDB::Btree -Filename => $Dfile, + -Subname => "joe" , + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 22, addData($db1, %data) ; + ok 23, addData($db2, %data) ; + + undef $db1 ; + undef $db2 ; + + ok 24, my $db = new BerkeleyDB::Unknown -Filename => $Dfile , + -Flags => DB_RDONLY ; + + #my $type = $db->type() ; print "type $type\n" ; + ok 25, my $cursor = $db->db_cursor() ; + my ($k, $v) = ("", "") ; + my $status ; + my @dbnames = () ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + push @dbnames, $k ; + } + ok 26, $status == DB_NOTFOUND ; + ok 27, join(",", sort @dbnames) eq "fred,joe" ; + undef $db ; + + ok 28, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "harry") != 0; + ok 29, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") == 0 ; + + # should only be one subdatabase + ok 30, $db = new BerkeleyDB::Unknown -Filename => $Dfile , + -Flags => DB_RDONLY ; + + ok 31, $cursor = $db->db_cursor() ; + @dbnames = () ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + push @dbnames, $k ; + } + ok 32, $status == DB_NOTFOUND ; + ok 33, join(",", sort @dbnames) eq "joe" ; + undef $db ; + + # can't delete an already deleted subdatabase + ok 34, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") != 0; + + ok 35, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "joe") == 0 ; + + # should only be one subdatabase + ok 36, $db = new BerkeleyDB::Unknown -Filename => $Dfile , + -Flags => DB_RDONLY ; + + ok 37, $cursor = $db->db_cursor() ; + @dbnames = () ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + push @dbnames, $k ; + } + ok 38, $status == DB_NOTFOUND ; + ok 39, @dbnames == 0 ; + undef $db ; + undef $cursor ; + + ok 40, -e $Dfile ; + ok 41, BerkeleyDB::db_remove(-Filename => $Dfile) == 0 ; + ok 42, ! -e $Dfile ; + ok 43, BerkeleyDB::db_remove(-Filename => $Dfile) != 0 ; +} + +# db_remove with env diff --git a/bdb/perl/BerkeleyDB/t/txn.t b/bdb/perl/BerkeleyDB/t/txn.t new file mode 100644 index 00000000000..ba6b636cdc8 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/txn.t @@ -0,0 +1,320 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..58\n"; + +my $Dfile = "dbhash.tmp"; + +umask(0); + +{ + # error cases + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 1, my $lexD = new LexDir($home); + ok 2, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE| DB_INIT_MPOOL; + eval { $env->txn_begin() ; } ; + ok 3, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ; + + eval { my $txn_mgr = $env->TxnMgr() ; } ; + ok 4, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ; + undef $env ; + +} + +{ + # transaction - abort works + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 5, my $lexD = new LexDir($home); + ok 6, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 7, my $txn = $env->txn_begin() ; + ok 8, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + ok 9, $txn->txn_commit() == 0 ; + ok 10, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db1->db_put($k, $v) ; + } + ok 11, $ret == 0 ; + + # should be able to see all the records + + ok 12, my $cursor = $db1->db_cursor() ; + my ($k, $v) = ("", "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 13, $count == 3 ; + undef $cursor ; + + # now abort the transaction + ok 14, $txn->txn_abort() == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 15, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 16, $count == 0 ; + + my $stat = $env->txn_stat() ; + ok 17, $stat->{'st_naborts'} == 1 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $env ; + untie %hash ; +} + +{ + # transaction - abort works via txnmgr + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 18, my $lexD = new LexDir($home); + ok 19, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 20, my $txn_mgr = $env->TxnMgr() ; + ok 21, my $txn = $txn_mgr->txn_begin() ; + ok 22, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + ok 23, $txn->txn_commit() == 0 ; + ok 24, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db1->db_put($k, $v) ; + } + ok 25, $ret == 0 ; + + # should be able to see all the records + + ok 26, my $cursor = $db1->db_cursor() ; + my ($k, $v) = ("", "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 27, $count == 3 ; + undef $cursor ; + + # now abort the transaction + ok 28, $txn->txn_abort() == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 29, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 30, $count == 0 ; + + my $stat = $txn_mgr->txn_stat() ; + ok 31, $stat->{'st_naborts'} == 1 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $txn_mgr ; + undef $env ; + untie %hash ; +} + +{ + # transaction - commit works + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 32, my $lexD = new LexDir($home); + ok 33, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 34, my $txn = $env->txn_begin() ; + ok 35, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + ok 36, $txn->txn_commit() == 0 ; + ok 37, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db1->db_put($k, $v) ; + } + ok 38, $ret == 0 ; + + # should be able to see all the records + + ok 39, my $cursor = $db1->db_cursor() ; + my ($k, $v) = ("", "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 40, $count == 3 ; + undef $cursor ; + + # now commit the transaction + ok 41, $txn->txn_commit() == 0 ; + + $count = 0 ; + # sequence forwards + ok 42, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 43, $count == 3 ; + + my $stat = $env->txn_stat() ; + ok 44, $stat->{'st_naborts'} == 0 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $env ; + untie %hash ; +} + +{ + # transaction - commit works via txnmgr + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 45, my $lexD = new LexDir($home); + ok 46, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 47, my $txn_mgr = $env->TxnMgr() ; + ok 48, my $txn = $txn_mgr->txn_begin() ; + ok 49, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + ok 50, $txn->txn_commit() == 0 ; + ok 51, $txn = $env->txn_begin() ; + $db1->Txn($txn); + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db1->db_put($k, $v) ; + } + ok 52, $ret == 0 ; + + # should be able to see all the records + + ok 53, my $cursor = $db1->db_cursor() ; + my ($k, $v) = ("", "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 54, $count == 3 ; + undef $cursor ; + + # now commit the transaction + ok 55, $txn->txn_commit() == 0 ; + + $count = 0 ; + # sequence forwards + ok 56, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 57, $count == 3 ; + + my $stat = $txn_mgr->txn_stat() ; + ok 58, $stat->{'st_naborts'} == 0 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $txn_mgr ; + undef $env ; + untie %hash ; +} + diff --git a/bdb/perl/BerkeleyDB/t/unknown.t b/bdb/perl/BerkeleyDB/t/unknown.t new file mode 100644 index 00000000000..f2630b585c0 --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/unknown.t @@ -0,0 +1,176 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..41\n"; + +my $Dfile = "dbhash.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Unknown -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Unknown -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $db = new BerkeleyDB::Unknown -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Unknown -Txn => "fred" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Unknown -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# check the interface to a rubbish database +{ + # first an empty file + my $lex = new LexFile $Dfile ; + ok 6, writeFile($Dfile, "") ; + + ok 7, ! (new BerkeleyDB::Unknown -Filename => $Dfile); + + # now a non-database file + writeFile($Dfile, "\x2af6") ; + ok 8, ! (new BerkeleyDB::Unknown -Filename => $Dfile); +} + +# check the interface to a Hash database + +{ + my $lex = new LexFile $Dfile ; + + # create a hash database + ok 9, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a few k/v pairs + my $value ; + my $status ; + ok 10, $db->db_put("some key", "some value") == 0 ; + ok 11, $db->db_put("key", "value") == 0 ; + + # close the database + undef $db ; + + # now open it with Unknown + ok 12, $db = new BerkeleyDB::Unknown -Filename => $Dfile; + + ok 13, $db->type() == DB_HASH ; + ok 14, $db->db_get("some key", $value) == 0 ; + ok 15, $value eq "some value" ; + ok 16, $db->db_get("key", $value) == 0 ; + ok 17, $value eq "value" ; + + my @array ; + eval { $db->Tie(\@array)} ; + ok 18, $@ =~ /^Tie needs a reference to a hash/ ; + + my %hash ; + $db->Tie(\%hash) ; + ok 19, $hash{"some key"} eq "some value" ; + +} + +# check the interface to a Btree database + +{ + my $lex = new LexFile $Dfile ; + + # create a hash database + ok 20, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a few k/v pairs + my $value ; + my $status ; + ok 21, $db->db_put("some key", "some value") == 0 ; + ok 22, $db->db_put("key", "value") == 0 ; + + # close the database + undef $db ; + + # now open it with Unknown + # create a hash database + ok 23, $db = new BerkeleyDB::Unknown -Filename => $Dfile; + + ok 24, $db->type() == DB_BTREE ; + ok 25, $db->db_get("some key", $value) == 0 ; + ok 26, $value eq "some value" ; + ok 27, $db->db_get("key", $value) == 0 ; + ok 28, $value eq "value" ; + + + my @array ; + eval { $db->Tie(\@array)} ; + ok 29, $@ =~ /^Tie needs a reference to a hash/ ; + + my %hash ; + $db->Tie(\%hash) ; + ok 30, $hash{"some key"} eq "some value" ; + + +} + +# check the interface to a Recno database + +{ + my $lex = new LexFile $Dfile ; + + # create a recno database + ok 31, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a few k/v pairs + my $value ; + my $status ; + ok 32, $db->db_put(0, "some value") == 0 ; + ok 33, $db->db_put(1, "value") == 0 ; + + # close the database + undef $db ; + + # now open it with Unknown + # create a hash database + ok 34, $db = new BerkeleyDB::Unknown -Filename => $Dfile; + + ok 35, $db->type() == DB_RECNO ; + ok 36, $db->db_get(0, $value) == 0 ; + ok 37, $value eq "some value" ; + ok 38, $db->db_get(1, $value) == 0 ; + ok 39, $value eq "value" ; + + + my %hash ; + eval { $db->Tie(\%hash)} ; + ok 40, $@ =~ /^Tie needs a reference to an array/ ; + + my @array ; + $db->Tie(\@array) ; + ok 41, $array[1] eq "value" ; + + +} + +# check i/f to text diff --git a/bdb/perl/BerkeleyDB/t/util.pm b/bdb/perl/BerkeleyDB/t/util.pm new file mode 100644 index 00000000000..1a1449751eb --- /dev/null +++ b/bdb/perl/BerkeleyDB/t/util.pm @@ -0,0 +1,220 @@ +package util ; + +package main ; + +use strict ; +use BerkeleyDB ; +use File::Path qw(rmtree); +use vars qw(%DB_errors $FA) ; + +$| = 1; + +%DB_errors = ( + 'DB_INCOMPLETE' => "DB_INCOMPLETE: Sync was unable to complete", + 'DB_KEYEMPTY' => "DB_KEYEMPTY: Non-existent key/data pair", + 'DB_KEYEXIST' => "DB_KEYEXIST: Key/data pair already exists", + 'DB_LOCK_DEADLOCK' => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock", + 'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted", + 'DB_NOTFOUND' => "DB_NOTFOUND: No matching key/data pair found", + 'DB_OLD_VERSION' => "DB_OLDVERSION: Database requires a version upgrade", + 'DB_RUNRECOVERY' => "DB_RUNRECOVERY: Fatal error, run database recovery", +) ; + +# full tied array support started in Perl 5.004_57 +# just double check. +$FA = 0 ; +{ + sub try::TIEARRAY { bless [], "try" } + sub try::FETCHSIZE { $FA = 1 } + my @a ; + tie @a, 'try' ; + my $a = @a ; +} + +{ + package LexFile ; + + use vars qw( $basename @files ) ; + $basename = "db0000" ; + + sub new + { + my $self = shift ; + #my @files = () ; + foreach (@_) + { + $_ = $basename ; + unlink $basename ; + push @files, $basename ; + ++ $basename ; + } + bless [ @files ], $self ; + } + + sub DESTROY + { + my $self = shift ; + #unlink @{ $self } ; + } + + END + { + foreach (@files) { unlink $_ } + } +} + + +{ + package LexDir ; + + use File::Path qw(rmtree); + + use vars qw( $basename %dirs ) ; + + sub new + { + my $self = shift ; + my $dir = shift ; + + rmtree $dir if -e $dir ; + + mkdir $dir, 0777 or return undef ; + + return bless [ $dir ], $self ; + } + + sub DESTROY + { + my $self = shift ; + my $dir = $self->[0]; + #rmtree $dir; + $dirs{$dir} ++ ; + } + + END + { + foreach (keys %dirs) { + rmtree $_ if -d $_ ; + } + } + +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + return $result; +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT> || "" ; + close(CAT); + unlink $file ; + return $result; +} + +sub writeFile +{ + my $name = shift ; + open(FH, ">$name") or return 0 ; + print FH @_ ; + close FH ; + return 1 ; +} + +sub touch +{ + my $file = shift ; + open(CAT,">$file") || die "Cannot open $file:$!"; + close(CAT); +} + +sub joiner +{ + my $db = shift ; + my $sep = shift ; + my ($k, $v) = (0, "") ; + my @data = () ; + + my $cursor = $db->db_cursor() or return () ; + for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_NEXT)) { + push @data, $v ; + } + + (scalar(@data), join($sep, @data)) ; +} + +sub countRecords +{ + my $db = shift ; + my ($k, $v) = (0,0) ; + my ($count) = 0 ; + my ($cursor) = $db->db_cursor() ; + #for ($status = $cursor->c_get($k, $v, DB_FIRST) ; +# $status == 0 ; +# $status = $cursor->c_get($k, $v, DB_NEXT) ) + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { ++ $count } + + return $count ; +} + +sub addData +{ + my $db = shift ; + my @data = @_ ; + die "addData odd data\n" if @data % 2 != 0 ; + my ($k, $v) ; + my $ret = 0 ; + while (@data) { + $k = shift @data ; + $v = shift @data ; + $ret += $db->db_put($k, $v) ; + } + + return ($ret == 0) ; +} + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + + +1; diff --git a/bdb/perl/BerkeleyDB/typemap b/bdb/perl/BerkeleyDB/typemap new file mode 100644 index 00000000000..81ead2c36d9 --- /dev/null +++ b/bdb/perl/BerkeleyDB/typemap @@ -0,0 +1,275 @@ +# typemap for Perl 5 interface to Berkeley DB version 2 & 3 +# +# SCCS: %I%, %G% +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# +#################################### DB SECTION +# +# + +void * T_PV +u_int T_U_INT +u_int32_t T_U_INT +const char * T_PV_NULL +PV_or_NULL T_PV_NULL +IO_or_NULL T_IO_NULL + +AV * T_AV + +BerkeleyDB T_PTROBJ +BerkeleyDB::Common T_PTROBJ_AV +BerkeleyDB::Hash T_PTROBJ_AV +BerkeleyDB::Btree T_PTROBJ_AV +BerkeleyDB::Recno T_PTROBJ_AV +BerkeleyDB::Queue T_PTROBJ_AV +BerkeleyDB::Cursor T_PTROBJ_AV +BerkeleyDB::TxnMgr T_PTROBJ_AV +BerkeleyDB::Txn T_PTROBJ_AV +BerkeleyDB::Log T_PTROBJ_AV +BerkeleyDB::Lock T_PTROBJ_AV +BerkeleyDB::Env T_PTROBJ_AV + +BerkeleyDB::Raw T_RAW +BerkeleyDB::Common::Raw T_RAW +BerkeleyDB::Hash::Raw T_RAW +BerkeleyDB::Btree::Raw T_RAW +BerkeleyDB::Recno::Raw T_RAW +BerkeleyDB::Queue::Raw T_RAW +BerkeleyDB::Cursor::Raw T_RAW +BerkeleyDB::TxnMgr::Raw T_RAW +BerkeleyDB::Txn::Raw T_RAW +BerkeleyDB::Log::Raw T_RAW +BerkeleyDB::Lock::Raw T_RAW +BerkeleyDB::Env::Raw T_RAW + +BerkeleyDB::Env::Inner T_INNER +BerkeleyDB::Common::Inner T_INNER +BerkeleyDB::Txn::Inner T_INNER +BerkeleyDB::TxnMgr::Inner T_INNER +# BerkeleyDB__Env T_PTR +DBT T_dbtdatum +DBT_OPT T_dbtdatum_opt +DBT_B T_dbtdatum_btree +DBTKEY T_dbtkeydatum +DBTKEY_B T_dbtkeydatum_btree +DBTYPE T_U_INT +DualType T_DUAL +BerkeleyDB_type * T_IV +BerkeleyDB_ENV_type * T_IV +BerkeleyDB_TxnMgr_type * T_IV +BerkeleyDB_Txn_type * T_IV +BerkeleyDB__Cursor_type * T_IV +DB * T_IV + +INPUT + +T_AV + if (SvROK($arg) && SvTYPE(SvRV($arg)) == SVt_PVAV) + /* if (sv_isa($arg, \"${ntype}\")) */ + $var = (AV*)SvRV($arg); + else + croak(\"$var is not an array reference\") + +T_RAW + $var = INT2PTR($type,SvIV($arg) + +T_U_INT + $var = SvUV($arg) + +T_SV_REF_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV *)GetInternalObject($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_HV_REF_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + HV * hv = (HV *)GetInternalObject($arg); + SV ** svp = hv_fetch(hv, \"db\", 2, FALSE); + IV tmp = SvIV(*svp); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_HV_REF + if (sv_derived_from($arg, \"${ntype}\")) { + HV * hv = (HV *)GetInternalObject($arg); + SV ** svp = hv_fetch(hv, \"db\", 2, FALSE); + IV tmp = SvIV(*svp); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + + +T_P_REF + if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + + +T_INNER + { + HV * hv = (HV *)SvRV($arg); + SV ** svp = hv_fetch(hv, \"db\", 2, FALSE); + IV tmp = SvIV(*svp); + $var = INT2PTR($type, tmp); + } + +T_PV_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else { + $var = ($type)SvPV($arg,PL_na) ; + if (PL_na == 0) + $var = NULL ; + } + +T_IO_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else + $var = IoOFP(sv_2io($arg)) + +T_PTROBJ_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_PTROBJ_SELF + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_PTROBJ_AV + if ($arg == &PL_sv_undef || $arg == NULL) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV(getInnerObject($arg)) ; + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_dbtkeydatum + DBM_ckFilter($arg, filter_store_key, \"filter_store_key\"); + DBT_clear($var) ; + if (db->recno_or_queue) { + Value = GetRecnoKey(db, SvIV($arg)) ; + $var.data = & Value; + $var.size = (int)sizeof(db_recno_t); + } + else { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + +T_dbtkeydatum_btree + DBM_ckFilter($arg, filter_store_key, \"filter_store_key\"); + DBT_clear($var) ; + if (db->recno_or_queue || + (db->type == DB_BTREE && flagSet(DB_SET_RECNO))) { + Value = GetRecnoKey(db, SvIV($arg)) ; + $var.data = & Value; + $var.size = (int)sizeof(db_recno_t); + } + else { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + +T_dbtdatum + DBM_ckFilter($arg, filter_store_value, \"filter_store_value\"); + DBT_clear($var) ; + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + $var.flags = db->partial ; + $var.dlen = db->dlen ; + $var.doff = db->doff ; + +T_dbtdatum_opt + DBT_clear($var) ; + if (flagSet(DB_GET_BOTH)) { + DBM_ckFilter($arg, filter_store_value, \"filter_store_value\"); + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + $var.flags = db->partial ; + $var.dlen = db->dlen ; + $var.doff = db->doff ; + } + +T_dbtdatum_btree + DBT_clear($var) ; + if (flagSet(DB_GET_BOTH)) { + DBM_ckFilter($arg, filter_store_value, \"filter_store_value\"); + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + $var.flags = db->partial ; + $var.dlen = db->dlen ; + $var.doff = db->doff ; + } + + +OUTPUT + +T_RAW + sv_setiv($arg, PTR2IV($var)); + +T_SV_REF_NULL + sv_setiv($arg, PTR2IV($var)); + +T_HV_REF_NULL + sv_setiv($arg, PTR2IV($var)); + +T_HV_REF + sv_setiv($arg, PTR2IV($var)); + +T_P_REF + sv_setiv($arg, PTR2IV($var)); + +T_DUAL + setDUALerrno($arg, $var) ; + +T_U_INT + sv_setuv($arg, (UV)$var); + +T_PV_NULL + sv_setpv((SV*)$arg, $var); + +T_dbtkeydatum_btree + OutputKey_B($arg, $var) +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) +T_dbtdatum_opt + OutputValue($arg, $var) +T_dbtdatum_btree + OutputValue_B($arg, $var) + +T_PTROBJ_NULL + sv_setref_pv($arg, \"${ntype}\", (void*)$var); + +T_PTROBJ_SELF + sv_setref_pv($arg, self, (void*)$var); diff --git a/bdb/perl/DB_File/Changes b/bdb/perl/DB_File/Changes new file mode 100644 index 00000000000..7883cbdfef0 --- /dev/null +++ b/bdb/perl/DB_File/Changes @@ -0,0 +1,434 @@ + +1.805 1st September 2002 + + * Added support to allow DB_File to build with Berkeley DB 4.1.X + + * Tightened up the test harness to test that calls to untie don't generate + the "untie attempted while %d inner references still exist" warning. + + * added code to guard against calling the callbacks (compare,hash & prefix) + recursively. + + * pasing undef for the flags and/or mode when opening a database could cause + a "Use of uninitialized value in subroutine entry" warning. Now silenced. + + * DBM filter code beefed up to cope with read-only $_. + +1.804 2nd June 2002 + + * Perl core patch 14939 added a new warning to "splice". This broke the + db-recno test harness. Fixed. + + * merged core patches 16502 & 16540. + +1.803 1st March 2002 + + * Fixed a problem with db-btree.t where it complained about an "our" + variable redeclaation. + + * FETCH, STORE & DELETE don't map the flags parameter into the + equivalent Berkeley DB function anymore. + +1.802 6th January 2002 + + * The message about some test failing in db-recno.t had the wrong test + numbers. Fixed. + + * merged core patch 13942. + +1.801 26th November 2001 + + * Fixed typo in Makefile.PL + + * Added "clean" attribute to Makefile.PL + +1.800 23rd November 2001 + + * use pport.h for perl backward compatability code. + + * use new ExtUtils::Constant module to generate XS constants. + + * upgrade Makefile.PL upgrade/downgrade code to toggle "our" with + "use vars" + +1.79 22nd October 2001 + + * Added a "local $SIG{__DIE__}" inside the eval that checks for + the presence of XSLoader s suggested by Andrew Hryckowin. + + * merged core patch 12277. + + * Changed NEXTKEY to not initialise the input key. It isn't used anyway. + +1.79 22nd October 2001 + + * Fixed test harness for cygwin + +1.78 30th July 2001 + + * the test in Makefile.PL for AIX used -plthreads. Should have been + -lpthreads + + * merged Core patches + 10372, 10335, 10372, 10534, 10549, 10643, 11051, 11194, 11432 + + * added documentation patch regarding duplicate keys from Andrew Johnson + + +1.77 26th April 2001 + + * AIX is reported to need -lpthreads, so Makefile.PL now checks for + AIX and adds it to the link options. + + * Minor documentation updates. + + * Merged Core patch 9176 + + * Added a patch from Edward Avis that adds support for splice with + recno databases. + + * Modified Makefile.PL to only enable the warnings pragma if using perl + 5.6.1 or better. + +1.76 15th January 2001 + + * Added instructions for using LD_PRELOAD to get Berkeley DB 2.x to work + with DB_File on Linux. Thanks to Norbert Bollow for sending details of + this approach. + + +1.75 17th December 2000 + + * Fixed perl core patch 7703 + + * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- + btree_compare, btree_prefix and hash_cb needed to be changed. + + * Updated dbinfo to support Berkeley DB 3.2 file format changes. + + +1.74 10th December 2000 + + * A "close" call in DB_File.xs needed parenthesised to stop win32 from + thinking it was one of its macros. + + * Updated dbinfo to support Berkeley DB 3.1 file format changes. + + * DB_File.pm & the test hasness now use the warnings pragma (when + available). + + * Included Perl core patch 7703 -- size argument for hash_cb is different + for Berkeley DB 3.x + + * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C + treatment. + + * @a = () produced the warning 'Argument "" isn't numeric in entersub' + This has been fixed. Thanks to Edward Avis for spotting this bug. + + * Added note about building under Linux. Included patches. + + * Included Perl core patch 8068 -- fix for bug 20001013.009 + When run with warnings enabled "$hash{XX} = undef " produced an + "Uninitialized value" warning. This has been fixed. + +1.73 31st May 2000 + + * Added support in version.c for building with threaded Perl. + + * Berkeley DB 3.1 has reenabled support for null keys. The test + harness has been updated to reflect this. + +1.72 16th January 2000 + + * Added hints/sco.pl + + * The module will now use XSLoader when it is available. When it + isn't it will use DynaLoader. + + * The locking section in DB_File.pm has been discredited. Many thanks + to David Harris for spotting the underlying problem, contributing + the updates to the documentation and writing DB_File::Lock (available + on CPAN). + +1.71 7th September 1999 + + * Fixed a bug that prevented 1.70 from compiling under win32 + + * Updated to support Berkeley DB 3.x + + * Updated dbinfo for Berkeley DB 3.x file formats. + +1.70 4th August 1999 + + * Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + + * Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + +1.69 3rd August 1999 + + * fixed a bug in push -- DB_APPEND wasn't working properly. + + * Fixed the R_SETCURSOR bug introduced in 1.68 + + * Added a new Perl variable $DB_File::db_ver + +1.68 22nd July 1999 + + * Merged changes from 5.005_58 + + * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB + 2 databases. + + * Added some of the examples in the POD into the test harness. + +1.67 6th June 1999 + + * Added DBM Filter documentation to DB_File.pm + + * Fixed DBM Filter code to work with 5.004 + + * A few instances of newSVpvn were used in 1.66. This isn't available in + Perl 5.004_04 or earlier. Replaced with newSVpv. + +1.66 15th March 1999 + + * Added DBM Filter code + +1.65 6th March 1999 + + * Fixed a bug in the recno PUSH logic. + * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 + +1.64 21st February 1999 + + * Tidied the 1.x to 2.x flag mapping code. + * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag + mapping problem with O_RDONLY on the Hurd + * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. + +1.63 19th December 1998 + + * Fix to allow DB 2.6.x to build with DB_File + * Documentation updated to use push,pop etc in the RECNO example & + to include the find_dup & del_dup methods. + +1.62 30th November 1998 + + Added hints/dynixptx.pl. + Fixed typemap -- 1.61 used PL_na instead of na + +1.61 19th November 1998 + + Added a note to README about how to build Berkeley DB 2.x when + using HP-UX. + Minor modifications to get the module to build with DB 2.5.x + Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis. + +1.60 + Changed the test to check for full tied array support + +1.59 + Updated the license section. + + Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in + db-btree.t and test 27 in db-hash.t failed because of this change. + Those tests have been zapped. + + Added dbinfo to the distribution. + +1.58 + Tied Array support was enhanced in Perl 5.004_57. DB_File now + supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. + + Fixed a problem with the use of sv_setpvn. When the size is + specified as 0, it does a strlen on the data. This was ok for DB + 1.x, but isn't for DB 2.x. + +1.57 + If Perl has been compiled with Threads support,the symbol op will be + defined. This clashes with a field name in db.h, so it needs to be + #undef'ed before db.h is included. + +1.56 + Documented the Solaris 2.5 mutex bug + +1.55 + Merged 1.16 changes. + +1.54 + + Fixed a small bug in the test harness when run under win32 + The emulation of fd when useing DB 2.x was busted. + +1.53 + + Added DB_RENUMBER to flags for recno. + +1.52 + + Patch from Nick Ing-Simmons now allows DB_File to build on NT. + Merged 1.15 patch. + +1.51 + + Fixed the test harness so that it doesn't expect DB_File to have + been installed by the main Perl build. + + + Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + +1.50 + + DB_File can now build with either DB 1.x or 2.x, but not both at + the same time. + +1.16 + + A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 + + Small fix for the AIX strict C compiler XLC which doesn't like + __attribute__ being defined via proto.h and redefined via db.h. Fix + courtesy of Jarkko Hietaniemi. + +1.15 + + Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined + value" warning with db_get and db_seq. + + Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the + O_* constants from Fcntl. + + Removed the DESTROY method from the DB_File::HASHINFO module. + + Previously DB_File hard-wired the class name of any object that it + created to "DB_File". This makes sub-classing difficult. Now + DB_File creats objects in the namespace of the package it has been + inherited into. + + +1.14 + + Made it illegal to tie an associative array to a RECNO database and + an ordinary array to a HASH or BTREE database. + +1.13 + + Minor changes to DB_FIle.xs and DB_File.pm + +1.12 + + Documented the incompatibility with version 2 of Berkeley DB. + +1.11 + + Documented the untie gotcha. + +1.10 + + Fixed fd method so that it still returns -1 for in-memory files + when db 1.86 is used. + +1.09 + + Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and + DB_File::BTREEINFO. + + Changed default mode to 0666. + +1.08 + + Documented operation of bval. + +1.07 + + Fixed bug with RECNO, where bval wasn't defaulting to "\n". + +1.06 + + Minor namespace cleanup: Localized PrintBtree. + +1.05 + + Made all scripts in the documentation strict and -w clean. + + Added logic to DB_File.xs to allow the module to be built after + Perl is installed. + +1.04 + + Minor documentation changes. + + Fixed a bug in hash_cb. Patches supplied by Dave Hammen, + <hammen@gothamcity.jsc.nasa.govt>. + + Fixed a bug with the constructors for DB_File::HASHINFO, + DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the + constructors to make them -w clean. + + Reworked part of the test harness to be more locale friendly. + +1.03 + + Documentation update. + + DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl + automatically. + + The standard hash function exists is now supported. + + Modified the behavior of get_dup. When it returns an associative + array, the value is the count of the number of matching BTREE + values. + +1.02 + + Merged OS/2 specific code into DB_File.xs + + Removed some redundant code in DB_File.xs. + + Documentation update. + + Allow negative subscripts with RECNO interface. + + Changed the default flags from O_RDWR to O_CREAT|O_RDWR. + + The example code which showed how to lock a database needed a call + to sync added. Without it the resultant database file was empty. + + Added get_dup method. + +1.01 + + Fixed a core dump problem with SunOS. + + The return value from TIEHASH wasn't set to NULL when dbopen + returned an error. + +1.0 + + DB_File has been in use for over a year. To reflect that, the + version number has been incremented to 1.0. + + Added complete support for multiple concurrent callbacks. + + Using the push method on an empty list didn't work properly. This + has been fixed. + +0.3 + + Added prototype support for multiple btree compare callbacks. + +0.2 + + When DB_File is opening a database file it no longer terminates the + process if dbopen returned an error. This allows file protection + errors to be caught at run time. Thanks to Judith Grass + <grass@cybercash.com> for spotting the bug. + +0.1 + + First Release. + diff --git a/bdb/perl/DB_File/DB_File.pm b/bdb/perl/DB_File/DB_File.pm new file mode 100644 index 00000000000..49004ffa148 --- /dev/null +++ b/bdb/perl/DB_File/DB_File.pm @@ -0,0 +1,2291 @@ +# DB_File.pm -- Perl 5 interface to Berkeley DB +# +# written by Paul Marquess (Paul.Marquess@btinternet.com) +# last modified 1st September 2002 +# version 1.805 +# +# Copyright (c) 1995-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. + + +package DB_File::HASHINFO ; + +require 5.00404; + +use warnings; +use strict; +use Carp; +require Tie::Hash; +@DB_File::HASHINFO::ISA = qw(Tie::Hash); + +sub new +{ + my $pkg = shift ; + my %x ; + tie %x, $pkg ; + bless \%x, $pkg ; +} + + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { + bsize => 1, + ffactor => 1, + nelem => 1, + cachesize => 1, + hash => 2, + lorder => 1, + }, + GOT => {} + }, $pkg ; +} + + +sub FETCH +{ + my $self = shift ; + my $key = shift ; + + return $self->{GOT}{$key} if exists $self->{VALID}{$key} ; + + my $pkg = ref $self ; + croak "${pkg}::FETCH - Unknown element '$key'" ; +} + + +sub STORE +{ + my $self = shift ; + my $key = shift ; + my $value = shift ; + + my $type = $self->{VALID}{$key}; + + if ( $type ) + { + croak "Key '$key' not associated with a code reference" + if $type == 2 && !ref $value && ref $value ne 'CODE'; + $self->{GOT}{$key} = $value ; + return ; + } + + my $pkg = ref $self ; + croak "${pkg}::STORE - Unknown element '$key'" ; +} + +sub DELETE +{ + my $self = shift ; + my $key = shift ; + + if ( exists $self->{VALID}{$key} ) + { + delete $self->{GOT}{$key} ; + return ; + } + + my $pkg = ref $self ; + croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ; +} + +sub EXISTS +{ + my $self = shift ; + my $key = shift ; + + exists $self->{VALID}{$key} ; +} + +sub NotHere +{ + my $self = shift ; + my $method = shift ; + + croak ref($self) . " does not define the method ${method}" ; +} + +sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } +sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } +sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } + +package DB_File::RECNOINFO ; + +use warnings; +use strict ; + +@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( bval cachesize psize flags lorder reclen bfname ) + }, + GOT => {}, + }, $pkg ; +} + +package DB_File::BTREEINFO ; + +use warnings; +use strict ; + +@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { + flags => 1, + cachesize => 1, + maxkeypage => 1, + minkeypage => 1, + psize => 1, + compare => 2, + prefix => 2, + lorder => 1, + }, + GOT => {}, + }, $pkg ; +} + + +package DB_File ; + +use warnings; +use strict; +our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO); +our ($db_version, $use_XSLoader, $splice_end_array); +use Carp; + + +$VERSION = "1.805" ; + +{ + local $SIG{__WARN__} = sub {$splice_end_array = "@_";}; + my @a =(1); splice(@a, 3); + $splice_end_array = + ($splice_end_array =~ /^splice\(\) offset past end of array at /); +} + +#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; +$DB_BTREE = new DB_File::BTREEINFO ; +$DB_HASH = new DB_File::HASHINFO ; +$DB_RECNO = new DB_File::RECNOINFO ; + +require Tie::Hash; +require Exporter; +use AutoLoader; +BEGIN { + $use_XSLoader = 1 ; + { local $SIG{__DIE__} ; eval { require XSLoader } ; } + + if ($@) { + $use_XSLoader = 0 ; + require DynaLoader; + @ISA = qw(DynaLoader); + } +} + +push @ISA, qw(Tie::Hash Exporter); +@EXPORT = qw( + $DB_BTREE $DB_HASH $DB_RECNO + + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED + +); + +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}; +} + + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + +if ($use_XSLoader) + { XSLoader::load("DB_File", $VERSION)} +else + { bootstrap DB_File $VERSION } + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +sub tie_hash_or_array +{ + my (@arg) = @_ ; + my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2]; + $arg[3] = 0666 if @arg >=4 && ! defined $arg[3]; + + # make recno in Berkeley DB version 2 work like recno in version 1. + if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and + $arg[1] and ! -e $arg[1]) { + open(FH, ">$arg[1]") or return undef ; + close FH ; + chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ; + } + + DoTie_($tieHASH, @arg) ; +} + +sub TIEHASH +{ + tie_hash_or_array(@_) ; +} + +sub TIEARRAY +{ + tie_hash_or_array(@_) ; +} + +sub CLEAR +{ + my $self = shift; + my $key = 0 ; + my $value = "" ; + my $status = $self->seq($key, $value, R_FIRST()); + my @keys; + + while ($status == 0) { + push @keys, $key; + $status = $self->seq($key, $value, R_NEXT()); + } + foreach $key (reverse @keys) { + my $s = $self->del($key); + } +} + +sub EXTEND { } + +sub STORESIZE +{ + my $self = shift; + my $length = shift ; + my $current_length = $self->length() ; + + if ($length < $current_length) { + my $key ; + for ($key = $current_length - 1 ; $key >= $length ; -- $key) + { $self->del($key) } + } + elsif ($length > $current_length) { + $self->put($length-1, "") ; + } +} + + +sub SPLICE +{ + my $self = shift; + my $offset = shift; + if (not defined $offset) { + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); + $offset = 0; + } + + my $length = @_ ? shift : 0; + # Carping about definedness comes _after_ the OFFSET sanity check. + # This is so we get the same error messages as Perl's splice(). + # + + my @list = @_; + + my $size = $self->FETCHSIZE(); + + # 'If OFFSET is negative then it start that far from the end of + # the array.' + # + if ($offset < 0) { + my $new_offset = $size + $offset; + if ($new_offset < 0) { + die "Modification of non-creatable array value attempted, " + . "subscript $offset"; + } + $offset = $new_offset; + } + + if (not defined $length) { + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); + $length = 0; + } + + if ($offset > $size) { + $offset = $size; + warnings::warnif('misc', 'splice() offset past end of array') + if $splice_end_array; + } + + # 'If LENGTH is omitted, removes everything from OFFSET onward.' + if (not defined $length) { + $length = $size - $offset; + } + + # 'If LENGTH is negative, leave that many elements off the end of + # the array.' + # + if ($length < 0) { + $length = $size - $offset + $length; + + if ($length < 0) { + # The user must have specified a length bigger than the + # length of the array passed in. But perl's splice() + # doesn't catch this, it just behaves as for length=0. + # + $length = 0; + } + } + + if ($length > $size - $offset) { + $length = $size - $offset; + } + + # $num_elems holds the current number of elements in the database. + my $num_elems = $size; + + # 'Removes the elements designated by OFFSET and LENGTH from an + # array,'... + # + my @removed = (); + foreach (0 .. $length - 1) { + my $old; + my $status = $self->get($offset, $old); + if ($status != 0) { + my $msg = "error from Berkeley DB on get($offset, \$old)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ": error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + push @removed, $old; + + $status = $self->del($offset); + if ($status != 0) { + my $msg = "error from Berkeley DB on del($offset)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ": error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + + -- $num_elems; + } + + # ...'and replaces them with the elements of LIST, if any.' + my $pos = $offset; + while (defined (my $elem = shift @list)) { + my $old_pos = $pos; + my $status; + if ($pos >= $num_elems) { + $status = $self->put($pos, $elem); + } + else { + $status = $self->put($pos, $elem, $self->R_IBEFORE); + } + + if ($status != 0) { + my $msg = "error from Berkeley DB on put($pos, $elem, ...)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ", error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + + die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE" + if $old_pos != $pos; + + ++ $pos; + ++ $num_elems; + } + + if (wantarray) { + # 'In list context, returns the elements removed from the + # array.' + # + return @removed; + } + elsif (defined wantarray and not wantarray) { + # 'In scalar context, returns the last element removed, or + # undef if no elements are removed.' + # + if (@removed) { + my $last = pop @removed; + return "$last"; + } + else { + return undef; + } + } + elsif (not defined wantarray) { + # Void context + } + else { die } +} +sub ::DB_File::splice { &SPLICE } + +sub find_dup +{ + croak "Usage: \$db->find_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($origkey, $value_wanted) = @_ ; + my ($key, $value) = ($origkey, 0); + my ($status) = 0 ; + + for ($status = $db->seq($key, $value, R_CURSOR() ) ; + $status == 0 ; + $status = $db->seq($key, $value, R_NEXT() ) ) { + + return 0 if $key eq $origkey and $value eq $value_wanted ; + } + + return $status ; +} + +sub del_dup +{ + croak "Usage: \$db->del_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($key, $value) = @_ ; + my ($status) = $db->find_dup($key, $value) ; + return $status if $status != 0 ; + + $status = $db->del($key, R_CURSOR() ) ; + return $status ; +} + +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 ; + + # iterate through the database until either EOF ($status == 0) + # or a different key is encountered ($key ne $origkey). + for ($status = $db->seq($key, $value, R_CURSOR()) ; + $status == 0 and $key eq $origkey ; + $status = $db->seq($key, $value, R_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) ; +} + + +1; +__END__ + +=head1 NAME + +DB_File - Perl5 access to Berkeley DB version 1.x + +=head1 SYNOPSIS + + use DB_File; + + [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; + [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; + [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; + + $status = $X->del($key [, $flags]) ; + $status = $X->put($key, $value [, $flags]) ; + $status = $X->get($key, $value [, $flags]) ; + $status = $X->seq($key, $value, $flags) ; + $status = $X->sync([$flags]) ; + $status = $X->fd ; + + # BTREE only + $count = $X->get_dup($key) ; + @list = $X->get_dup($key) ; + %list = $X->get_dup($key, 1) ; + $status = $X->find_dup($key, $value) ; + $status = $X->del_dup($key, $value) ; + + # RECNO only + $a = $X->length; + $a = $X->pop ; + $X->push(list); + $a = $X->shift; + $X->unshift(list); + @r = $X->splice(offset, length, elements); + + # DBM Filters + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; + + untie %hash ; + untie @array ; + +=head1 DESCRIPTION + +B<DB_File> is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 1.x (if you have a newer +version of DB, see L<Using DB_File with Berkeley DB version 2 or greater>). +It is assumed that you have a copy of the Berkeley DB manual pages at +hand when reading this documentation. The interface defined here +mirrors the Berkeley DB interface closely. + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. B<DB_File> provides an interface to all +three of the database types currently supported by Berkeley DB. + +The file types are: + +=over 5 + +=item B<DB_HASH> + +This database type allows arbitrary key/value pairs to be stored in data +files. This is equivalent to the functionality provided by other +hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, +the files created using DB_HASH are not compatible with any of the +other packages mentioned. + +A default hashing algorithm, which will be adequate for most +applications, is built into Berkeley DB. If you do need to use your own +hashing algorithm it is possible to write your own in Perl and have +B<DB_File> use it instead. + +=item B<DB_BTREE> + +The btree format allows arbitrary key/value pairs to be stored in a +sorted, balanced binary tree. + +As with the DB_HASH format, it is possible to provide a user defined +Perl routine to perform the comparison of keys. By default, though, the +keys are stored in lexical order. + +=item B<DB_RECNO> + +DB_RECNO allows both fixed-length and variable-length flat text files +to be manipulated using the same key/value pair interface as in DB_HASH +and DB_BTREE. In this case the key will consist of a record (line) +number. + +=back + +=head2 Using DB_File with Berkeley DB version 2 or greater + +Although B<DB_File> is intended to be used with Berkeley DB version 1, +it can also be used with version 2, 3 or 4. In this case the interface is +limited to the functionality provided by Berkeley DB 1.x. Anywhere the +version 2 or greater interface differs, B<DB_File> arranges for it to work +like version 1. This feature allows B<DB_File> scripts that were built +with version 1 to be migrated to version 2 or greater without any changes. + +If you want to make use of the new features available in Berkeley DB +2.x or greater, use the Perl module B<BerkeleyDB> instead. + +B<Note:> The database file format has changed multiple times in Berkeley +DB version 2, 3 and 4. If you cannot recreate your databases, you +must dump any existing databases with either the C<db_dump> or the +C<db_dump185> utility that comes with Berkeley DB. +Once you have rebuilt DB_File to use Berkeley DB version 2 or greater, +your databases can be recreated using C<db_load>. Refer to the Berkeley DB +documentation for further details. + +Please read L<"COPYRIGHT"> before using version 2.x or greater of Berkeley +DB with DB_File. + +=head2 Interface to Berkeley DB + +B<DB_File> allows access to Berkeley DB files using the tie() mechanism +in Perl 5 (for full details, see L<perlfunc/tie()>). This facility +allows B<DB_File> to access Berkeley DB files using either an +associative array (for DB_HASH & DB_BTREE file types) or an ordinary +array (for the DB_RECNO file type). + +In addition to the tie() interface, it is also possible to access most +of the functions provided in the Berkeley DB API directly. +See L<THE API INTERFACE>. + +=head2 Opening a Berkeley DB Database File + +Berkeley DB uses the function dbopen() to open or create a database. +Here is the C prototype for dbopen(): + + DB* + dbopen (const char * file, int flags, int mode, + DBTYPE type, const void * openinfo) + +The parameter C<type> is an enumeration which specifies which of the 3 +interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used. +Depending on which of these is actually chosen, the final parameter, +I<openinfo> points to a data structure which allows tailoring of the +specific interface method. + +This interface is handled slightly differently in B<DB_File>. Here is +an equivalent call using B<DB_File>: + + tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ; + +The C<filename>, C<flags> and C<mode> parameters are the direct +equivalent of their dbopen() counterparts. The final parameter $DB_HASH +performs the function of both the C<type> and C<openinfo> parameters in +dbopen(). + +In the example above $DB_HASH is actually a pre-defined reference to a +hash object. B<DB_File> has three of these pre-defined references. +Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. + +The keys allowed in each of these pre-defined references is limited to +the names used in the equivalent C structure. So, for example, the +$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>, +C<ffactor>, C<hash>, C<lorder> and C<nelem>. + +To change one of these elements, just assign to it like this: + + $DB_HASH->{'cachesize'} = 10000 ; + +The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are +usually adequate for most applications. If you do need to create extra +instances of these objects, constructors are available for each file +type. + +Here are examples of the constructors and the valid options available +for DB_HASH, DB_BTREE and DB_RECNO respectively. + + $a = new DB_File::HASHINFO ; + $a->{'bsize'} ; + $a->{'cachesize'} ; + $a->{'ffactor'}; + $a->{'hash'} ; + $a->{'lorder'} ; + $a->{'nelem'} ; + + $b = new DB_File::BTREEINFO ; + $b->{'flags'} ; + $b->{'cachesize'} ; + $b->{'maxkeypage'} ; + $b->{'minkeypage'} ; + $b->{'psize'} ; + $b->{'compare'} ; + $b->{'prefix'} ; + $b->{'lorder'} ; + + $c = new DB_File::RECNOINFO ; + $c->{'bval'} ; + $c->{'cachesize'} ; + $c->{'psize'} ; + $c->{'flags'} ; + $c->{'lorder'} ; + $c->{'reclen'} ; + $c->{'bfname'} ; + +The values stored in the hashes above are mostly the direct equivalent +of their C counterpart. Like their C counterparts, all are set to a +default values - that means you don't have to set I<all> of the +values when you only want to change one. Here is an example: + + $a = new DB_File::HASHINFO ; + $a->{'cachesize'} = 12345 ; + tie %y, 'DB_File', "filename", $flags, 0777, $a ; + +A few of the options need extra discussion here. When used, the C +equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers +to C functions. In B<DB_File> these keys are used to store references +to Perl subs. Below are templates for each of the subs: + + sub hash + { + my ($data) = @_ ; + ... + # return the hash value for $data + return $hash ; + } + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + sub prefix + { + my ($key, $key2) = @_ ; + ... + # return number of bytes of $key2 which are + # necessary to determine that it is greater than $key1 + return $bytes ; + } + +See L<Changing the BTREE sort order> for an example of using the +C<compare> template. + +If you are using the DB_RECNO interface and you intend making use of +C<bval>, you should check out L<The 'bval' Option>. + +=head2 Default Parameters + +It is possible to omit some or all of the final 4 parameters in the +call to C<tie> and let them take default values. As DB_HASH is the most +common file format used, the call: + + tie %A, "DB_File", "filename" ; + +is equivalent to: + + tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; + +It is also possible to omit the filename parameter as well, so the +call: + + tie %A, "DB_File" ; + +is equivalent to: + + tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ; + +See L<In Memory Databases> for a discussion on the use of C<undef> +in place of a filename. + +=head2 In Memory Databases + +Berkeley DB allows the creation of in-memory databases by using NULL +(that is, a C<(char *)0> in C) in place of the filename. B<DB_File> +uses C<undef> instead of NULL to provide this functionality. + +=head1 DB_HASH + +The DB_HASH file format is probably the most commonly used of the three +file formats that B<DB_File> supports. It is also very straightforward +to use. + +=head2 A Simple Example + +This example shows how to create a database, add key/value pairs to the +database, delete keys/value pairs and finally how to enumerate the +contents of the database. + + use warnings ; + use strict ; + use DB_File ; + our (%h, $k, $v) ; + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved is in an apparently random order. + +=head1 DB_BTREE + +The DB_BTREE format is useful when you want to store data in a given +order. By default the keys will be stored in lexical order, but as you +will see from the example shown in the next section, it is very easy to +define your own sorting function. + +=head2 Changing the BTREE sort order + +This script shows how to override the default sorting algorithm that +BTREE uses. Instead of using the normal lexical ordering, a case +insensitive compare function will be used. + + use warnings ; + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +You cannot change the ordering once the database has been created. Thus +you must use the same compare function every time you access the +database. + +=item 3 + +Duplicate keys are entirely defined by the comparison function. +In the case-insensitive example above, the keys: 'KEY' and 'key' +would be considered duplicates, and assigning to the second one +would overwrite the first. If duplicates are allowed for (with the +R_DUPS flag discussed below), only a single copy of duplicate keys +is stored in the database --- so (again with example above) assigning +three values to the keys: 'KEY', 'Key', and 'key' would leave just +the first key: 'KEY' in the database with three values. For some +situations this results in information loss, so care should be taken +to provide fully qualified comparison functions when necessary. +For example, the above comparison routine could be modified to +additionally compare case-sensitively if two keys are equal in the +case insensitive comparison: + + sub compare { + my($key1, $key2) = @_; + lc $key1 cmp lc $key2 || + $key1 cmp $key2; + } + +And now you will only have duplicates when the keys themselves +are truly the same. (note: in versions of the db library prior to +about November 1996, such duplicate keys were retained so it was +possible to recover the original keys in sets of keys that +compared as equal). + + +=back + +=head2 Handling Duplicate Keys + +The BTREE file type optionally allows a single key to be associated +with an arbitrary number of values. This option is enabled by setting +the flags element of C<$DB_BTREE> to R_DUP when creating the database. + +There are some difficulties in using the tied hash interface if you +want to manipulate a BTREE database with duplicate keys. Consider this +code: + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, %h) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (sort keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + +Here is the output: + + Smith -> John + Wall -> Larry + Wall -> Larry + Wall -> Larry + mouse -> mickey + +As you can see 3 records have been successfully created with key C<Wall> +- the only thing is, when they are retrieved from the database they +I<seem> to have the same value, namely C<Larry>. The problem is caused +by the way that the associative array interface works. Basically, when +the associative array interface is used to fetch the value associated +with a given key, it will only ever retrieve the first value. + +Although it may not be immediately obvious from the code above, the +associative array interface can be used to write values with duplicate +keys, but it cannot be used to read them back from the database. + +The way to get around this problem is to use the Berkeley DB API method +called C<seq>. This method allows sequential access to key/value +pairs. See L<THE API INTERFACE> for details of both the C<seq> method +and the API in general. + +Here is the script above rewritten using the C<seq> API method. + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $status, $key, $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + undef $x ; + untie %h ; + +that prints: + + Smith -> John + Wall -> Brick + Wall -> Brick + Wall -> Larry + mouse -> mickey + +This time we have got all the key/value pairs, including the multiple +values associated with the key C<Wall>. + +To make life easier when dealing with duplicate keys, B<DB_File> comes with +a few utility methods. + +=head2 The get_dup() Method + +The C<get_dup> method assists in +reading duplicate values from BTREE databases. The method can take the +following forms: + + $count = $x->get_dup($key) ; + @list = $x->get_dup($key) ; + %list = $x->get_dup($key, 1) ; + +In a scalar context the method returns the number of values associated +with the key, C<$key>. + +In list context, it returns all the values which match C<$key>. Note +that the values will be returned in an apparently random order. + +In list context, if the second parameter is present and evaluates +TRUE, the method returns an associative array. The keys of the +associative array correspond to the values that matched in the BTREE +and the values of the array are a count of the number of times that +particular value occurred in the BTREE. + +So assuming the database created above, we can use C<get_dup> like +this: + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + +and it will print: + + Wall occurred 3 times + Larry is there + There are 2 Brick Walls + Wall => [Brick Brick Larry] + Smith => [John] + Dog => [] + +=head2 The find_dup() Method + + $status = $X->find_dup($key, $value) ; + +This method checks for the existence of a specific key/value pair. If the +pair exists, the cursor is left pointing to the pair and the method +returns 0. Otherwise the method returns a non-zero value. + +Assuming the database from the previous example: + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is there + Harry Wall is not there + + +=head2 The del_dup() Method + + $status = $X->del_dup($key, $value) ; + +This method deletes a specific key/value pair. It returns +0 if they exist and have been deleted successfully. +Otherwise the method returns a non-zero value. + +Again assuming the existence of the C<tree> database + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is not there + +=head2 Matching Partial Keys + +The BTREE interface has a feature which allows partial keys to be +matched. This functionality is I<only> available when the C<seq> method +is used along with the R_CURSOR flag. + + $x->seq($key, $value, R_CURSOR) ; + +Here is the relevant quote from the dbopen man page where it defines +the use of the R_CURSOR flag with seq: + + Note, for the DB_BTREE access method, the returned key is not + necessarily an exact match for the specified key. The returned key + is the smallest key greater than or equal to the specified key, + permitting partial key matches and range searches. + +In the example script below, the C<match> sub uses this feature to find +and print the first matching key/value pair given a partial key. + + use warnings ; + use strict ; + use DB_File ; + use Fcntl ; + + my ($filename, $x, %h, $st, $key, $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + +Here is the output: + + IN ORDER + Smith -> John + Wall -> Larry + Walls -> Brick + mouse -> mickey + + PARTIAL MATCH + Wa -> Wall -> Larry + A -> Smith -> John + a -> mouse -> mickey + +=head1 DB_RECNO + +DB_RECNO provides an interface to flat text files. Both variable and +fixed length records are supported. + +In order to make RECNO more compatible with Perl, the array offset for +all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. + +As with normal Perl arrays, a RECNO array can be accessed using +negative indexes. The index -1 refers to the last element of the array, +-2 the second last, and so on. Attempting to access an element before +the start of the array will raise a fatal run-time error. + +=head2 The 'bval' Option + +The operation of the bval option warrants some discussion. Here is the +definition of bval from the Berkeley DB 1.85 recno manual page: + + The delimiting byte to be used to mark the end of a + record for variable-length records, and the pad charac- + ter for fixed-length records. If no value is speci- + fied, newlines (``\n'') are used to mark the end of + variable-length records and fixed-length records are + padded with spaces. + +The second sentence is wrong. In actual fact bval will only default to +C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL +openinfo parameter is used at all, the value that happens to be in bval +will be used. That means you always have to specify bval when making +use of any of the options in the openinfo parameter. This documentation +error will be fixed in the next release of Berkeley DB. + +That clarifies the situation with regards Berkeley DB itself. What +about B<DB_File>? Well, the behavior defined in the quote above is +quite useful, so B<DB_File> conforms to it. + +That means that you can specify other options (e.g. cachesize) and +still have bval default to C<"\n"> for variable length records, and +space for fixed length records. + +Also note that the bval option only allows you to specify a single byte +as a delimeter. + +=head2 A Simple Example + +Here is a simple example that uses RECNO (if you are using a version +of Perl earlier than 5.004_57 this example won't work -- see +L<Extra RECNO Methods> for a workaround). + + use warnings ; + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + push @h, "green", "black" ; + + my $elements = scalar @h ; + print "The array contains $elements entries\n" ; + + my $last = pop @h ; + print "popped $last\n" ; + + unshift @h, "white" ; + my $first = shift @h ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + untie @h ; + +Here is the output from the script: + + The array contains 5 entries + popped black + shifted white + Element 1 Exists with value blue + The last element is green + The 2nd last element is yellow + +=head2 Extra RECNO Methods + +If you are using a version of Perl earlier than 5.004_57, the tied +array interface is quite limited. In the example script above +C<push>, C<pop>, C<shift>, C<unshift> +or determining the array length will not work with a tied array. + +To make the interface more useful for older versions of Perl, a number +of methods are supplied with B<DB_File> to simulate the missing array +operations. All these methods are accessed via the object returned from +the tie call. + +Here are the methods: + +=over 5 + +=item B<$X-E<gt>push(list) ;> + +Pushes the elements of C<list> to the end of the array. + +=item B<$value = $X-E<gt>pop ;> + +Removes and returns the last element of the array. + +=item B<$X-E<gt>shift> + +Removes and returns the first element of the array. + +=item B<$X-E<gt>unshift(list) ;> + +Pushes the elements of C<list> to the start of the array. + +=item B<$X-E<gt>length> + +Returns the number of elements in the array. + +=item B<$X-E<gt>splice(offset, length, elements);> + +Returns a splice of the the array. + +=back + +=head2 Another Example + +Here is a more complete example that makes use of some of the methods +described above. It also makes use of the API interface directly (see +L<THE API INTERFACE>). + + use warnings ; + use strict ; + my (@h, $H, $file, $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + +and this is what it outputs: + + ORIGINAL + 0: zero + 1: one + 2: two + 3: three + 4: four + + The last record was [four] + The first record was [zero] + + REVERSE + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + + REVERSE again + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + +Notes: + +=over 5 + +=item 1. + +Rather than iterating through the array, C<@h> like this: + + foreach $i (@h) + +it is necessary to use either this: + + foreach $i (0 .. $H->length - 1) + +or this: + + for ($a = $H->get($k, $v, R_FIRST) ; + $a == 0 ; + $a = $H->get($k, $v, R_NEXT) ) + +=item 2. + +Notice that both times the C<put> method was used the record index was +specified using a variable, C<$i>, rather than the literal value +itself. This is because C<put> will return the record number of the +inserted line via that parameter. + +=back + +=head1 THE API INTERFACE + +As well as accessing Berkeley DB using a tied hash or array, it is also +possible to make direct use of most of the API functions defined in the +Berkeley DB documentation. + +To do this you need to store a copy of the object returned from the tie. + + $db = tie %hash, "DB_File", "filename" ; + +Once you have done that, you can access the Berkeley DB API functions +as B<DB_File> methods directly like this: + + $db->put($key, $value, R_NOOVERWRITE) ; + +B<Important:> If you have saved a copy of the object returned from +C<tie>, the underlying database file will I<not> be closed until both +the tied variable is untied and all copies of the saved object are +destroyed. + + use DB_File ; + $db = tie %hash, "DB_File", "filename" + or die "Cannot tie filename: $!" ; + ... + undef $db ; + untie %hash ; + +See L<The untie() Gotcha> for more details. + +All the functions defined in L<dbopen> are available except for +close() and dbopen() itself. The B<DB_File> method interface to the +supported functions have been implemented to mirror the way Berkeley DB +works whenever possible. In particular note that: + +=over 5 + +=item * + +The methods return a status value. All return 0 on success. +All return -1 to signify an error and set C<$!> to the exact +error code. The return code 1 generally (but not always) means that the +key specified did not exist in the database. + +Other return codes are defined. See below and in the Berkeley DB +documentation for details. The Berkeley DB documentation should be used +as the definitive source. + +=item * + +Whenever a Berkeley DB function returns data via one of its parameters, +the equivalent B<DB_File> method does exactly the same. + +=item * + +If you are careful, it is possible to mix API calls with the tied +hash/array interface in the same piece of code. Although only a few of +the methods used to implement the tied interface currently make use of +the cursor, you should always assume that the cursor has been changed +any time the tied hash/array interface is used. As an example, this +code will probably not do what you expect: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the second key/value pair. + # oops, it didn't, it got the last key/value pair! + $X->seq($key, $value, R_NEXT) ; + +The code above can be rearranged to get around the problem, like this: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # Get the second key/value pair. + # worked this time. + $X->seq($key, $value, R_NEXT) ; + +=back + +All the constants defined in L<dbopen> for use in the flags parameters +in the methods defined below are also available. Refer to the Berkeley +DB documentation for the precise meaning of the flags values. + +Below is a list of the methods available. + +=over 5 + +=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;> + +Given a key (C<$key>) this method reads the value associated with it +from the database. The value read from the database is returned in the +C<$value> parameter. + +If the key does not exist the method returns 1. + +No flags are currently defined for this method. + +=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;> + +Stores the key/value pair in the database. + +If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter +will have the record number of the inserted key/value pair set. + +Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and +R_SETCURSOR. + +=item B<$status = $X-E<gt>del($key [, $flags]) ;> + +Removes all key/value pairs with key C<$key> from the database. + +A return code of 1 means that the requested key was not in the +database. + +R_CURSOR is the only valid flag at present. + +=item B<$status = $X-E<gt>fd ;> + +Returns the file descriptor for the underlying database. + +See L<Locking: The Trouble with fd> for an explanation for why you should +not use C<fd> to lock your database. + +=item B<$status = $X-E<gt>seq($key, $value, $flags) ;> + +This interface allows sequential retrieval from the database. See +L<dbopen> for full details. + +Both the C<$key> and C<$value> parameters will be set to the key/value +pair read from the database. + +The flags parameter is mandatory. The valid flag values are R_CURSOR, +R_FIRST, R_LAST, R_NEXT and R_PREV. + +=item B<$status = $X-E<gt>sync([$flags]) ;> + +Flushes any cached buffers to disk. + +R_RECNOSYNC is the only valid flag at present. + +=back + +=head1 DBM FILTERS + +A DBM Filter is a piece of code that is be used when you I<always> +want to make the same transformation to all keys and/or values in a +DBM database. + +There are four methods associated with DBM Filters. All work identically, +and each is used to install (or uninstall) a single DBM Filter. Each +expects a single parameter, namely a reference to a sub. The only +difference between them is the place that the filter is installed. + +To summarise: + +=over 5 + +=item B<filter_store_key> + +If a filter has been installed with this method, it will be invoked +every time you write a key to a DBM database. + +=item B<filter_store_value> + +If a filter has been installed with this method, it will be invoked +every time you write a value to a DBM database. + + +=item B<filter_fetch_key> + +If a filter has been installed with this method, it will be invoked +every time you read a key from a DBM database. + +=item B<filter_fetch_value> + +If a filter has been installed with this method, it will be invoked +every time you read a value from a DBM database. + +=back + +You can use any combination of the methods, from none, to all four. + +All filter methods return the existing filter, if present, or C<undef> +in not. + +To delete a filter pass C<undef> to it. + +=head2 The Filter + +When each filter is called by Perl, a local copy of C<$_> will contain +the key or value to be filtered. Filtering is achieved by modifying +the contents of C<$_>. The return code from the filter is ignored. + +=head2 An Example -- the NULL termination problem. + +Consider the following scenario. You have a DBM database +that you need to share with a third-party C application. The C application +assumes that I<all> keys and values are NULL terminated. Unfortunately +when Perl writes to DBM databases it doesn't use NULL termination, so +your Perl application will have to manage NULL termination itself. When +you write to the database you will have to use something like this: + + $hash{"$key\0"} = "$value\0" ; + +Similarly the NULL needs to be taken into account when you are considering +the length of existing keys/values. + +It would be much better if you could ignore the NULL terminations issue +in the main application code and have a mechanism that automatically +added the terminating NULL to all keys and values whenever you write to +the database and have them removed when you read from the database. As I'm +sure you have already guessed, this is a problem that DBM Filters can +fix very easily. + + use warnings ; + use strict ; + use DB_File ; + + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; + +Hopefully the contents of each of the filters should be +self-explanatory. Both "fetch" filters remove the terminating NULL, +and both "store" filters add a terminating NULL. + + +=head2 Another Example -- Key is a C int. + +Here is another real-life example. By default, whenever Perl writes to +a DBM database it always writes the key and value as strings. So when +you use this: + + $hash{12345} = "soemthing" ; + +the key 12345 will get stored in the DBM database as the 5 byte string +"12345". If you actually want the key to be stored in the DBM database +as a C int, you will have to use C<pack> when writing, and C<unpack> +when reading. + +Here is a DBM Filter that does it: + + use warnings ; + use strict ; + use DB_File ; + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; + +This time only two filters have been used -- we only need to manipulate +the contents of the key, so it wasn't necessary to install any value +filters. + +=head1 HINTS AND TIPS + + +=head2 Locking: The Trouble with fd + +Until version 1.72 of this module, the recommended technique for locking +B<DB_File> databases was to flock the filehandle returned from the "fd" +function. Unfortunately this technique has been shown to be fundamentally +flawed (Kudos to David Harris for tracking this down). Use it at your own +peril! + +The locking technique went like this. + + $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666) + || die "dbcreat /tmp/foo.db $!"; + $fd = $db->fd; + open(DB_FH, "+<&=$fd") || die "dup $!"; + flock (DB_FH, LOCK_EX) || die "flock: $!"; + ... + $db{"Tom"} = "Jerry" ; + ... + flock(DB_FH, LOCK_UN); + undef $db; + untie %db; + close(DB_FH); + +In simple terms, this is what happens: + +=over 5 + +=item 1. + +Use "tie" to open the database. + +=item 2. + +Lock the database with fd & flock. + +=item 3. + +Read & Write to the database. + +=item 4. + +Unlock and close the database. + +=back + +Here is the crux of the problem. A side-effect of opening the B<DB_File> +database in step 2 is that an initial block from the database will get +read from disk and cached in memory. + +To see why this is a problem, consider what can happen when two processes, +say "A" and "B", both want to update the same B<DB_File> database +using the locking steps outlined above. Assume process "A" has already +opened the database and has a write lock, but it hasn't actually updated +the database yet (it has finished step 2, but not started step 3 yet). Now +process "B" tries to open the same database - step 1 will succeed, +but it will block on step 2 until process "A" releases the lock. The +important thing to notice here is that at this point in time both +processes will have cached identical initial blocks from the database. + +Now process "A" updates the database and happens to change some of the +data held in the initial buffer. Process "A" terminates, flushing +all cached data to disk and releasing the database lock. At this point +the database on disk will correctly reflect the changes made by process +"A". + +With the lock released, process "B" can now continue. It also updates the +database and unfortunately it too modifies the data that was in its +initial buffer. Once that data gets flushed to disk it will overwrite +some/all of the changes process "A" made to the database. + +The result of this scenario is at best a database that doesn't contain +what you expect. At worst the database will corrupt. + +The above won't happen every time competing process update the same +B<DB_File> database, but it does illustrate why the technique should +not be used. + +=head2 Safe ways to lock a database + +Starting with version 2.x, Berkeley DB has internal support for locking. +The companion module to this one, B<BerkeleyDB>, provides an interface +to this locking functionality. If you are serious about locking +Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. + +If using B<BerkeleyDB> isn't an option, there are a number of modules +available on CPAN that can be used to implement locking. Each one +implements locking differently and has different goals in mind. It is +therefore worth knowing the difference, so that you can pick the right +one for your application. Here are the three locking wrappers: + +=over 5 + +=item B<Tie::DB_Lock> + +A B<DB_File> wrapper which creates copies of the database file for +read access, so that you have a kind of a multiversioning concurrent read +system. However, updates are still serial. Use for databases where reads +may be lengthy and consistency problems may occur. + +=item B<Tie::DB_LockFile> + +A B<DB_File> wrapper that has the ability to lock and unlock the database +while it is being used. Avoids the tie-before-flock problem by simply +re-tie-ing the database when you get or drop a lock. Because of the +flexibility in dropping and re-acquiring the lock in the middle of a +session, this can be massaged into a system that will work with long +updates and/or reads if the application follows the hints in the POD +documentation. + +=item B<DB_File::Lock> + +An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile +before tie-ing the database and drops the lock after the untie. Allows +one to use the same lockfile for multiple databases to avoid deadlock +problems, if desired. Use for databases where updates are reads are +quick and simple flock locking semantics are enough. + +=back + +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings are +not. See L<DBM FILTERS> for a generic way to work around this problem. + +Here is a real example. Netscape 2.0 keeps a record of the locations you +visit along with the time you last visited them in a DB_HASH database. +This is usually stored in the file F<~/.netscape/history.db>. The key +field in the database is the location string and the value field is the +time the location was last visited stored as a 4 byte binary value. + +If you haven't already guessed, the location string is stored with a +terminating NULL. This means you need to be careful when accessing the +database. + +Here is a snippet of code that is loosely based on Tom Christiansen's +I<ggh> script (available from your nearest CPAN archive in +F<authors/id/TOMC/scripts/nshist.gz>). + + use warnings ; + use strict ; + use DB_File ; + use Fcntl ; + + my ($dotdir, $HISTORY, %hist_db, $href, $binary_time, $date) ; + $dotdir = $ENV{HOME} || $ENV{LOGNAME}; + + $HISTORY = "$dotdir/.netscape/history.db"; + + tie %hist_db, 'DB_File', $HISTORY + or die "Cannot open $HISTORY: $!\n" ;; + + # Dump the complete database + while ( ($href, $binary_time) = each %hist_db ) { + + # remove the terminating NULL + $href =~ s/\x00$// ; + + # convert the binary time into a user friendly string + $date = localtime unpack("V", $binary_time); + print "$date $href\n" ; + } + + # check for the existence of a specific key + # remember to add the NULL + if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) { + $date = localtime unpack("V", $binary_time) ; + print "Last visited mox.perl.com on $date\n" ; + } + else { + print "Never visited mox.perl.com\n" + } + + untie %hist_db ; + +=head2 The untie() Gotcha + +If you make use of the Berkeley DB API, it is I<very> strongly +recommended that you read L<perltie/The untie Gotcha>. + +Even if you don't currently make use of the API interface, it is still +worth reading it. + +Here is an example which illustrates the problem from a B<DB_File> +perspective: + + use DB_File ; + use Fcntl ; + + my %x ; + my $X ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC + or die "Cannot tie first time: $!" ; + + $x{123} = 456 ; + + untie %x ; + + tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + or die "Cannot tie second time: $!" ; + + untie %x ; + +When run, the script will produce this error message: + + Cannot tie second time: Invalid argument at bad.file line 14. + +Although the error message above refers to the second tie() statement +in the script, the source of the problem is really with the untie() +statement that precedes it. + +Having read L<perltie> you will probably have already guessed that the +error is caused by the extra copy of the tied object stored in C<$X>. +If you haven't, then the problem boils down to the fact that the +B<DB_File> destructor, DESTROY, will not be called until I<all> +references to the tied object are destroyed. Both the tied variable, +C<%x>, and C<$X> above hold a reference to the object. The call to +untie() will destroy the first, but C<$X> still holds a valid +reference, so the destructor will not get called and the database file +F<tst.fil> will remain open. The fact that Berkeley DB then reports the +attempt to open a database that is already open via the catch-all +"Invalid argument" doesn't help. + +If you run the script with the C<-w> flag the error message becomes: + + untie attempted while 1 inner references still exist at bad.file line 12. + Cannot tie second time: Invalid argument at bad.file line 14. + +which pinpoints the real problem. Finally the script can now be +modified to fix the original problem by destroying the API object +before the untie: + + ... + $x{123} = 456 ; + + undef $X ; + untie %x ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + ... + + +=head1 COMMON QUESTIONS + +=head2 Why is there Perl source in my database? + +If you look at the contents of a database file created by DB_File, +there can sometimes be part of a Perl script included in it. + +This happens because Berkeley DB uses dynamic memory to allocate +buffers which will subsequently be written to the database file. Being +dynamic, the memory could have been used for anything before DB +malloced it. As Berkeley DB doesn't clear the memory once it has been +allocated, the unused portions will contain random junk. In the case +where a Perl script gets written to the database, the random junk will +correspond to an area of dynamic memory that happened to be used during +the compilation of the script. + +Unless you don't like the possibility of there being part of your Perl +scripts embedded in a database file, this is nothing to worry about. + +=head2 How do I store complex data structures with DB_File? + +Although B<DB_File> cannot do this directly, there is a module which +can layer transparently over B<DB_File> to accomplish this feat. + +Check out the MLDBM module, available on CPAN in the directory +F<modules/by-module/MLDBM>. + +=head2 What does "Invalid Argument" mean? + +You will get this error message when one of the parameters in the +C<tie> call is wrong. Unfortunately there are quite a few parameters to +get wrong, so it can be difficult to figure out which one it is. + +Here are a couple of possibilities: + +=over 5 + +=item 1. + +Attempting to reopen a database without closing it. + +=item 2. + +Using the O_WRONLY flag. + +=back + +=head2 What does "Bareword 'DB_File' not allowed" mean? + +You will encounter this particular error message when you have the +C<strict 'subs'> pragma (or the full strict pragma) in your script. +Consider this script: + + use warnings ; + use strict ; + use DB_File ; + my %x ; + tie %x, DB_File, "filename" ; + +Running it produces the error in question: + + Bareword "DB_File" not allowed while "strict subs" in use + +To get around the error, place the word C<DB_File> in either single or +double quotes, like this: + + tie %x, "DB_File", "filename" ; + +Although it might seem like a real pain, it is really worth the effort +of having a C<use strict> in all your scripts. + +=head1 REFERENCES + +Articles that are either about B<DB_File> or make use of it. + +=over 5 + +=item 1. + +I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com), +Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41 + +=back + +=head1 HISTORY + +Moved to the Changes file. + +=head1 BUGS + +Some older versions of Berkeley DB had problems with fixed length +records using the RECNO file format. This problem has been fixed since +version 1.85 of Berkeley DB. + +I am sure there are bugs in the code. If you do find any, or can +suggest any enhancements, I would welcome your comments. + +=head1 AVAILABILITY + +B<DB_File> comes with the standard Perl source distribution. Look in +the directory F<ext/DB_File>. Given the amount of time between releases +of Perl the version that ships with Perl is quite likely to be out of +date, so the most recent version can always be found on CPAN (see +L<perlmod/CPAN> for details), in the directory +F<modules/by-module/DB_File>. + +This version of B<DB_File> will work with either version 1.x, 2.x or +3.x of Berkeley DB, but is limited to the functionality provided by +version 1. + +The official web site for Berkeley DB is F<http://www.sleepycat.com>. +All versions of Berkeley DB are available there. + +Alternatively, Berkeley DB version 1 is available at your nearest CPAN +archive in F<src/misc/db.1.85.tar.gz>. + +If you are running IRIX, then get Berkeley DB version 1 from +F<http://reality.sgi.com/ariel>. It has the patches necessary to +compile properly on IRIX 5.3. + +=head1 COPYRIGHT + +Copyright (c) 1995-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. + +Although B<DB_File> is covered by the Perl license, the library it +makes use of, namely Berkeley DB, is not. Berkeley DB has its own +copyright and its own license. Please take the time to read it. + +Here are are few words taken from the Berkeley DB FAQ (at +F<http://www.sleepycat.com>) regarding the license: + + Do I have to license DB to use it in Perl scripts? + + No. The Berkeley DB license requires that software that uses + Berkeley DB be freely redistributable. In the case of Perl, that + software is Perl, and not your scripts. Any Perl scripts that you + write are your property, including scripts that make use of + Berkeley DB. Neither the Perl license nor the Berkeley DB license + place any restriction on what you may do with them. + +If you are in any doubt about the license situation, contact either the +Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. + + +=head1 SEE ALSO + +L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>, +L<dbmfilter> + +=head1 AUTHOR + +The DB_File interface was written by Paul Marquess +E<lt>Paul.Marquess@btinternet.comE<gt>. +Questions about the DB system itself may be addressed to +E<lt>db@sleepycat.com<gt>. + +=cut diff --git a/bdb/perl/DB_File/DB_File.xs b/bdb/perl/DB_File/DB_File.xs new file mode 100644 index 00000000000..fba8dede791 --- /dev/null +++ b/bdb/perl/DB_File/DB_File.xs @@ -0,0 +1,1951 @@ +/* + + DB_File.xs -- Perl 5 interface to Berkeley DB + + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 1st September 2002 + version 1.805 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995-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. + + Changes: + 0.1 - Initial Release + 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. + 1.01 - Fixed a SunOS core dump problem. + The return value from TIEHASH wasn't set to NULL when + dbopen returned an error. + 1.02 - Use ALIAS to define TIEARRAY. + Removed some redundant commented code. + Merged OS2 code into the main distribution. + Allow negative subscripts with RECNO interface. + Changed the default flags to O_CREAT|O_RDWR + 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. + 1.11 - No change to DB_File.xs + 1.12 - No change to DB_File.xs + 1.13 - Tidied up a few casts. + 1.14 - Made it illegal to tie an associative array to a RECNO + database and an ordinary array to a HASH or BTREE database. + 1.50 - Make work with both DB 1.x or DB 2.x + 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of + undefined value" warning with db_get and db_seq. + 1.53 - Added DB_RENUMBER to flags for recno. + 1.54 - Fixed bug in the fd method + 1.55 - Fix for AIX from Jarkko Hietaniemi + 1.56 - No change to DB_File.xs + 1.57 - added the #undef op to allow building with Threads support. + 1.58 - Fixed a problem with the use of sv_setpvn. When the + size is specified as 0, it does a strlen on the data. + This was ok for DB 1.x, but isn't for DB 2.x. + 1.59 - No change to DB_File.xs + 1.60 - Some code tidy up + 1.61 - added flagSet macro for DB 2.5.x + fixed typo in O_RDONLY test. + 1.62 - No change to DB_File.xs + 1.63 - Fix to alllow DB 2.6.x to build. + 1.64 - Tidied up the 1.x to 2.x flags mapping code. + Added a patch from Mark Kettenis <kettenis@wins.uva.nl> + to fix a flag mapping problem with O_RDONLY on the Hurd + 1.65 - Fixed a bug in the PUSH logic. + Added BOOT check that using 2.3.4 or greater + 1.66 - Added DBM filter code + 1.67 - Backed off the use of newSVpvn. + Fixed DBM Filter code for Perl 5.004. + Fixed a small memory leak in the filter code. + 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE + merged in the 5.005_58 changes + 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. + Fixed the R_SETCURSOR bug introduced in 1.68 + Added a new Perl variable $DB_File::db_ver + 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + Rewrote push + 1.72 - No change to DB_File.xs + 1.73 - No change to DB_File.xs + 1.74 - A call to open needed parenthesised to stop it clashing + with a win32 macro. + Added Perl core patches 7703 & 7801. + 1.75 - Fixed Perl core patch 7703. + Added suppport to allow DB_File to be built with + Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb + needed to be changed. + 1.76 - No change to DB_File.xs + 1.77 - Tidied up a few types used in calling newSVpvn. + 1.78 - Core patch 10335, 10372, 10534, 10549, 11051 included. + 1.79 - NEXTKEY ignores the input key. + Added lots of casts + 1.800 - Moved backward compatability code into ppport.h. + Use the new constants code. + 1.801 - No change to DB_File.xs + 1.802 - No change to DB_File.xs + 1.803 - FETCH, STORE & DELETE don't map the flags parameter + into the equivalent Berkeley DB function anymore. + 1.804 - no change. + 1.805 - recursion detection added to the callbacks + Support for 4.1.X added. + Filter code can now cope with read-only $_ + +*/ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef _NOT_CORE +# include "ppport.h" +#endif + +/* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and + DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */ + +/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be + * shortly #included by the <db.h>) __attribute__ to the possibly + * already defined __attribute__, for example by GNUC or by Perl. */ + +/* #if DB_VERSION_MAJOR_CFG < 2 */ +#ifndef DB_VERSION_MAJOR +# undef __attribute__ +#endif + +#ifdef COMPAT185 +# include <db_185.h> +#else +# include <db.h> +#endif + +/* Wall starts with 5.7.x */ + +#if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7) + +/* Since we dropped the gccish definition of __attribute__ we will want + * to redefine dNOOP, however (so that dTHX continues to work). Yes, + * all this means that we can't do attribute checking on the DB_File, + * boo, hiss. */ +# ifndef DB_VERSION_MAJOR + +# undef dNOOP +# define dNOOP extern int Perl___notused + + /* Ditto for dXSARGS. */ +# undef dXSARGS +# define dXSARGS \ + dSP; dMARK; \ + I32 ax = mark - PL_stack_base + 1; \ + I32 items = sp - mark + +# endif + +/* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */ +# undef dXSI32 +# define dXSI32 dNOOP + +#endif /* Perl >= 5.7 */ + +#include <fcntl.h> + +/* #define TRACE */ + +#ifdef TRACE +# define Trace(x) printf x +#else +# define Trace(x) +#endif + + +#define DBT_clear(x) Zero(&x, 1, DBT) ; + +#ifdef DB_VERSION_MAJOR + +#if DB_VERSION_MAJOR == 2 +# define BERKELEY_DB_1_OR_2 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + +#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1) +# define AT_LEAST_DB_4_1 +#endif + +/* map version 2 features & constants onto their version 1 equivalent */ + +#ifdef DB_Prefix_t +# undef DB_Prefix_t +#endif +#define DB_Prefix_t size_t + +#ifdef DB_Hash_t +# undef DB_Hash_t +#endif +#define DB_Hash_t u_int32_t + +/* DBTYPE stays the same */ +/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ +#if DB_VERSION_MAJOR == 2 + typedef DB_INFO INFO ; +#else /* DB_VERSION_MAJOR > 2 */ +# define DB_FIXEDLEN (0x8000) +#endif /* DB_VERSION_MAJOR == 2 */ + +/* version 2 has db_recno_t in place of recno_t */ +typedef db_recno_t recno_t; + + +#define R_CURSOR DB_SET_RANGE +#define R_FIRST DB_FIRST +#define R_IAFTER DB_AFTER +#define R_IBEFORE DB_BEFORE +#define R_LAST DB_LAST +#define R_NEXT DB_NEXT +#define R_NOOVERWRITE DB_NOOVERWRITE +#define R_PREV DB_PREV + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define R_SETCURSOR 0x800000 +#else +# define R_SETCURSOR (-100) +#endif + +#define R_RECNOSYNC 0 +#define R_FIXEDLEN DB_FIXEDLEN +#define R_DUP DB_DUP + + +#define db_HA_hash h_hash +#define db_HA_ffactor h_ffactor +#define db_HA_nelem h_nelem +#define db_HA_bsize db_pagesize +#define db_HA_cachesize db_cachesize +#define db_HA_lorder db_lorder + +#define db_BT_compare bt_compare +#define db_BT_prefix bt_prefix +#define db_BT_flags flags +#define db_BT_psize db_pagesize +#define db_BT_cachesize db_cachesize +#define db_BT_lorder db_lorder +#define db_BT_maxkeypage +#define db_BT_minkeypage + + +#define db_RE_reclen re_len +#define db_RE_flags flags +#define db_RE_bval re_pad +#define db_RE_bfname re_source +#define db_RE_psize db_pagesize +#define db_RE_cachesize db_cachesize +#define db_RE_lorder db_lorder + +#define TXN NULL, + +#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) + + +#define DBT_flags(x) x.flags = 0 +#define DB_flags(x, v) x |= v + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define flagSet(flags, bitmask) ((flags) & (bitmask)) +#else +# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) +#endif + +#else /* db version 1.x */ + +#define BERKELEY_DB_1 +#define BERKELEY_DB_1_OR_2 + +typedef union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } INFO ; + + +#ifdef mDB_Prefix_t +# ifdef DB_Prefix_t +# undef DB_Prefix_t +# endif +# define DB_Prefix_t mDB_Prefix_t +#endif + +#ifdef mDB_Hash_t +# ifdef DB_Hash_t +# undef DB_Hash_t +# endif +# define DB_Hash_t mDB_Hash_t +#endif + +#define db_HA_hash hash.hash +#define db_HA_ffactor hash.ffactor +#define db_HA_nelem hash.nelem +#define db_HA_bsize hash.bsize +#define db_HA_cachesize hash.cachesize +#define db_HA_lorder hash.lorder + +#define db_BT_compare btree.compare +#define db_BT_prefix btree.prefix +#define db_BT_flags btree.flags +#define db_BT_psize btree.psize +#define db_BT_cachesize btree.cachesize +#define db_BT_lorder btree.lorder +#define db_BT_maxkeypage btree.maxkeypage +#define db_BT_minkeypage btree.minkeypage + +#define db_RE_reclen recno.reclen +#define db_RE_flags recno.flags +#define db_RE_bval recno.bval +#define db_RE_bfname recno.bfname +#define db_RE_psize recno.psize +#define db_RE_cachesize recno.cachesize +#define db_RE_lorder recno.lorder + +#define TXN + +#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) +#define DBT_flags(x) +#define DB_flags(x, v) +#define flagSet(flags, bitmask) ((flags) & (bitmask)) + +#endif /* db version 1 */ + + + +#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0) +#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0) +#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0) + +#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) +#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) + +#ifdef DB_VERSION_MAJOR +#define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\ + (db->dbp->close)(db->dbp, 0) )) +#define db_close(db) ((db->dbp)->close)(db->dbp, 0) +#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ + ? ((db->cursor)->c_del)(db->cursor, 0) \ + : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) + +#else /* ! DB_VERSION_MAJOR */ + +#define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp)) +#define db_close(db) ((db->dbp)->close)(db->dbp) +#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) +#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) + +#endif /* ! DB_VERSION_MAJOR */ + + +#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) + +typedef struct { + DBTYPE type ; + DB * dbp ; + SV * compare ; + bool in_compare ; + SV * prefix ; + bool in_prefix ; + SV * hash ; + bool in_hash ; + bool aborted ; + int in_memory ; +#ifdef BERKELEY_DB_1_OR_2 + INFO info ; +#endif +#ifdef DB_VERSION_MAJOR + DBC * cursor ; +#endif + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + + } DB_File_type; + +typedef DB_File_type * DB_File ; +typedef DBT DBTKEY ; + +#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + TAINT; \ + SvTAINTED_on(arg); \ + DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ + } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + TAINT; \ + SvTAINTED_on(arg); \ + DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + } \ + } + +#define my_SvUV32(sv) ((u_int32_t)SvUV(sv)) + +#ifdef CAN_PROTOTYPE +extern void __getBerkeleyDBInfo(void); +#endif + +/* Internal Global Data */ + +#define MY_CXT_KEY "DB_File::_guts" XS_VERSION + +typedef struct { + recno_t x_Value; + recno_t x_zero; + DB_File x_CurrentDB; + DBTKEY x_empty; +} my_cxt_t; + +START_MY_CXT + +#define Value (MY_CXT.x_Value) +#define zero (MY_CXT.x_zero) +#define CurrentDB (MY_CXT.x_CurrentDB) +#define empty (MY_CXT.x_empty) + +#define ERR_BUFF "DB_File::Error" + +#ifdef DB_VERSION_MAJOR + +static int +#ifdef CAN_PROTOTYPE +db_put(DB_File db, DBTKEY key, DBT value, u_int flags) +#else +db_put(db, key, value, flags) +DB_File db ; +DBTKEY key ; +DBT value ; +u_int flags ; +#endif +{ + int status ; + + if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { + DBC * temp_cursor ; + DBT l_key, l_value; + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) +#else + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) +#endif + return (-1) ; + + memset(&l_key, 0, sizeof(l_key)); + l_key.data = key.data; + l_key.size = key.size; + memset(&l_value, 0, sizeof(l_value)); + l_value.data = value.data; + l_value.size = value.size; + + if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { + (void)temp_cursor->c_close(temp_cursor); + return (-1); + } + + status = temp_cursor->c_put(temp_cursor, &key, &value, flags); + (void)temp_cursor->c_close(temp_cursor); + + return (status) ; + } + + + if (flagSet(flags, R_CURSOR)) { + return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); + } + + if (flagSet(flags, R_SETCURSOR)) { + if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) + return -1 ; + return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); + + } + + return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; + +} + +#endif /* DB_VERSION_MAJOR */ + +static void +tidyUp(DB_File db) +{ + /* db_DESTROY(db); */ + db->aborted = TRUE ; +} + + +static int +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_compare(DB * db, const DBT *key1, const DBT *key2) +#else +btree_compare(db, key1, key2) +DB * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif /* CAN_PROTOTYPE */ + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +btree_compare(const DBT *key1, const DBT *key2) +#else +btree_compare(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +#endif + +#endif + +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + dMY_CXT ; + void * data1, * data2 ; + int retval ; + int count ; + DB_File keep_CurrentDB = CurrentDB; + + + if (CurrentDB->in_compare) { + tidyUp(CurrentDB); + croak ("DB_File btree_compare: recursion detected\n") ; + } + + data1 = (char *) key1->data ; + data2 = (char *) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + CurrentDB->in_compare = TRUE; + + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + + CurrentDB = keep_CurrentDB; + CurrentDB->in_compare = FALSE; + + SPAGAIN ; + + if (count != 1){ + tidyUp(CurrentDB); + croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; + } + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; + +} + +static DB_Prefix_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_prefix(DB * db, const DBT *key1, const DBT *key2) +#else +btree_prefix(db, key1, key2) +Db * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +btree_prefix(const DBT *key1, const DBT *key2) +#else +btree_prefix(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +#endif + +#endif +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + dMY_CXT ; + char * data1, * data2 ; + int retval ; + int count ; + DB_File keep_CurrentDB = CurrentDB; + + if (CurrentDB->in_prefix){ + tidyUp(CurrentDB); + croak ("DB_File btree_prefix: recursion detected\n") ; + } + + data1 = (char *) key1->data ; + data2 = (char *) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + CurrentDB->in_prefix = TRUE; + + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + + CurrentDB = keep_CurrentDB; + CurrentDB->in_prefix = FALSE; + + SPAGAIN ; + + if (count != 1){ + tidyUp(CurrentDB); + croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; + } + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + + +#ifdef BERKELEY_DB_1 +# define HASH_CB_SIZE_TYPE size_t +#else +# define HASH_CB_SIZE_TYPE u_int32_t +#endif + +static DB_Hash_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +hash_cb(DB * db, const void *data, u_int32_t size) +#else +hash_cb(db, data, size) +DB * db ; +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, HASH_CB_SIZE_TYPE size) +#else +hash_cb(data, size) +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#endif +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + dMY_CXT; + int retval ; + int count ; + DB_File keep_CurrentDB = CurrentDB; + + if (CurrentDB->in_hash){ + tidyUp(CurrentDB); + croak ("DB_File hash callback: recursion detected\n") ; + } + +#ifndef newSVpvn + if (size == 0) + data = "" ; +#endif + + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + + XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); + PUTBACK ; + + keep_CurrentDB->in_hash = TRUE; + + count = perl_call_sv(CurrentDB->hash, G_SCALAR); + + CurrentDB = keep_CurrentDB; + CurrentDB->in_hash = FALSE; + + SPAGAIN ; + + if (count != 1){ + tidyUp(CurrentDB); + croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; + } + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + +static void +#ifdef CAN_PROTOTYPE +db_errcall_cb(const char * db_errpfx, char * buffer) +#else +db_errcall_cb(db_errpfx, buffer) +const char * db_errpfx; +char * buffer; +#endif +{ + SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; + if (sv) { + if (db_errpfx) + sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ; + else + sv_setpv(sv, buffer) ; + } +} + +#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) + +static void +#ifdef CAN_PROTOTYPE +PrintHash(INFO *hash) +#else +PrintHash(hash) +INFO * hash ; +#endif +{ + printf ("HASH Info\n") ; + printf (" hash = %s\n", + (hash->db_HA_hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->db_HA_bsize) ; + printf (" ffactor = %d\n", hash->db_HA_ffactor) ; + printf (" nelem = %d\n", hash->db_HA_nelem) ; + printf (" cachesize = %d\n", hash->db_HA_cachesize) ; + printf (" lorder = %d\n", hash->db_HA_lorder) ; + +} + +static void +#ifdef CAN_PROTOTYPE +PrintRecno(INFO *recno) +#else +PrintRecno(recno) +INFO * recno ; +#endif +{ + printf ("RECNO Info\n") ; + printf (" flags = %d\n", recno->db_RE_flags) ; + printf (" cachesize = %d\n", recno->db_RE_cachesize) ; + printf (" psize = %d\n", recno->db_RE_psize) ; + printf (" lorder = %d\n", recno->db_RE_lorder) ; + printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ; + printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ; + printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ; +} + +static void +#ifdef CAN_PROTOTYPE +PrintBtree(INFO *btree) +#else +PrintBtree(btree) +INFO * btree ; +#endif +{ + printf ("BTREE Info\n") ; + printf (" compare = %s\n", + (btree->db_BT_compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", + (btree->db_BT_prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->db_BT_flags) ; + printf (" cachesize = %d\n", btree->db_BT_cachesize) ; + printf (" psize = %d\n", btree->db_BT_psize) ; +#ifndef DB_VERSION_MAJOR + printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ; + printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ; +#endif + printf (" lorder = %d\n", btree->db_BT_lorder) ; +} + +#else + +#define PrintRecno(recno) +#define PrintHash(hash) +#define PrintBtree(btree) + +#endif /* TRACE */ + + +static I32 +#ifdef CAN_PROTOTYPE +GetArrayLength(pTHX_ DB_File db) +#else +GetArrayLength(db) +DB_File db ; +#endif +{ + DBT key ; + DBT value ; + int RETVAL ; + + DBT_clear(key) ; + DBT_clear(value) ; + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL == 0) + RETVAL = *(I32 *)key.data ; + else /* No key means empty file */ + RETVAL = 0 ; + + return ((I32)RETVAL) ; +} + +static recno_t +#ifdef CAN_PROTOTYPE +GetRecnoKey(pTHX_ DB_File db, I32 value) +#else +GetRecnoKey(db, value) +DB_File db ; +I32 value ; +#endif +{ + if (value < 0) { + /* Get the length of the array */ + I32 length = GetArrayLength(aTHX_ db) ; + + /* check for attempt to write before start of array */ + if (length + value + 1 <= 0) { + tidyUp(db); + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + } + + value = length + value + 1 ; + } + else + ++ value ; + + return value ; +} + + +static DB_File +#ifdef CAN_PROTOTYPE +ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) +#else +ParseOpenInfo(isHASH, name, flags, mode, sv) +int isHASH ; +char * name ; +int flags ; +int mode ; +SV * sv ; +#endif +{ + +#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + void * openinfo = NULL ; + INFO * info = &RETVAL->info ; + STRLEN n_a; + dMY_CXT; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + info->db_HA_hash = hash_cb ; + RETVAL->hash = newSVsv(*svp) ; + } + else + info->db_HA_hash = NULL ; + + svp = hv_fetch(action, "ffactor", 7, FALSE); + info->db_HA_ffactor = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "nelem", 5, FALSE); + info->db_HA_nelem = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "bsize", 5, FALSE); + info->db_HA_bsize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_HA_cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_HA_lorder = svp ? SvIV(*svp) : 0; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_compare = btree_compare ; + RETVAL->compare = newSVsv(*svp) ; + } + else + info->db_BT_compare = NULL ; + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_prefix = btree_prefix ; + RETVAL->prefix = newSVsv(*svp) ; + } + else + info->db_BT_prefix = NULL ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_BT_flags = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_BT_cachesize = svp ? SvIV(*svp) : 0; + +#ifndef DB_VERSION_MAJOR + svp = hv_fetch(action, "minkeypage", 10, FALSE); + info->btree.minkeypage = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "maxkeypage", 10, FALSE); + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; +#endif + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_BT_psize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_BT_lorder = svp ? SvIV(*svp) : 0; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + openinfo = (void *)info ; + + info->db_RE_flags = 0 ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "reclen", 6, FALSE); + info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); + +#ifdef DB_VERSION_MAJOR + info->re_source = name ; + name = NULL ; +#endif + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; +#ifdef DB_VERSION_MAJOR + name = (char*) n_a ? ptr : NULL ; +#else + info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; +#endif + } + else +#ifdef DB_VERSION_MAJOR + name = NULL ; +#else + info->db_RE_bfname = NULL ; +#endif + + svp = hv_fetch(action, "bval", 4, FALSE); +#ifdef DB_VERSION_MAJOR + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = SvIV(*svp) ; + + if (info->flags & DB_FIXEDLEN) { + info->re_pad = value ; + info->flags |= DB_PAD ; + } + else { + info->re_delim = value ; + info->flags |= DB_DELIMITER ; + } + + } +#else + if (svp && SvOK(*svp)) + { + if (SvPOK(*svp)) + info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; + else + info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; + DB_flags(info->flags, DB_DELIMITER) ; + + } + else + { + if (info->db_RE_flags & R_FIXEDLEN) + info->db_RE_bval = (u_char) ' ' ; + else + info->db_RE_bval = (u_char) '\n' ; + DB_flags(info->flags, DB_DELIMITER) ; + } +#endif + +#ifdef DB_RENUMBER + info->flags |= DB_RENUMBER ; +#endif + + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + + /* OS2 Specific Code */ +#ifdef OS2 +#ifdef __EMX__ + flags |= O_BINARY; +#endif /* __EMX__ */ +#endif /* OS2 */ + +#ifdef DB_VERSION_MAJOR + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 2.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ; + if (status == 0) +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; +#else + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; +#endif + + if (status) + RETVAL->dbp = NULL ; + + } +#else + +#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 + RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; +#else + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#endif /* DB_LIBRARY_COMPATIBILITY_API */ + +#endif + + return (RETVAL) ; + +#else /* Berkeley DB Version > 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + DB * dbp ; + STRLEN n_a; + int status ; + dMY_CXT; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + status = db_create(&RETVAL->dbp, NULL,0) ; + /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ + if (status) { + RETVAL->dbp = NULL ; + return (RETVAL) ; + } + dbp = RETVAL->dbp ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + (void)dbp->set_h_hash(dbp, hash_cb) ; + RETVAL->hash = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "ffactor", 7, FALSE); + if (svp) + (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "nelem", 5, FALSE); + if (svp) + (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "bsize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_compare(dbp, btree_compare) ; + RETVAL->compare = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_prefix(dbp, btree_prefix) ; + RETVAL->prefix = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) + (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + int fixed = FALSE ; + + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) { + int flags = SvIV(*svp) ; + /* remove FIXDLEN, if present */ + if (flags & DB_FIXEDLEN) { + fixed = TRUE ; + flags &= ~DB_FIXEDLEN ; + } + } + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) { + status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; + } + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) { + status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; + } + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) { + status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ; + } + + svp = hv_fetch(action, "bval", 4, FALSE); + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = (int)SvIV(*svp) ; + + if (fixed) { + status = dbp->set_re_pad(dbp, value) ; + } + else { + status = dbp->set_re_delim(dbp, value) ; + } + + } + + if (fixed) { + svp = hv_fetch(action, "reclen", 6, FALSE); + if (svp) { + u_int32_t len = my_SvUV32(*svp) ; + status = dbp->set_re_len(dbp, len) ; + } + } + + if (name != NULL) { + status = dbp->set_re_source(dbp, name) ; + name = NULL ; + } + + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; + name = (char*) n_a ? ptr : NULL ; + } + else + name = NULL ; + + + status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ; + + if (flags){ + (void)dbp->set_flags(dbp, (u_int32_t)flags) ; + } + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + { + u_int32_t Flags = 0 ; + int status ; + + /* Map 1.x flags to 3.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + +#ifdef AT_LEAST_DB_4_1 + status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, + Flags, mode) ; +#else + status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, + Flags, mode) ; +#endif + /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ + + if (status == 0) { + RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ; + + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; + /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ + } + + if (status) + RETVAL->dbp = NULL ; + + } + + return (RETVAL) ; + +#endif /* Berkeley DB Version > 2 */ + +} /* ParseOpenInfo */ + + +#include "constants.h" + +MODULE = DB_File PACKAGE = DB_File PREFIX = db_ + +INCLUDE: constants.xs + +BOOT: + { + SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; + MY_CXT_INIT; + __getBerkeleyDBInfo() ; + + DBT_clear(empty) ; + empty.data = &zero ; + empty.size = sizeof(recno_t) ; + } + + + +DB_File +db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) + int isHASH + char * dbtype + int flags + int mode + CODE: + { + char * name = (char *) NULL ; + SV * sv = (SV *) NULL ; + STRLEN n_a; + + if (items >= 3 && SvOK(ST(2))) + name = (char*) SvPV(ST(2), n_a) ; + + if (items == 6) + sv = ST(5) ; + + RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; + if (RETVAL->dbp == NULL) + RETVAL = NULL ; + } + OUTPUT: + RETVAL + +int +db_DESTROY(db) + DB_File db + PREINIT: + dMY_CXT; + INIT: + CurrentDB = db ; + Trace(("DESTROY %p\n", db)); + CLEANUP: + Trace(("DESTROY %p done\n", db)); + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; + safefree(db) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + + +int +db_DELETE(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT; + INIT: + CurrentDB = db ; + + +int +db_EXISTS(db, key) + DB_File db + DBTKEY key + PREINIT: + dMY_CXT; + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; + } + OUTPUT: + RETVAL + +void +db_FETCH(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = db_get(db, key, value, flags) ; + ST(0) = sv_newmortal(); + OutputValue(ST(0), value) + } + +int +db_STORE(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + PREINIT: + dMY_CXT; + INIT: + CurrentDB = db ; + + +void +db_FIRSTKEY(db) + DB_File db + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +void +db_NEXTKEY(db, key) + DB_File db + DBTKEY key = NO_INIT + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_NEXT) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +# +# These would be nice for RECNO +# + +int +unshift(db, ...) + DB_File db + ALIAS: UNSHIFT = 1 + PREINIT: + dMY_CXT; + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + int One ; + STRLEN n_a; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + /* get the first value */ + RETVAL = do_SEQ(db, key, value, DB_FIRST) ; + RETVAL = 0 ; +#else + RETVAL = -1 ; +#endif + for (i = items-1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + One = 1 ; + key.data = &One ; + key.size = sizeof(int) ; +#ifdef DB_VERSION_MAJOR + RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; +#else + RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ; +#endif + if (RETVAL != 0) + break; + } + } + OUTPUT: + RETVAL + +void +pop(db) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: POP = 1 + PREINIT: + I32 RETVAL; + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + + /* First get the final value */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv(ST(0), &PL_sv_undef); + } + } + +void +shift(db) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: SHIFT = 1 + PREINIT: + I32 RETVAL; + CODE: + { + DBT value ; + DBTKEY key ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + /* get the first value */ + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv (ST(0), &PL_sv_undef) ; + } + } + + +I32 +push(db, ...) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: PUSH = 1 + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + int i ; + STRLEN n_a; + int keyval ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; +#ifndef DB_VERSION_MAJOR + if (RETVAL >= 0) +#endif + { + if (RETVAL == 0) + keyval = *(int*)key.data ; + else + keyval = 0 ; + for (i = 1 ; i < items ; ++i) + { + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + ++ keyval ; + key.data = &keyval ; + key.size = sizeof(int) ; + RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; + if (RETVAL != 0) + break; + } + } + } + OUTPUT: + RETVAL + +I32 +length(db) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: FETCHSIZE = 1 + CODE: + CurrentDB = db ; + RETVAL = GetArrayLength(aTHX_ db) ; + OUTPUT: + RETVAL + + +# +# Now provide an interface to the rest of the DB functionality +# + +int +db_del(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_del(db, key, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + + +int +db_get(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_get(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + value + +int +db_put(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_put(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_KEYEXIST) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); + +int +db_fd(db) + DB_File db + PREINIT: + dMY_CXT ; + CODE: + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + RETVAL = -1 ; + { + int status = 0 ; + status = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; + if (status != 0) + RETVAL = -1 ; + } +#else + RETVAL = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp) ) ; +#endif + OUTPUT: + RETVAL + +int +db_sync(db, flags=0) + DB_File db + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_sync(db, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + OUTPUT: + RETVAL + + +int +db_seq(db, key, value, flags) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_seq(db, key, value, flags); +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key + value + +SV * +filter_fetch_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_key, code) ; + +SV * +filter_store_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_key, code) ; + +SV * +filter_fetch_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_value, code) ; + +SV * +filter_store_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_value, code) ; + diff --git a/bdb/perl/DB_File/DB_File_BS b/bdb/perl/DB_File/DB_File_BS new file mode 100644 index 00000000000..9282c498811 --- /dev/null +++ b/bdb/perl/DB_File/DB_File_BS @@ -0,0 +1,6 @@ +# NeXT needs /usr/lib/libposix.a to load along with DB_File.so +if ( $dlsrc eq "dl_next.xs" ) { + @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); +} + +1; diff --git a/bdb/perl/DB_File/MANIFEST b/bdb/perl/DB_File/MANIFEST new file mode 100644 index 00000000000..b3e1a7bd85b --- /dev/null +++ b/bdb/perl/DB_File/MANIFEST @@ -0,0 +1,30 @@ +Changes +DB_File.pm +DB_File.xs +DB_File_BS +MANIFEST +Makefile.PL +README +config.in +dbinfo +fallback.h +fallback.xs +hints/dynixptx.pl +hints/sco.pl +patches/5.004 +patches/5.004_01 +patches/5.004_02 +patches/5.004_03 +patches/5.004_04 +patches/5.004_05 +patches/5.005 +patches/5.005_01 +patches/5.005_02 +patches/5.005_03 +patches/5.6.0 +ppport.h +t/db-btree.t +t/db-hash.t +t/db-recno.t +typemap +version.c diff --git a/bdb/perl/DB_File/Makefile.PL b/bdb/perl/DB_File/Makefile.PL new file mode 100644 index 00000000000..4c1565d8d01 --- /dev/null +++ b/bdb/perl/DB_File/Makefile.PL @@ -0,0 +1,330 @@ +#! perl -w + +use strict ; +use ExtUtils::MakeMaker 5.16 ; +use Config ; + +die "DB_File needs Perl 5.004_05 or better. This is $]\n" + if $] <= 5.00404; + +my $VER_INFO ; +my $LIB_DIR ; +my $INC_DIR ; +my $DB_NAME ; +my $LIBS ; +my $COMPAT185 = "" ; + +ParseCONFIG() ; + +my @files = ('DB_File.pm', glob "t/*.t") ; +UpDowngrade(@files); + +if (defined $DB_NAME) + { $LIBS = $DB_NAME } +else { + if ($^O eq 'MSWin32') + { $LIBS = '-llibdb' } + else + { $LIBS = '-ldb' } +} + +# Solaris is special. +#$LIBS .= " -lthread" if $^O eq 'solaris' ; + +# AIX is special. +$LIBS .= " -lpthread" if $^O eq 'aix' ; + +# OS2 is a special case, so check for it now. +my $OS2 = "" ; +$OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; + +WriteMakefile( + NAME => 'DB_File', + LIBS => ["-L${LIB_DIR} $LIBS"], + #MAN3PODS => {}, # Pods will be built by installman. + INC => "-I$INC_DIR", + VERSION_FROM => 'DB_File.pm', + XSPROTOARG => '-noprototypes', + DEFINE => "-D_NOT_CORE $OS2 $VER_INFO $COMPAT185", + OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', + #OPTIMIZE => '-g', + 'depend' => { 'Makefile' => 'config.in', + 'version$(OBJ_EXT)' => 'version.c'}, + 'clean' => { FILES => 'constants.h constants.xs' }, + 'macro' => { INSTALLDIRS => 'perl', my_files => "@files" }, + 'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz', + DIST_DEFAULT => 'MyDoubleCheck tardist'}, + ); + + +my @names = qw( + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED + ); + +if (eval {require ExtUtils::Constant; 1}) { + # Check the constants above all appear in @EXPORT in DB_File.pm + my %names = map { $_, 1} @names; + open F, "<DB_File.pm" or die "Cannot open DB_File.pm: $!\n"; + while (<F>) + { + last if /^\s*\@EXPORT\s+=\s+qw\(/ ; + } + + while (<F>) + { + last if /^\s*\)/ ; + /(\S+)/ ; + delete $names{$1} if defined $1 ; + } + close F ; + + if ( keys %names ) + { + my $missing = join ("\n\t", sort keys %names) ; + die "The following names are missing from \@EXPORT in DB_File.pm\n" . + "\t$missing\n" ; + } + + + ExtUtils::Constant::WriteConstants( + NAME => 'DB_File', + NAMES => \@names, + C_FILE => 'constants.h', + XS_FILE => 'constants.xs', + + ); +} +else { + use File::Copy; + copy ('fallback.h', 'constants.h') + or die "Can't copy fallback.h to constants.h: $!"; + copy ('fallback.xs', 'constants.xs') + or die "Can't copy fallback.xs to constants.xs: $!"; +} + +exit; + + +sub MY::postamble { <<'EOM' } ; + +MyDoubleCheck: + @echo Checking config.in is setup for a release + @(grep "^LIB.*/usr/local/BerkeleyDB" config.in && \ + grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in && \ + grep "^#DBNAME.*" config.in) >/dev/null || \ + (echo config.in needs fixing ; exit 1) + @echo config.in is ok + @echo + @echo Checking DB_File.xs is ok for a release. + @(perl -ne ' exit 1 if /^\s*#\s*define\s+TRACE/ ; ' DB_File.xs || \ + (echo DB_File.xs needs fixing ; exit 1)) + @echo DB_File.xs is ok + @echo + @echo Checking for $$^W in files: $(my_files) + @perl -ne ' \ + exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;' $(my_files) || \ + (echo found unexpected $$^W ; exit 1) + @echo No $$^W found. + @echo + @echo Checking for 'use vars' in files: $(my_files) + @perl -ne ' \ + exit 0 if /^__(DATA|END)__/; \ + exit 1 if /^\s*use\s+vars/;' $(my_files) || \ + (echo found unexpected "use vars"; exit 1) + @echo No 'use vars' found. + @echo + @echo All files are OK for a release. + @echo + +EOM + + + +sub ParseCONFIG +{ + my ($k, $v) ; + my @badkey = () ; + my %Info = () ; + my @Options = qw( INCLUDE LIB PREFIX HASH DBNAME COMPAT185 ) ; + my %ValidOption = map {$_, 1} @Options ; + my %Parsed = %ValidOption ; + my $CONFIG = 'config.in' ; + + print "Parsing $CONFIG...\n" ; + + # DBNAME & COMPAT185 are optional, so pretend they have + # been parsed. + delete $Parsed{'DBNAME'} ; + delete $Parsed{'COMPAT185'} ; + $Info{COMPAT185} = "No" ; + + + open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ; + while (<F>) { + s/^\s*|\s*$//g ; + next if /^\s*$/ or /^\s*#/ ; + s/\s*#\s*$// ; + + ($k, $v) = split(/\s+=\s+/, $_, 2) ; + $k = uc $k ; + if ($ValidOption{$k}) { + delete $Parsed{$k} ; + $Info{$k} = $v ; + } + else { + push(@badkey, $k) ; + } + } + close F ; + + print "Unknown keys in $CONFIG ignored [@badkey]\n" + if @badkey ; + + # check parsed values + my @missing = () ; + die "The following keys are missing from $CONFIG file: [@missing]\n" + if @missing = keys %Parsed ; + + $INC_DIR = $ENV{'DB_FILE_INCLUDE'} || $Info{'INCLUDE'} ; + $LIB_DIR = $ENV{'DB_FILE_LIB'} || $Info{'LIB'} ; + $DB_NAME = $Info{'DBNAME'} if defined $Info{'DBNAME'} ; + $COMPAT185 = "-DCOMPAT185 -DDB_LIBRARY_COMPATIBILITY_API" + if (defined $ENV{'DB_FILE_COMPAT185'} && + $ENV{'DB_FILE_COMPAT185'} =~ /^\s*(on|true|1)\s*$/i) || + $Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ; + my $PREFIX = $Info{'PREFIX'} ; + my $HASH = $Info{'HASH'} ; + + $VER_INFO = "-DmDB_Prefix_t=${PREFIX} -DmDB_Hash_t=${HASH}" ; + + print <<EOM if 0 ; + INCLUDE [$INC_DIR] + LIB [$LIB_DIR] + HASH [$HASH] + PREFIX [$PREFIX] + DBNAME [$DB_NAME] + +EOM + + print "Looks Good.\n" ; + +} + +sub UpDowngrade +{ + my @files = @_ ; + + # our is stable from 5.6.0 onward + # warnings is stable from 5.6.1 onward + + # Note: this code assumes that each statement it modifies is not + # split across multiple lines. + + + my $warn_sub ; + my $our_sub ; + + if ($] < 5.006001) { + # From: use|no warnings "blah" + # To: local ($^W) = 1; # use|no warnings "blah" + # + # and + # + # From: warnings::warnif(x,y); + # To: $^W && carp(y); # warnif -- x + $warn_sub = sub { + s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; + s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; + + s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ; + }; + } + else { + # From: local ($^W) = 1; # use|no warnings "blah" + # To: use|no warnings "blah" + # + # and + # + # From: $^W && carp(y); # warnif -- x + # To: warnings::warnif(x,y); + $warn_sub = sub { + s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; + s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ; + }; + } + + if ($] < 5.006000) { + $our_sub = sub { + if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { + my $indent = $1; + my $vars = join ' ', split /\s*,\s*/, $2; + $_ = "${indent}use vars qw($vars);\n"; + } + }; + } + else { + $our_sub = sub { + if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { + my $indent = $1; + my $vars = join ', ', split ' ', $2; + $_ = "${indent}our ($vars);\n"; + } + }; + } + + foreach (@files) + { doUpDown($our_sub, $warn_sub, $_) } +} + + +sub doUpDown +{ + my $our_sub = shift; + my $warn_sub = shift; + + local ($^I) = ".bak" ; + local (@ARGV) = shift; + + while (<>) + { + print, last if /^__(END|DATA)__/ ; + + &{ $our_sub }(); + &{ $warn_sub }(); + print ; + } + + return if eof ; + + while (<>) + { print } +} + +# end of file Makefile.PL diff --git a/bdb/perl/DB_File/README b/bdb/perl/DB_File/README new file mode 100644 index 00000000000..b09aa9d8aee --- /dev/null +++ b/bdb/perl/DB_File/README @@ -0,0 +1,458 @@ + DB_File + + Version 1.805 + + 1st Sep 2002 + + Copyright (c) 1995-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. + + +IMPORTANT NOTICE +================ + +If are using the locking technique described in older versions of +DB_File, please read the section called "Locking: The Trouble with fd" +in DB_File.pm immediately. The locking method has been found to be +unsafe. You risk corrupting your data if you continue to use it. + +DESCRIPTION +----------- + +DB_File is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 1. (DB_File can be built +version 2, 3 or 4 of Berkeley DB, but it will only support the 1.x +features), + +If you want to make use of the new features available in Berkeley DB +2.x, 3.x or 4.x, use the Perl module BerkeleyDB instead. + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. DB_File provides an interface to all three +of the database types (hash, btree and recno) currently supported by +Berkeley DB. + +For further details see the documentation included at the end of the +file DB_File.pm. + +PREREQUISITES +------------- + +Before you can build DB_File you must have the following installed on +your system: + + * Perl 5.004_05 or greater. + + * Berkeley DB. + + The official web site for Berkeley DB is http://www.sleepycat.com. + The latest version of Berkeley DB is always available there. It + is recommended that you use the most recent version available at + the Sleepycat site. + + The one exception to this advice is where you want to use DB_File + to access database files created by a third-party application, like + Sendmail or Netscape. In these cases you must build DB_File with a + compatible version of Berkeley DB. + + If you want to use Berkeley DB 2.x, you must have version 2.3.4 + or greater. If you want to use Berkeley DB 3.x or 4.x, any version + will do. For Berkeley DB 1.x, use either version 1.85 or 1.86. + + +BUILDING THE MODULE +------------------- + +Assuming you have met all the prerequisites, building the module should +be relatively straightforward. + +Step 1 : If you are running either Solaris 2.5 or HP-UX 10 and want + to use Berkeley DB version 2, 3 or 4, read either the Solaris Notes + or HP-UX Notes sections below. If you are running Linux please + read the Linux Notes section before proceeding. + +Step 2 : Edit the file config.in to suit you local installation. + Instructions are given in the file. + +Step 3 : Build and test the module using this sequence of commands: + + perl Makefile.PL + make + make test + + + NOTE: + If you have a very old version of Berkeley DB (i.e. pre 1.85), + three of the tests in the recno test harness may fail (tests 51, + 53 and 55). You can safely ignore the errors if you're never + going to use the broken functionality (recno databases with a + modified bval). Otherwise you'll have to upgrade your DB + library. + + +INSTALLATION +------------ + + make install + + +TROUBLESHOOTING +=============== + +Here are some of the common problems people encounter when building +DB_File. + +Missing db.h or libdb.a +----------------------- + +If you get an error like this: + + cc -c -I/usr/local/include -Dbool=char -DHAS_BOOL + -O2 -DVERSION=\"1.64\" -DXS_VERSION=\"1.64\" -fpic + -I/usr/local/lib/perl5/i586-linux/5.00404/CORE -DmDB_Prefix_t=size_t + -DmDB_Hash_t=u_int32_t DB_File.c + DB_File.xs:101: db.h: No such file or directory + +or this: + + LD_RUN_PATH="/lib" cc -o blib/arch/auto/DB_File/DB_File.so -shared + -L/usr/local/lib DB_File.o -L/usr/local/lib -ldb + ld: cannot open -ldb: No such file or directory + +This symptom can imply: + + 1. You don't have Berkeley DB installed on your system at all. + Solution: get & install Berkeley DB. + + 2. You do have Berkeley DB installed, but it isn't in a standard place. + Solution: Edit config.in and set the LIB and INCLUDE variables to point + to the directories where libdb.a and db.h are installed. + + +Undefined symbol db_version +--------------------------- + +DB_File seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /usr/bin/perl5.00404 -I./blib/arch -I./blib/lib + -I/usr/local/lib/perl5/i586-linux/5.00404 -I/usr/local/lib/perl5 -e 'use + Test::Harness qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/db-btree..........Can't load './blib/arch/auto/DB_File/DB_File.so' for + module DB_File: ./blib/arch/auto/DB_File/DB_File.so: undefined symbol: + db_version at /usr/local/lib/perl5/i586-linux/5.00404/DynaLoader.pm + line 166. + + at t/db-btree.t line 21 + BEGIN failed--compilation aborted at t/db-btree.t line 21. + dubious Test returned status 2 (wstat 512, 0x200) + +This error usually happens when you have both version 1 and version +2 of Berkeley DB installed on your system and DB_File attempts to +build using the db.h for Berkeley DB version 2 and the version 1 +library. Unfortunately the two versions aren't compatible with each +other. The undefined symbol error is actually caused because Berkeley +DB version 1 doesn't have the symbol db_version. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want DB_File to use. + + +Undefined symbol dbopen +----------------------- + +DB_File seems to have built correctly, but you get an error like this +when you run the test harness: + + ... + t/db-btree..........Can't load 'blib/arch/auto/DB_File/DB_File.so' for + module DB_File: blib/arch/auto/DB_File/DB_File.so: undefined symbol: + dbopen at /usr/local/lib/perl5/5.6.1/i586-linux/DynaLoader.pm line 206. + at t/db-btree.t line 23 + Compilation failed in require at t/db-btree.t line 23. + ... + +This error usually happens when you have both version 1 and a more recent +version of Berkeley DB installed on your system and DB_File attempts +to build using the db.h for Berkeley DB version 1 and the newer version +library. Unfortunately the two versions aren't compatible with each +other. The undefined symbol error is actually caused because versions +of Berkeley DB newer than version 1 doesn't have the symbol dbopen. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want DB_File to use. + + +Incompatible versions of db.h and libdb +--------------------------------------- + +BerkeleyDB seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00560 -Iblib/arch + -Iblib/lib -I/home/paul/perl/install/5.005_60/lib/5.00560/i586-linux + -I/home/paul/perl/install/5.005_60/lib/5.00560 -e 'use Test::Harness + qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/db-btree.......... + DB_File needs compatible versions of libdb & db.h + you have db.h version 2.3.7 and libdb version 2.7.5 + BEGIN failed--compilation aborted at t/db-btree.t line 21. + ... + +Another variation on the theme of having two versions of Berkeley DB on +your system. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want BerkeleyDB to use. + If you are running Linux, please read the Linux Notes section + below. + + +Linux Notes +----------- + +Newer versions of Linux (e.g. RedHat 6, SuSe 6) ship with a C library +that has version 2.x of Berkeley DB linked into it. This makes it +difficult to build this module with anything other than the version of +Berkeley DB that shipped with your Linux release. If you do try to use +a different version of Berkeley DB you will most likely get the error +described in the "Incompatible versions of db.h and libdb" section of +this file. + +To make matters worse, prior to Perl 5.6.1, the perl binary itself +*always* included the Berkeley DB library. + +If you want to use a newer version of Berkeley DB with this module, the +easiest solution is to use Perl 5.6.1 (or better) and Berkeley DB 3.x +(or better). + +There are two approaches you can use to get older versions of Perl to +work with specific versions of Berkeley DB. Both have their advantages +and disadvantages. + +The first approach will only work when you want to build a version of +Perl older than 5.6.1 along with Berkeley DB 3.x. If you want to use +Berkeley DB 2.x, you must use the next approach. This approach involves +rebuilding your existing version of Perl after applying an unofficial +patch. The "patches" directory in the this module's source distribution +contains a number of patch files. There is one patch file for every +stable version of Perl since 5.004. Apply the appropriate patch to your +Perl source tree before re-building and installing Perl from scratch. +For example, assuming you are in the top-level source directory for +Perl 5.6.0, the command below will apply the necessary patch. Remember +to replace the path shown below with one that points to this module's +patches directory. + + patch -p1 -N </path/to/DB_File/patches/5.6.0 + +Now rebuild & install perl. You should now have a perl binary that can +be used to build this module. Follow the instructions in "BUILDING THE +MODULE", remembering to set the INCLUDE and LIB variables in config.in. + + +The second approach will work with both Berkeley DB 2.x and 3.x. +Start by building Berkeley DB as a shared library. This is from +the Berkeley DB build instructions: + + Building Shared Libraries for the GNU GCC compiler + + If you're using gcc and there's no better shared library example for + your architecture, the following shared library build procedure will + probably work. + + Add the -fpic option to the CFLAGS value in the Makefile. + + Rebuild all of your .o files. This will create a Berkeley DB library + that contains .o files with PIC code. To build the shared library, + then take the following steps in the library build directory: + + % mkdir tmp + % cd tmp + % ar xv ../libdb.a + % gcc -shared -o libdb.so *.o + % mv libdb.so .. + % cd .. + % rm -rf tmp + + Note, you may have to change the gcc line depending on the + requirements of your system. + + The file libdb.so is your shared library + +Once you have built libdb.so, you will need to store it somewhere safe. + + cp libdb.so /usr/local/BerkeleyDB/lib + +If you now set the LD_PRELOAD environment variable to point to this +shared library, Perl will use it instead of the version of Berkeley DB +that shipped with your Linux distribution. + + export LD_PRELOAD=/usr/local/BerkeleyDB/lib/libdb.so + +Finally follow the instructions in "BUILDING THE MODULE" to build, +test and install this module. Don't forget to set the INCLUDE and LIB +variables in config.in. + +Remember, you will need to have the LD_PRELOAD variable set anytime you +want to use Perl with Berkeley DB. Also note that if you have LD_PRELOAD +permanently set it will affect ALL commands you execute. This may be a +problem if you run any commands that access a database created by the +version of Berkeley DB that shipped with your Linux distribution. + + +Solaris Notes +------------- + +If you are running Solaris 2.5, and you get this error when you run the +DB_File test harness: + + libc internal error: _rmutex_unlock: rmutex not held. + +you probably need to install a Sun patch. It has been reported that +Sun patch 103187-25 (or later revisions) fixes this problem. + +To find out if you have the patch installed, the command "showrev -p" +will display the patches that are currently installed on your system. + + +HP-UX 10 Notes +-------------- + +Some people running HP-UX 10 have reported getting an error like this +when building DB_File with the native HP-UX compiler. + + ld: (Warning) At least one PA 2.0 object file (DB_File.o) was detected. + The linked output may not run on a PA 1.x system. + ld: Invalid loader fixup for symbol "$000000A5". + +If this is the case for you, Berkeley DB needs to be recompiled with +the +z or +Z option and the resulting library placed in a .sl file. The +following steps should do the trick: + + 1: Configure the Berkeley DB distribution with the +z or +Z C compiler + flag: + + env "CFLAGS=+z" ../dist/configure ... + + 2: Edit the Berkeley DB Makefile and change: + + "libdb= libdb.a" to "libdb= libdb.sl". + + + 3: Build and install the Berkeley DB distribution as usual. + +HP-UX 11 Notes +-------------- + +Some people running the combination of HP-UX 11 and Berkeley DB 2.7.7 have +reported getting this error when the run the test harness for DB_File + + ... + lib/db-btree.........Can't call method "DELETE" on an undefined value at lib/db-btree.t line 216. + FAILED at test 26 + lib/db-hash..........Can't call method "DELETE" on an undefined value at lib/db-hash.t line 183. + FAILED at test 22 + ... + +The fix for this is to rebuild and install Berkeley DB with the bigfile +option disabled. + + +IRIX NOTES +---------- + +If you are running IRIX, and want to use Berkeley DB version 1, you can +get it from http://reality.sgi.com/ariel. It has the patches necessary +to compile properly on IRIX 5.3. + + +FEEDBACK +======== + +How to report a problem with DB_File. + +When reporting any problem, I need the information requested below. + + 1. The *complete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. DB_File needs Perl version 5.00405 or better. + + 2. The version of DB_File you have. + If you have successfully installed DB_File, this one-liner will + tell you: + + perl -e 'use DB_File; print qq{DB_File ver $DB_File::VERSION\n}' + + If you haven't installed DB_File then search DB_File.pm for a line + like this: + + $VERSION = "1.20" ; + + 3. The version of Berkeley DB you are using. + If you are using a version older than 1.85, think about upgrading. One + point to note if you are considering upgrading Berkeley DB - the + file formats for 1.85, 1.86, 2.0, 3.0 & 3.1 are all different. + + If you have successfully installed DB_File, this command will display + the version of Berkeley DB it was built with: + + perl -e 'use DB_File; print qq{Berkeley DB ver $DB_File::db_ver\n}' + + 4. A copy the file config.in from the DB_File main source directory. + + 5. A listing of directories where Berkeley DB is installed. + For example, if Berkeley DB is installed in /usr/BerkeleDB/lib and + /usr/BerkeleyDB/include, I need the output from running this + + ls -l /usr/BerkeleyDB/lib + ls -l /usr/BerkeleyDB/include + + 6. If you are having problems building DB_File, send me a complete log + of what happened. Start by unpacking the DB_File module into a fresh + directory and keep a log of all the steps + + [edit config.in, if necessary] + perl Makefile.PL + make + make test TEST_VERBOSE=1 + + 7. Now the difficult one. If you think you have found a bug in DB_File + and you want me to fix it, you will *greatly* enhance the chances + of me being able to track it down by sending me a small + self-contained Perl script that illustrates the problem you are + encountering. Include a summary of what you think the problem is + and a log of what happens when you run the script, in case I can't + reproduce your problem on my system. If possible, don't have the + script dependent on an existing 20Meg database. If the script you + send me can create the database itself then that is preferred. + + I realise that in some cases this is easier said than done, so if + you can only reproduce the problem in your existing script, then + you can post me that if you want. Just don't expect me to find your + problem in a hurry, or at all. :-) + + +CHANGES +------- + +See the Changes file. + +Paul Marquess <Paul.Marquess@btinternet.com> diff --git a/bdb/perl/DB_File/config.in b/bdb/perl/DB_File/config.in new file mode 100644 index 00000000000..292b09a5fb3 --- /dev/null +++ b/bdb/perl/DB_File/config.in @@ -0,0 +1,97 @@ +# Filename: config.in +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# last modified 9th Sept 1997 +# version 1.55 + +# 1. Where is the file db.h? +# +# Change the path below to point to the directory where db.h is +# installed on your system. + +INCLUDE = /usr/local/BerkeleyDB/include +#INCLUDE = /usr/local/include +#INCLUDE = /usr/include + +# 2. Where is libdb? +# +# Change the path below to point to the directory where libdb is +# installed on your system. + +LIB = /usr/local/BerkeleyDB/lib +#LIB = /usr/local/lib +#LIB = /usr/lib + +# 3. What version of Berkely DB have you got? +# +# If you have version 2.0 or greater, you can skip this question. +# +# If you have Berkeley DB 1.78 or greater you shouldn't have to +# change the definitions for PREFIX and HASH below. +# +# For older versions of Berkeley DB change both PREFIX and HASH to int. +# Version 1.71, 1.72 and 1.73 are known to need this change. +# +# If you don't know what version you have have a look in the file db.h. +# +# Search for the string "DB_VERSION_MAJOR". If it is present, you +# have Berkeley DB version 2 (or greater). +# +# If that didn't work, find the definition of the BTREEINFO typedef. +# Check the return type from the prefix element. It should look like +# this in an older copy of db.h: +# +# int (*prefix) __P((const DBT *, const DBT *)); +# +# and like this in a more recent copy: +# +# size_t (*prefix) /* prefix function */ +# __P((const DBT *, const DBT *)); +# +# Change the definition of PREFIX, below, to reflect the return type +# of the prefix function in your db.h. +# +# Now find the definition of the HASHINFO typedef. Check the return +# type of the hash element. Older versions look like this: +# +# int (*hash) __P((const void *, size_t)); +# +# newer like this: +# +# u_int32_t /* hash function */ +# (*hash) __P((const void *, size_t)); +# +# Change the definition of HASH, below, to reflect the return type of +# the hash function in your db.h. +# + +PREFIX = size_t +HASH = u_int32_t + +# 4. Is the library called libdb? +# +# If you have copies of both 1.x and 2.x Berkeley DB installed on +# your system it can sometimes be tricky to make sure you are using +# the correct one. Renaming one (or creating a symbolic link) to +# include the version number of the library can help. +# +# For example, if you have both Berkeley DB 2.3.12 and 1.85 on your +# system and you want to use the Berkeley DB version 2 library you +# could rename the version 2 library from libdb.a to libdb-2.3.12.a and +# change the DBNAME line below to look like this: +# +# DBNAME = -ldb-2.3.12 +# +# That will ensure you are linking the correct version of the DB +# library. +# +# Note: If you are building this module with Win32, -llibdb will be +# used by default. +# +# If you have changed the name of the library, uncomment the line +# below (by removing the leading #) and edit the line to use the name +# you have picked. + +#DBNAME = -ldb-2.4.10 + +# end of file config.in diff --git a/bdb/perl/DB_File/dbinfo b/bdb/perl/DB_File/dbinfo new file mode 100644 index 00000000000..af2c45facf5 --- /dev/null +++ b/bdb/perl/DB_File/dbinfo @@ -0,0 +1,112 @@ +#!/usr/local/bin/perl + +# Name: dbinfo -- identify berkeley DB version used to create +# a database file +# +# Author: Paul Marquess <Paul.Marquess@btinternet.com> +# Version: 1.03 +# Date 17th September 2000 +# +# Copyright (c) 1998-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. + +# Todo: Print more stats on a db file, e.g. no of records +# add log/txn/lock files + +use strict ; + +my %Data = + ( + 0x053162 => { + Type => "Btree", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "Unknown (older than 1.71)", + 3 => "1.71 -> 1.85, 1.86", + 4 => "Unknown", + 5 => "2.0.0 -> 2.3.0", + 6 => "2.3.1 -> 2.7.7", + 7 => "3.0.x", + 8 => "3.1.x -> 4.0.x", + 9 => "4.1.x or greater", + } + }, + 0x061561 => { + Type => "Hash", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "1.71 -> 1.85", + 3 => "1.86", + 4 => "2.0.0 -> 2.1.0", + 5 => "2.2.6 -> 2.7.7", + 6 => "3.0.x", + 7 => "3.1.x -> 4.0.x", + 8 => "4.1.x or greater", + } + }, + 0x042253 => { + Type => "Queue", + Versions => + { + 1 => "3.0.x", + 2 => "3.1.x", + 3 => "3.2.x -> 4.0.x", + 4 => "4.1.x or greater", + } + }, + ) ; + +die "Usage: dbinfo file\n" unless @ARGV == 1 ; + +print "testing file $ARGV[0]...\n\n" ; +open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ; + +my $buff ; +read F, $buff, 20 ; + +my (@info) = unpack("NNNNN", $buff) ; +my (@info1) = unpack("VVVVV", $buff) ; +my ($magic, $version, $endian) ; + +if ($Data{$info[0]}) # first try DB 1.x format +{ + $magic = $info[0] ; + $version = $info[1] ; + $endian = "Unknown" ; +} +elsif ($Data{$info[3]}) # next DB 2.x big endian +{ + $magic = $info[3] ; + $version = $info[4] ; + $endian = "Big Endian" ; +} +elsif ($Data{$info1[3]}) # next DB 2.x little endian +{ + $magic = $info1[3] ; + $version = $info1[4] ; + $endian = "Little Endian" ; +} +else + { die "not a Berkeley DB database file.\n" } + +my $type = $Data{$magic} ; +$magic = sprintf "%06X", $magic ; + +my $ver_string = "Unknown" ; +$ver_string = $type->{Versions}{$version} + if defined $type->{Versions}{$version} ; + +print <<EOM ; +File Type: Berkeley DB $type->{Type} file. +File Version ID: $version +Built with Berkeley DB: $ver_string +Byte Order: $endian +Magic: $magic +EOM + +close F ; + +exit ; diff --git a/bdb/perl/DB_File/fallback.h b/bdb/perl/DB_File/fallback.h new file mode 100644 index 00000000000..0213308a0ee --- /dev/null +++ b/bdb/perl/DB_File/fallback.h @@ -0,0 +1,455 @@ +#define PERL_constant_NOTFOUND 1 +#define PERL_constant_NOTDEF 2 +#define PERL_constant_ISIV 3 +#define PERL_constant_ISNO 4 +#define PERL_constant_ISNV 5 +#define PERL_constant_ISPV 6 +#define PERL_constant_ISPVN 7 +#define PERL_constant_ISSV 8 +#define PERL_constant_ISUNDEF 9 +#define PERL_constant_ISUV 10 +#define PERL_constant_ISYES 11 + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif + +static int +constant_6 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_TXN R_LAST R_NEXT R_PREV */ + /* Offset 2 gives the best switch position. */ + switch (name[2]) { + case 'L': + if (memEQ(name, "R_LAST", 6)) { + /* ^ */ +#ifdef R_LAST + *iv_return = R_LAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "R_NEXT", 6)) { + /* ^ */ +#ifdef R_NEXT + *iv_return = R_NEXT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "R_PREV", 6)) { + /* ^ */ +#ifdef R_PREV + *iv_return = R_PREV; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_TXN", 6)) { + /* ^ */ +#ifdef DB_TXN + *iv_return = DB_TXN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_7 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_LOCK R_FIRST R_NOKEY */ + /* Offset 3 gives the best switch position. */ + switch (name[3]) { + case 'I': + if (memEQ(name, "R_FIRST", 7)) { + /* ^ */ +#ifdef R_FIRST + *iv_return = R_FIRST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_LOCK", 7)) { + /* ^ */ +#ifdef DB_LOCK + *iv_return = DB_LOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "R_NOKEY", 7)) { + /* ^ */ +#ifdef R_NOKEY + *iv_return = R_NOKEY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_8 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_SHMEM R_CURSOR R_IAFTER */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case 'M': + if (memEQ(name, "DB_SHMEM", 8)) { + /* ^ */ +#ifdef DB_SHMEM + *iv_return = DB_SHMEM; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "R_CURSOR", 8)) { + /* ^ */ +#ifdef R_CURSOR + *iv_return = R_CURSOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "R_IAFTER", 8)) { + /* ^ */ +#ifdef R_IAFTER + *iv_return = R_IAFTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_9 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + HASHMAGIC RET_ERROR R_IBEFORE */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'I': + if (memEQ(name, "HASHMAGIC", 9)) { + /* ^ */ +#ifdef HASHMAGIC + *iv_return = HASHMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "RET_ERROR", 9)) { + /* ^ */ +#ifdef RET_ERROR + *iv_return = RET_ERROR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "R_IBEFORE", 9)) { + /* ^ */ +#ifdef R_IBEFORE + *iv_return = R_IBEFORE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_10 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + BTREEMAGIC R_FIXEDLEN R_SNAPSHOT __R_UNUSED */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case 'E': + if (memEQ(name, "R_FIXEDLEN", 10)) { + /* ^ */ +#ifdef R_FIXEDLEN + *iv_return = R_FIXEDLEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "BTREEMAGIC", 10)) { + /* ^ */ +#ifdef BTREEMAGIC + *iv_return = BTREEMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "__R_UNUSED", 10)) { + /* ^ */ +#ifdef __R_UNUSED + *iv_return = __R_UNUSED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "R_SNAPSHOT", 10)) { + /* ^ */ +#ifdef R_SNAPSHOT + *iv_return = R_SNAPSHOT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_11 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + HASHVERSION RET_SPECIAL RET_SUCCESS R_RECNOSYNC R_SETCURSOR */ + /* Offset 10 gives the best switch position. */ + switch (name[10]) { + case 'C': + if (memEQ(name, "R_RECNOSYNC", 11)) { + /* ^ */ +#ifdef R_RECNOSYNC + *iv_return = R_RECNOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "RET_SPECIAL", 11)) { + /* ^ */ +#ifdef RET_SPECIAL + *iv_return = RET_SPECIAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "HASHVERSION", 11)) { + /* ^ */ +#ifdef HASHVERSION + *iv_return = HASHVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "R_SETCURSOR", 11)) { + /* ^ */ +#ifdef R_SETCURSOR + *iv_return = R_SETCURSOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "RET_SUCCESS", 11)) { + /* ^ */ +#ifdef RET_SUCCESS + *iv_return = RET_SUCCESS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { + /* Initially switch on the length of the name. */ + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!bleedperl -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +my $types = {map {($_, 1)} qw(IV)}; +my @names = (qw(BTREEMAGIC BTREEVERSION DB_LOCK DB_SHMEM DB_TXN HASHMAGIC + HASHVERSION MAX_PAGE_NUMBER MAX_PAGE_OFFSET MAX_REC_NUMBER + RET_ERROR RET_SPECIAL RET_SUCCESS R_CURSOR R_DUP R_FIRST + R_FIXEDLEN R_IAFTER R_IBEFORE R_LAST R_NEXT R_NOKEY + R_NOOVERWRITE R_PREV R_RECNOSYNC R_SETCURSOR R_SNAPSHOT + __R_UNUSED)); + +print constant_types(); # macro defs +foreach (C_constant ("DB_File", 'constant', 'IV', $types, undef, 3, @names) ) { + print $_, "\n"; # C constant subs +} +print "#### XS Section:\n"; +print XS_constant ("DB_File", $types); +__END__ + */ + + switch (len) { + case 5: + if (memEQ(name, "R_DUP", 5)) { +#ifdef R_DUP + *iv_return = R_DUP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 6: + return constant_6 (aTHX_ name, iv_return); + break; + case 7: + return constant_7 (aTHX_ name, iv_return); + break; + case 8: + return constant_8 (aTHX_ name, iv_return); + break; + case 9: + return constant_9 (aTHX_ name, iv_return); + break; + case 10: + return constant_10 (aTHX_ name, iv_return); + break; + case 11: + return constant_11 (aTHX_ name, iv_return); + break; + case 12: + if (memEQ(name, "BTREEVERSION", 12)) { +#ifdef BTREEVERSION + *iv_return = BTREEVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 13: + if (memEQ(name, "R_NOOVERWRITE", 13)) { +#ifdef R_NOOVERWRITE + *iv_return = R_NOOVERWRITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 14: + if (memEQ(name, "MAX_REC_NUMBER", 14)) { +#ifdef MAX_REC_NUMBER + *iv_return = MAX_REC_NUMBER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 15: + /* Names all of length 15. */ + /* MAX_PAGE_NUMBER MAX_PAGE_OFFSET */ + /* Offset 9 gives the best switch position. */ + switch (name[9]) { + case 'N': + if (memEQ(name, "MAX_PAGE_NUMBER", 15)) { + /* ^ */ +#ifdef MAX_PAGE_NUMBER + *iv_return = MAX_PAGE_NUMBER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "MAX_PAGE_OFFSET", 15)) { + /* ^ */ +#ifdef MAX_PAGE_OFFSET + *iv_return = MAX_PAGE_OFFSET; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + break; + } + return PERL_constant_NOTFOUND; +} + diff --git a/bdb/perl/DB_File/fallback.xs b/bdb/perl/DB_File/fallback.xs new file mode 100644 index 00000000000..8650cdf7646 --- /dev/null +++ b/bdb/perl/DB_File/fallback.xs @@ -0,0 +1,88 @@ +void +constant(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; + IV iv; + /* NV nv; Uncomment this if you need to return NVs */ + /* const char *pv; Uncomment this if you need to return PVs */ + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: + /* Change this to constant(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ + type = constant(aTHX_ s, len, &iv); + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = sv_2mortal(newSVpvf("%s is not a valid DB_File macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined DB_File macro %s, used", s)); + PUSHs(sv); + break; + case PERL_constant_ISIV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHi(iv); + break; + /* Uncomment this if you need to return NOs + case PERL_constant_ISNO: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_no); + break; */ + /* Uncomment this if you need to return NVs + case PERL_constant_ISNV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHn(nv); + break; */ + /* Uncomment this if you need to return PVs + case PERL_constant_ISPV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, strlen(pv)); + break; */ + /* Uncomment this if you need to return PVNs + case PERL_constant_ISPVN: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, iv); + break; */ + /* Uncomment this if you need to return SVs + case PERL_constant_ISSV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(sv); + break; */ + /* Uncomment this if you need to return UNDEFs + case PERL_constant_ISUNDEF: + break; */ + /* Uncomment this if you need to return UVs + case PERL_constant_ISUV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHu((UV)iv); + break; */ + /* Uncomment this if you need to return YESs + case PERL_constant_ISYES: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_yes); + break; */ + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing DB_File macro %s, used", + type, s)); + PUSHs(sv); + } diff --git a/bdb/perl/DB_File/hints/dynixptx.pl b/bdb/perl/DB_File/hints/dynixptx.pl new file mode 100644 index 00000000000..bb5ffa56e6b --- /dev/null +++ b/bdb/perl/DB_File/hints/dynixptx.pl @@ -0,0 +1,3 @@ +# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug + +$self->{LIBS} = ['-lm -lc']; diff --git a/bdb/perl/DB_File/hints/sco.pl b/bdb/perl/DB_File/hints/sco.pl new file mode 100644 index 00000000000..ff604409496 --- /dev/null +++ b/bdb/perl/DB_File/hints/sco.pl @@ -0,0 +1,2 @@ +# osr5 needs to explicitly link against libc to pull in some static symbols +$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ; diff --git a/bdb/perl/DB_File/patches/5.004 b/bdb/perl/DB_File/patches/5.004 new file mode 100644 index 00000000000..143ec95afbc --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004 @@ -0,0 +1,44 @@ +diff perl5.004.orig/Configure perl5.004/Configure +190a191 +> perllibs='' +9904a9906,9913 +> : Remove libraries needed only for extensions +> : The appropriate ext/Foo/Makefile.PL will add them back in, if +> : necessary. +> set X `echo " $libs " | +> sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` +> shift +> perllibs="$*" +> +10372a10382 +> perllibs='$perllibs' +diff perl5.004.orig/Makefile.SH perl5.004/Makefile.SH +122c122 +< libs = $libs $cryptlib +--- +> libs = $perllibs $cryptlib +Common subdirectories: perl5.004.orig/Porting and perl5.004/Porting +Common subdirectories: perl5.004.orig/cygwin32 and perl5.004/cygwin32 +Common subdirectories: perl5.004.orig/eg and perl5.004/eg +Common subdirectories: perl5.004.orig/emacs and perl5.004/emacs +Common subdirectories: perl5.004.orig/ext and perl5.004/ext +Common subdirectories: perl5.004.orig/h2pl and perl5.004/h2pl +Common subdirectories: perl5.004.orig/hints and perl5.004/hints +Common subdirectories: perl5.004.orig/lib and perl5.004/lib +diff perl5.004.orig/myconfig perl5.004/myconfig +38c38 +< libs=$libs +--- +> libs=$perllibs +Common subdirectories: perl5.004.orig/os2 and perl5.004/os2 +diff perl5.004.orig/patchlevel.h perl5.004/patchlevel.h +40a41 +> ,"NODB-1.0 - remove -ldb from core perl binary." +Common subdirectories: perl5.004.orig/plan9 and perl5.004/plan9 +Common subdirectories: perl5.004.orig/pod and perl5.004/pod +Common subdirectories: perl5.004.orig/qnx and perl5.004/qnx +Common subdirectories: perl5.004.orig/t and perl5.004/t +Common subdirectories: perl5.004.orig/utils and perl5.004/utils +Common subdirectories: perl5.004.orig/vms and perl5.004/vms +Common subdirectories: perl5.004.orig/win32 and perl5.004/win32 +Common subdirectories: perl5.004.orig/x2p and perl5.004/x2p diff --git a/bdb/perl/DB_File/patches/5.004_01 b/bdb/perl/DB_File/patches/5.004_01 new file mode 100644 index 00000000000..1b05eb4e02b --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_01 @@ -0,0 +1,217 @@ +diff -rc perl5.004_01.orig/Configure perl5.004_01/Configure +*** perl5.004_01.orig/Configure Wed Jun 11 00:28:03 1997 +--- perl5.004_01/Configure Sun Nov 12 22:12:35 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9907,9912 **** +--- 9908,9921 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10375,10380 **** +--- 10384,10390 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_01.orig/Makefile.SH perl5.004_01/Makefile.SH +*** perl5.004_01.orig/Makefile.SH Thu Jun 12 23:27:56 1997 +--- perl5.004_01/Makefile.SH Sun Nov 12 22:12:35 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_01.orig/lib/ExtUtils/Embed.pm perl5.004_01/lib/ExtUtils/Embed.pm +*** perl5.004_01.orig/lib/ExtUtils/Embed.pm Wed Apr 2 22:12:04 1997 +--- perl5.004_01/lib/ExtUtils/Embed.pm Sun Nov 12 22:12:35 2000 +*************** +*** 170,176 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 170,176 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_01.orig/lib/ExtUtils/Liblist.pm perl5.004_01/lib/ExtUtils/Liblist.pm +*** perl5.004_01.orig/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997 +--- perl5.004_01/lib/ExtUtils/Liblist.pm Sun Nov 12 22:13:27 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm perl5.004_01/lib/ExtUtils/MM_Unix.pm +*** perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997 +--- perl5.004_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:12:35 2000 +*************** +*** 2137,2143 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2137,2143 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_01.orig/myconfig perl5.004_01/myconfig +*** perl5.004_01.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_01/myconfig Sun Nov 12 22:12:35 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_01.orig/patchlevel.h perl5.004_01/patchlevel.h +*** perl5.004_01.orig/patchlevel.h Wed Jun 11 03:06:10 1997 +--- perl5.004_01/patchlevel.h Sun Nov 12 22:12:35 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.004_02 b/bdb/perl/DB_File/patches/5.004_02 new file mode 100644 index 00000000000..238f8737941 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_02 @@ -0,0 +1,217 @@ +diff -rc perl5.004_02.orig/Configure perl5.004_02/Configure +*** perl5.004_02.orig/Configure Thu Aug 7 15:08:44 1997 +--- perl5.004_02/Configure Sun Nov 12 22:06:24 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_02.orig/Makefile.SH perl5.004_02/Makefile.SH +*** perl5.004_02.orig/Makefile.SH Thu Aug 7 13:10:53 1997 +--- perl5.004_02/Makefile.SH Sun Nov 12 22:06:24 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_02.orig/lib/ExtUtils/Embed.pm perl5.004_02/lib/ExtUtils/Embed.pm +*** perl5.004_02.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_02/lib/ExtUtils/Embed.pm Sun Nov 12 22:06:24 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_02.orig/lib/ExtUtils/Liblist.pm perl5.004_02/lib/ExtUtils/Liblist.pm +*** perl5.004_02.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_02/lib/ExtUtils/Liblist.pm Sun Nov 12 22:06:24 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm perl5.004_02/lib/ExtUtils/MM_Unix.pm +*** perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm Tue Aug 5 14:28:08 1997 +--- perl5.004_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:06:25 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_02.orig/myconfig perl5.004_02/myconfig +*** perl5.004_02.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_02/myconfig Sun Nov 12 22:06:25 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_02.orig/patchlevel.h perl5.004_02/patchlevel.h +*** perl5.004_02.orig/patchlevel.h Fri Aug 1 15:07:34 1997 +--- perl5.004_02/patchlevel.h Sun Nov 12 22:06:25 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.004_03 b/bdb/perl/DB_File/patches/5.004_03 new file mode 100644 index 00000000000..06331eac922 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_03 @@ -0,0 +1,223 @@ +diff -rc perl5.004_03.orig/Configure perl5.004_03/Configure +*** perl5.004_03.orig/Configure Wed Aug 13 16:09:46 1997 +--- perl5.004_03/Configure Sun Nov 12 21:56:18 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.004_03: Configure.orig +diff -rc perl5.004_03.orig/Makefile.SH perl5.004_03/Makefile.SH +*** perl5.004_03.orig/Makefile.SH Mon Aug 18 19:24:29 1997 +--- perl5.004_03/Makefile.SH Sun Nov 12 21:56:18 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.004_03: Makefile.SH.orig +diff -rc perl5.004_03.orig/lib/ExtUtils/Embed.pm perl5.004_03/lib/ExtUtils/Embed.pm +*** perl5.004_03.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_03/lib/ExtUtils/Embed.pm Sun Nov 12 21:56:18 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_03.orig/lib/ExtUtils/Liblist.pm perl5.004_03/lib/ExtUtils/Liblist.pm +*** perl5.004_03.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_03/lib/ExtUtils/Liblist.pm Sun Nov 12 21:57:17 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.orig +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.rej +diff -rc perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm perl5.004_03/lib/ExtUtils/MM_Unix.pm +*** perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm Mon Aug 18 19:16:12 1997 +--- perl5.004_03/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:56:19 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.004_03/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.004_03.orig/myconfig perl5.004_03/myconfig +*** perl5.004_03.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_03/myconfig Sun Nov 12 21:56:19 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_03.orig/patchlevel.h perl5.004_03/patchlevel.h +*** perl5.004_03.orig/patchlevel.h Wed Aug 13 11:42:01 1997 +--- perl5.004_03/patchlevel.h Sun Nov 12 21:56:19 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + +Only in perl5.004_03: patchlevel.h.orig diff --git a/bdb/perl/DB_File/patches/5.004_04 b/bdb/perl/DB_File/patches/5.004_04 new file mode 100644 index 00000000000..a227dc700d9 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_04 @@ -0,0 +1,209 @@ +diff -rc perl5.004_04.orig/Configure perl5.004_04/Configure +*** perl5.004_04.orig/Configure Fri Oct 3 18:57:39 1997 +--- perl5.004_04/Configure Sun Nov 12 21:50:51 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9910,9915 **** +--- 9911,9924 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10378,10383 **** +--- 10387,10393 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_04.orig/Makefile.SH perl5.004_04/Makefile.SH +*** perl5.004_04.orig/Makefile.SH Wed Oct 15 10:33:16 1997 +--- perl5.004_04/Makefile.SH Sun Nov 12 21:50:51 2000 +*************** +*** 129,135 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 129,135 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_04.orig/lib/ExtUtils/Embed.pm perl5.004_04/lib/ExtUtils/Embed.pm +*** perl5.004_04.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_04/lib/ExtUtils/Embed.pm Sun Nov 12 21:50:51 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_04.orig/lib/ExtUtils/Liblist.pm perl5.004_04/lib/ExtUtils/Liblist.pm +*** perl5.004_04.orig/lib/ExtUtils/Liblist.pm Tue Sep 9 17:41:32 1997 +--- perl5.004_04/lib/ExtUtils/Liblist.pm Sun Nov 12 21:51:33 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 189,195 **** + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 189,195 ---- + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 539,545 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 539,545 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm perl5.004_04/lib/ExtUtils/MM_Unix.pm +*** perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm Wed Oct 8 14:13:51 1997 +--- perl5.004_04/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:50:51 2000 +*************** +*** 2229,2235 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2229,2235 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_04.orig/myconfig perl5.004_04/myconfig +*** perl5.004_04.orig/myconfig Mon Oct 6 18:26:49 1997 +--- perl5.004_04/myconfig Sun Nov 12 21:50:51 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_04.orig/patchlevel.h perl5.004_04/patchlevel.h +*** perl5.004_04.orig/patchlevel.h Wed Oct 15 10:55:19 1997 +--- perl5.004_04/patchlevel.h Sun Nov 12 21:50:51 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.004_05 b/bdb/perl/DB_File/patches/5.004_05 new file mode 100644 index 00000000000..51c8bf35009 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_05 @@ -0,0 +1,209 @@ +diff -rc perl5.004_05.orig/Configure perl5.004_05/Configure +*** perl5.004_05.orig/Configure Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Configure Sun Nov 12 21:36:25 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 10164,10169 **** +--- 10165,10178 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10648,10653 **** +--- 10657,10663 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_05.orig/Makefile.SH perl5.004_05/Makefile.SH +*** perl5.004_05.orig/Makefile.SH Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Makefile.SH Sun Nov 12 21:36:25 2000 +*************** +*** 151,157 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 151,157 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_05.orig/lib/ExtUtils/Embed.pm perl5.004_05/lib/ExtUtils/Embed.pm +*** perl5.004_05.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_05/lib/ExtUtils/Embed.pm Sun Nov 12 21:36:25 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_05.orig/lib/ExtUtils/Liblist.pm perl5.004_05/lib/ExtUtils/Liblist.pm +*** perl5.004_05.orig/lib/ExtUtils/Liblist.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/Liblist.pm Sun Nov 12 21:45:31 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 590,596 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 590,596 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm perl5.004_05/lib/ExtUtils/MM_Unix.pm +*** perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:36:25 2000 +*************** +*** 2246,2252 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2246,2252 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_05.orig/myconfig perl5.004_05/myconfig +*** perl5.004_05.orig/myconfig Thu Jan 6 22:05:55 2000 +--- perl5.004_05/myconfig Sun Nov 12 21:43:54 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_05.orig/patchlevel.h perl5.004_05/patchlevel.h +*** perl5.004_05.orig/patchlevel.h Thu Jan 6 22:05:48 2000 +--- perl5.004_05/patchlevel.h Sun Nov 12 21:36:25 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005 b/bdb/perl/DB_File/patches/5.005 new file mode 100644 index 00000000000..effee3e8275 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005 @@ -0,0 +1,209 @@ +diff -rc perl5.005.orig/Configure perl5.005/Configure +*** perl5.005.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005/Configure Sun Nov 12 21:30:40 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005.orig/Makefile.SH perl5.005/Makefile.SH +*** perl5.005.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005/Makefile.SH Sun Nov 12 21:30:40 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005.orig/lib/ExtUtils/Embed.pm perl5.005/lib/ExtUtils/Embed.pm +*** perl5.005.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005/lib/ExtUtils/Embed.pm Sun Nov 12 21:30:40 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005.orig/lib/ExtUtils/Liblist.pm perl5.005/lib/ExtUtils/Liblist.pm +*** perl5.005.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005/lib/ExtUtils/Liblist.pm Sun Nov 12 21:30:40 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005.orig/lib/ExtUtils/MM_Unix.pm perl5.005/lib/ExtUtils/MM_Unix.pm +*** perl5.005.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:30:41 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005.orig/myconfig perl5.005/myconfig +*** perl5.005.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005/myconfig Sun Nov 12 21:30:41 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005.orig/patchlevel.h perl5.005/patchlevel.h +*** perl5.005.orig/patchlevel.h Wed Jul 22 19:22:01 1998 +--- perl5.005/patchlevel.h Sun Nov 12 21:30:41 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005_01 b/bdb/perl/DB_File/patches/5.005_01 new file mode 100644 index 00000000000..2a05dd545f6 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005_01 @@ -0,0 +1,209 @@ +diff -rc perl5.005_01.orig/Configure perl5.005_01/Configure +*** perl5.005_01.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005_01/Configure Sun Nov 12 20:55:58 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_01.orig/Makefile.SH perl5.005_01/Makefile.SH +*** perl5.005_01.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_01/Makefile.SH Sun Nov 12 20:55:58 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_01.orig/lib/ExtUtils/Embed.pm perl5.005_01/lib/ExtUtils/Embed.pm +*** perl5.005_01.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_01/lib/ExtUtils/Embed.pm Sun Nov 12 20:55:58 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_01.orig/lib/ExtUtils/Liblist.pm perl5.005_01/lib/ExtUtils/Liblist.pm +*** perl5.005_01.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005_01/lib/ExtUtils/Liblist.pm Sun Nov 12 20:55:58 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm perl5.005_01/lib/ExtUtils/MM_Unix.pm +*** perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:55:58 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005_01.orig/myconfig perl5.005_01/myconfig +*** perl5.005_01.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_01/myconfig Sun Nov 12 20:55:58 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_01.orig/patchlevel.h perl5.005_01/patchlevel.h +*** perl5.005_01.orig/patchlevel.h Mon Jan 3 11:07:45 2000 +--- perl5.005_01/patchlevel.h Sun Nov 12 20:55:58 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005_02 b/bdb/perl/DB_File/patches/5.005_02 new file mode 100644 index 00000000000..5dd57ddc03f --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005_02 @@ -0,0 +1,264 @@ +diff -rc perl5.005_02.orig/Configure perl5.005_02/Configure +*** perl5.005_02.orig/Configure Mon Jan 3 11:12:20 2000 +--- perl5.005_02/Configure Sun Nov 12 20:50:51 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11334,11339 **** +--- 11335,11348 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11859,11864 **** +--- 11868,11874 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.005_02: Configure.orig +diff -rc perl5.005_02.orig/Makefile.SH perl5.005_02/Makefile.SH +*** perl5.005_02.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_02/Makefile.SH Sun Nov 12 20:50:51 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.005_02: Makefile.SH.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/Embed.pm perl5.005_02/lib/ExtUtils/Embed.pm +*** perl5.005_02.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_02/lib/ExtUtils/Embed.pm Sun Nov 12 20:50:51 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_02.orig/lib/ExtUtils/Liblist.pm perl5.005_02/lib/ExtUtils/Liblist.pm +*** perl5.005_02.orig/lib/ExtUtils/Liblist.pm Mon Jan 3 11:12:21 2000 +--- perl5.005_02/lib/ExtUtils/Liblist.pm Sun Nov 12 20:50:51 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 333,339 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 333,339 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 623,629 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 623,629 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +*************** +*** 666,672 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 666,672 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 676,682 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 676,682 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +Only in perl5.005_02/lib/ExtUtils: Liblist.pm.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm perl5.005_02/lib/ExtUtils/MM_Unix.pm +*** perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:50:51 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.005_02/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.005_02.orig/myconfig perl5.005_02/myconfig +*** perl5.005_02.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_02/myconfig Sun Nov 12 20:50:51 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_02.orig/patchlevel.h perl5.005_02/patchlevel.h +*** perl5.005_02.orig/patchlevel.h Mon Jan 3 11:12:19 2000 +--- perl5.005_02/patchlevel.h Sun Nov 12 20:50:51 2000 +*************** +*** 40,45 **** +--- 40,46 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005_03 b/bdb/perl/DB_File/patches/5.005_03 new file mode 100644 index 00000000000..115f9f5b909 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005_03 @@ -0,0 +1,250 @@ +diff -rc perl5.005_03.orig/Configure perl5.005_03/Configure +*** perl5.005_03.orig/Configure Sun Mar 28 17:12:57 1999 +--- perl5.005_03/Configure Sun Sep 17 22:19:16 2000 +*************** +*** 208,213 **** +--- 208,214 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11642,11647 **** +--- 11643,11656 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 12183,12188 **** +--- 12192,12198 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_03.orig/Makefile.SH perl5.005_03/Makefile.SH +*** perl5.005_03.orig/Makefile.SH Thu Mar 4 02:35:25 1999 +--- perl5.005_03/Makefile.SH Sun Sep 17 22:21:01 2000 +*************** +*** 58,67 **** + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +--- 58,67 ---- + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $perllibs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $perllibs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +*************** +*** 155,161 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 155,161 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_03.orig/lib/ExtUtils/Embed.pm perl5.005_03/lib/ExtUtils/Embed.pm +*** perl5.005_03.orig/lib/ExtUtils/Embed.pm Wed Jan 6 02:17:50 1999 +--- perl5.005_03/lib/ExtUtils/Embed.pm Sun Sep 17 22:19:16 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_03.orig/lib/ExtUtils/Liblist.pm perl5.005_03/lib/ExtUtils/Liblist.pm +*** perl5.005_03.orig/lib/ExtUtils/Liblist.pm Wed Jan 6 02:17:47 1999 +--- perl5.005_03/lib/ExtUtils/Liblist.pm Sun Sep 17 22:19:16 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 336,342 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 336,342 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 626,632 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 626,632 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 670,676 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 670,676 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 680,686 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 680,686 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -rc perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm perl5.005_03/lib/ExtUtils/MM_Unix.pm +*** perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm Fri Mar 5 00:34:20 1999 +--- perl5.005_03/lib/ExtUtils/MM_Unix.pm Sun Sep 17 22:19:16 2000 +*************** +*** 2284,2290 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2284,2290 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { diff --git a/bdb/perl/DB_File/patches/5.6.0 b/bdb/perl/DB_File/patches/5.6.0 new file mode 100644 index 00000000000..1f9b3b620de --- /dev/null +++ b/bdb/perl/DB_File/patches/5.6.0 @@ -0,0 +1,294 @@ +diff -cr perl-5.6.0.orig/Configure perl-5.6.0/Configure +*** perl-5.6.0.orig/Configure Wed Mar 22 20:36:37 2000 +--- perl-5.6.0/Configure Sun Sep 17 23:40:15 2000 +*************** +*** 217,222 **** +--- 217,223 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 14971,14976 **** +--- 14972,14985 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 15640,15645 **** +--- 15649,15655 ---- + path_sep='$path_sep' + perl5='$perl5' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -cr perl-5.6.0.orig/Makefile.SH perl-5.6.0/Makefile.SH +*** perl-5.6.0.orig/Makefile.SH Sat Mar 11 16:05:24 2000 +--- perl-5.6.0/Makefile.SH Sun Sep 17 23:40:15 2000 +*************** +*** 70,76 **** + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $libs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +--- 70,76 ---- + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +*************** +*** 176,182 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 176,182 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +*************** +*** 333,339 **** + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $libs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +--- 333,339 ---- + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $perllibs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +diff -cr perl-5.6.0.orig/lib/ExtUtils/Embed.pm perl-5.6.0/lib/ExtUtils/Embed.pm +*** perl-5.6.0.orig/lib/ExtUtils/Embed.pm Sun Jan 23 12:08:32 2000 +--- perl-5.6.0/lib/ExtUtils/Embed.pm Sun Sep 17 23:40:15 2000 +*************** +*** 193,199 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 193,199 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -cr perl-5.6.0.orig/lib/ExtUtils/Liblist.pm perl-5.6.0/lib/ExtUtils/Liblist.pm +*** perl-5.6.0.orig/lib/ExtUtils/Liblist.pm Wed Mar 22 16:16:31 2000 +--- perl-5.6.0/lib/ExtUtils/Liblist.pm Sun Sep 17 23:40:15 2000 +*************** +*** 17,34 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 17,34 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 198,204 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 198,204 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 338,344 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 338,344 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 624,630 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 624,630 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 668,674 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 668,674 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 678,684 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 678,684 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -cr perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm perl-5.6.0/lib/ExtUtils/MM_Unix.pm +*** perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm Thu Mar 2 17:52:52 2000 +--- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Sun Sep 17 23:40:15 2000 +*************** +*** 2450,2456 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2450,2456 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -cr perl-5.6.0.orig/myconfig.SH perl-5.6.0/myconfig.SH +*** perl-5.6.0.orig/myconfig.SH Sat Feb 26 06:34:49 2000 +--- perl-5.6.0/myconfig.SH Sun Sep 17 23:41:17 2000 +*************** +*** 48,54 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 48,54 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -cr perl-5.6.0.orig/patchlevel.h perl-5.6.0/patchlevel.h +*** perl-5.6.0.orig/patchlevel.h Wed Mar 22 20:23:11 2000 +--- perl-5.6.0/patchlevel.h Sun Sep 17 23:40:15 2000 +*************** +*** 70,75 **** +--- 70,76 ---- + #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/ppport.h b/bdb/perl/DB_File/ppport.h new file mode 100644 index 00000000000..0887c2159a9 --- /dev/null +++ b/bdb/perl/DB_File/ppport.h @@ -0,0 +1,329 @@ +/* This file is Based on output from + * Perl/Pollution/Portability Version 2.0000 */ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef PERL_REVISION +# ifndef __PATCHLEVEL_H_INCLUDED__ +# include "patchlevel.h" +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +#ifndef ERRSV +# define ERRSV perl_get_sv("@",FALSE) +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_defgv defgv +# define PL_dirty dirty +# define PL_hints hints +# define PL_na na +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stdingv stdingv +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +/* Replace: 0 */ +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + +#ifndef PTR2IV +# define PTR2IV(d) (IV)(d) +#endif + +#ifndef INT2PTR +# define INT2PTR(any,d) (any)(d) +#endif + +#ifndef dTHR +# ifdef WIN32 +# define dTHR extern int Perl___notused +# else +# define dTHR extern int errno +# endif +#endif + +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) +#endif + +#ifndef newSVpvn +# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) +#endif + +#ifndef newRV_inc +/* Replace: 1 */ +# define newRV_inc(sv) newRV(sv) +/* Replace: 0 */ +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef newRV_noinc +# ifdef __GNUC__ +# define newRV_noinc(sv) \ + ({ \ + SV *nsv = (SV*)newRV(sv); \ + SvREFCNT_dec(sv); \ + nsv; \ + }) +# else +# if defined(CRIPPLED_CC) || defined(USE_THREADS) +static SV * newRV_noinc (SV * sv) +{ + SV *nsv = (SV*)newRV(sv); + SvREFCNT_dec(sv); + return nsv; +} +# else +# define newRV_noinc(sv) \ + ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv) +# endif +# endif +#endif + +/* Provide: newCONSTSUB */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63)) + +#if defined(NEED_newCONSTSUB) +static +#else +extern void newCONSTSUB _((HV * stash, char * name, SV *sv)); +#endif + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) +void +newCONSTSUB(stash,name,sv) +HV *stash; +char *name; +SV *sv; +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)) + /* before 5.003_22 */ + start_subparse(), +#else +# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22) + /* 5.003_22 */ + start_subparse(0), +# else + /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +# endif +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif + +#endif /* newCONSTSUB */ + + +#ifndef START_MY_CXT + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if PERL_REVISION == 5 && \ + (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#else /* single interpreter */ + +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifdef HASATTRIBUTE +# define PERL_UNUSED_DECL __attribute__((unused)) +#else +# define PERL_UNUSED_DECL +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif + +#endif /* START_MY_CXT */ + + +#ifndef DBM_setFilter + +/* + The DBM_setFilter & DBM_ckFilter macros are only used by + the *DB*_File modules +*/ + +#define DBM_setFilter(db_type,code) \ + { \ + if (db_type) \ + RETVAL = sv_mortalcopy(db_type) ; \ + ST(0) = RETVAL ; \ + if (db_type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db_type) ; \ + db_type = NULL ; \ + } \ + else if (code) { \ + if (db_type) \ + sv_setsv(db_type, code) ; \ + else \ + db_type = newSVsv(code) ; \ + } \ + } + +#define DBM_ckFilter(arg,type,name) \ + if (db->type) { \ + if (db->filtering) { \ + croak("recursion detected in %s", name) ; \ + } \ + ENTER ; \ + SAVETMPS ; \ + SAVEINT(db->filtering) ; \ + db->filtering = TRUE ; \ + SAVESPTR(DEFSV) ; \ + DEFSV = arg ; \ + SvTEMP_off(arg) ; \ + PUSHMARK(SP) ; \ + PUTBACK ; \ + (void) perl_call_sv(db->type, G_DISCARD); \ + SPAGAIN ; \ + PUTBACK ; \ + FREETMPS ; \ + LEAVE ; \ + } + +#endif /* DBM_setFilter */ + +#endif /* _P_P_PORTABILITY_H_ */ diff --git a/bdb/perl/DB_File/t/db-btree.t b/bdb/perl/DB_File/t/db-btree.t new file mode 100644 index 00000000000..a990a5c4ba5 --- /dev/null +++ b/bdb/perl/DB_File/t/db-btree.t @@ -0,0 +1,1489 @@ +#!./perl -w + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use warnings; +use strict; +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } + } + if ($^O eq 'darwin' + && $Config{db_version_major} == 1 + && $Config{db_version_minor} == 0 + && $Config{db_version_patch} == 0) { + warn <<EOM; +# +# This test is known to crash in Mac OS X versions 10.1.4 (or earlier) +# because of the buggy Berkeley DB version included with the OS. +# +EOM + } +} + +use DB_File; +use Fcntl; + +print "1..177\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +sub lexical +{ + my(@a) = unpack ("C*", $a) ; + my(@b) = unpack ("C*", $b) ; + + my $len = (@a > @b ? @b : @a) ; + my $i = 0 ; + + foreach $i ( 0 .. $len -1) { + return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; + } + + return @a - @b ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef ; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + $result = normalise($result) ; + return $result ; +} + +sub docat_del +{ + my $file = shift; + my $result = docat($file); + unlink $file ; + return $result ; +} + +sub normalise +{ + my $data = shift ; + $data =~ s#\r\n#\n#g + if $^O eq 'cygwin' ; + + return $data ; +} + +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie %$hashref; + return $no_inner; +} + + + +my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +my $Dfile = "dbbtree.tmp"; +unlink $Dfile; + +umask(0); + +# Check the interface to BTREEINFO + +my $dbh = new DB_File::BTREEINFO ; +ok(1, ! defined $dbh->{flags}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{lorder}) ; +ok(5, ! defined $dbh->{minkeypage}) ; +ok(6, ! defined $dbh->{maxkeypage}) ; +ok(7, ! defined $dbh->{compare}) ; +ok(8, ! defined $dbh->{prefix}) ; + +$dbh->{flags} = 3000 ; +ok(9, $dbh->{flags} == 3000) ; + +$dbh->{cachesize} = 9000 ; +ok(10, $dbh->{cachesize} == 9000); + +$dbh->{psize} = 400 ; +ok(11, $dbh->{psize} == 400) ; + +$dbh->{lorder} = 65 ; +ok(12, $dbh->{lorder} == 65) ; + +$dbh->{minkeypage} = 123 ; +ok(13, $dbh->{minkeypage} == 123) ; + +$dbh->{maxkeypage} = 1234 ; +ok(14, $dbh->{maxkeypage} == 1234 ); + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(15, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; +eval 'my $q = $dbh->{fred}' ; +ok(16, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; + +# Now check the interface to BTREE + +my ($X, %h) ; +ok(17, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; +die "Could not tie: $!" unless $X; + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + +my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; + +ok(18, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) + || $noMode{$^O} ); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(19, !$i ) ; + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +ok(20, $h{'abc'} eq 'ABC' ); +ok(21, ! defined $h{'jimmy'} ) ; +ok(22, ! exists $h{'jimmy'} ) ; +ok(23, defined $h{'abc'} ) ; + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + +# tie to the same file again +ok(24, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(25, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(26, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(27, $#keys == 31) ; + +#Check that the keys can be retrieved in order +my @b = keys %h ; +my @c = sort lexical @b ; +ok(28, ArrayCompare(\@b, \@c)) ; + +$h{'foo'} = ''; +ok(29, $h{'foo'} eq '' ) ; + +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(30, $result) ; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +ok(31, $ok); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(32, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(33, join(':',200..400) eq join(':',@foo) ); + +# Now check all the non-tie specific stuff + + +# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(34, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(35, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(36, $status == 0 ); + +#check that previous put can be retrieved +$value = 0 ; +$status = $X->get('key', $value) ; +ok(37, $status == 0 ); +ok(38, $value eq 'value' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(39, $status == 0 ); +if ($null_keys_allowed) { + $status = $X->del('') ; +} else { + $status = 0 ; +} +ok(40, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +ok(41, ! defined $h{'q'}) ; +ok(42, ! defined $h{''}) ; + +undef $X ; +untie %h ; + +ok(43, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +ok(44, $status == 1 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(45, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(46, $status == 0 ); +ok(47, $value eq 'A' ); + +# seq +# ### + +# use seq to find an approximate match +$key = 'ke' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(48, $status == 0 ); +ok(49, $key eq 'key' ); +ok(50, $value eq 'value' ); + +# seq when the key does not match +$key = 'zzz' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(51, $status == 1 ); + + +# use seq to set the cursor, then delete the record @ the cursor. + +$key = 'x' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(52, $status == 0 ); +ok(53, $key eq 'x' ); +ok(54, $value eq 'X' ); +$status = $X->del(0, R_CURSOR) ; +ok(55, $status == 0 ); +$status = $X->get('x', $value) ; +ok(56, $status == 1 ); + +# ditto, but use put to replace the key/value pair. +$key = 'y' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(57, $status == 0 ); +ok(58, $key eq 'y' ); +ok(59, $value eq 'Y' ); + +$key = "replace key" ; +$value = "replace value" ; +$status = $X->put($key, $value, R_CURSOR) ; +ok(60, $status == 0 ); +ok(61, $key eq 'replace key' ); +ok(62, $value eq 'replace value' ); +$status = $X->get('y', $value) ; +ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1) + # only worked because of a bug in 1.85/6 + +# use seq to walk forwards through a file + +$status = $X->seq($key, $value, R_FIRST) ; +ok(64, $status == 0 ); +my $previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_NEXT)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == 1 ; +} + +ok(65, $status == 1 ); +ok(66, $ok == 1 ); + +# use seq to walk backwards through a file +$status = $X->seq($key, $value, R_LAST) ; +ok(67, $status == 0 ); +$previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_PREV)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == -1 ; + #print "key = [$key] value = [$value]\n" ; +} + +ok(68, $status == 1 ); +ok(69, $ok == 1 ); + + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(70, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(71, $status != 0 ); + + +undef $X ; +untie %h ; + +unlink $Dfile; + +# Now try an in memory file +my $Y; +ok(72, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); + +# fd with an in memory file should return failure +$status = $Y->fd ; +ok(73, $status == -1 ); + + +undef $Y ; +untie %h ; + +# Duplicate keys +my $bt = new DB_File::BTREEINFO ; +$bt->{flags} = R_DUP ; +my ($YY, %hh); +ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; + +$hh{'Wall'} = 'Larry' ; +$hh{'Wall'} = 'Stone' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value +$hh{'Smith'} = 'John' ; +$hh{'mouse'} = 'mickey' ; + +# first work in scalar context +ok(75, scalar $YY->get_dup('Unknown') == 0 ); +ok(76, scalar $YY->get_dup('Smith') == 1 ); +ok(77, scalar $YY->get_dup('Wall') == 4 ); + +# now in list context +my @unknown = $YY->get_dup('Unknown') ; +ok(78, "@unknown" eq "" ); + +my @smith = $YY->get_dup('Smith') ; +ok(79, "@smith" eq "John" ); + +{ +my @wall = $YY->get_dup('Wall') ; +my %wall ; +@wall{@wall} = @wall ; +ok(80, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); +} + +# hash +my %unknown = $YY->get_dup('Unknown', 1) ; +ok(81, keys %unknown == 0 ); + +my %smith = $YY->get_dup('Smith', 1) ; +ok(82, keys %smith == 1 && $smith{'John'}) ; + +my %wall = $YY->get_dup('Wall', 1) ; +ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 + && $wall{'Brick'} == 2); + +undef $YY ; +untie %hh ; +unlink $Dfile; + + +# test multiple callbacks +my $Dfile1 = "btree1" ; +my $Dfile2 = "btree2" ; +my $Dfile3 = "btree3" ; + +my $dbh1 = new DB_File::BTREEINFO ; +$dbh1->{compare} = sub { + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; + +my $dbh2 = new DB_File::BTREEINFO ; +$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; + +my $dbh3 = new DB_File::BTREEINFO ; +$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; + + +my (%g, %k); +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!; +tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!; +tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!; + +my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; +my (@srt_1, @srt_2, @srt_3); +{ + no warnings 'numeric' ; + @srt_1 = sort { $a <=> $b } @Keys ; +} +@srt_2 = sort { $a cmp $b } @Keys ; +@srt_3 = sort { length $a <=> length $b } @Keys ; + +foreach (@Keys) { + $h{$_} = 1 ; + $g{$_} = 1 ; + $k{$_} = 1 ; +} + +sub ArrayCompare +{ + my($a, $b) = @_ ; + + return 0 if @$a != @$b ; + + foreach (1 .. length @$a) + { + return 0 unless $$a[$_] eq $$b[$_] ; + } + + 1 ; +} + +ok(84, ArrayCompare (\@srt_1, [keys %h]) ); +ok(85, ArrayCompare (\@srt_2, [keys %g]) ); +ok(86, ArrayCompare (\@srt_3, [keys %k]) ); + +untie %h ; +untie %g ; +untie %k ; +unlink $Dfile1, $Dfile2, $Dfile3 ; + +# clear +# ##### + +ok(87, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(88, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(89, $i == 0); + +untie %h ; +unlink $Dfile1 ; + +{ + # check that attempting to tie an array to a DB_BTREE will fail + + my $filename = "xyz" ; + my @x ; + eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; + ok(90, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + our (@ISA, @EXPORT); + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(91, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; + + main::ok(92, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(93, $@ eq "") ; + main::ok(94, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(95, $@ eq "") ; + main::ok(96, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(97, $@ eq "" ) ; + main::ok(98, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(99, $@ eq "") ; + main::ok(100, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(102, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(103, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(104, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(105, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(106, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(107, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(108, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(109, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(110, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(111, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(112, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(113, $h{"fred"} eq "joe"); + ok(114, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(115, $db->FIRSTKEY() eq "fred") ; + ok(116, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(117, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(118, $h{"fred"} eq "joe"); + ok(119, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(120, $db->FIRSTKEY() eq "fred") ; + ok(121, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(122, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(123, $result{"store key"} eq "store key - 1: [fred]"); + ok(124, $result{"store value"} eq "store value - 1: [joe]"); + ok(125, ! defined $result{"fetch key"} ); + ok(126, ! defined $result{"fetch value"} ); + ok(127, $_ eq "original") ; + + ok(128, $db->FIRSTKEY() eq "fred") ; + ok(129, $result{"store key"} eq "store key - 1: [fred]"); + ok(130, $result{"store value"} eq "store value - 1: [joe]"); + ok(131, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(132, ! defined $result{"fetch value"} ); + ok(133, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(134, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(135, $result{"store value"} eq "store value - 2: [joe john]"); + ok(136, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(137, ! defined $result{"fetch value"} ); + ok(138, $_ eq "original") ; + + ok(139, $h{"fred"} eq "joe"); + ok(140, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(141, $result{"store value"} eq "store value - 2: [joe john]"); + ok(142, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(143, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(144, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(145, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + # BTREE example 1 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + + unlink "tree" ; + } + + delete $DB_BTREE->{'compare'} ; + + ok(147, docat_del($file) eq <<'EOM') ; +mouse +Smith +Wall +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 2 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, %h); + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + + unlink $filename ; + } + + ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Larry +Wall -> Larry +mouse -> mickey +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 3 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $status, $key, $value); + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + + undef $x ; + untie %h ; + } + + ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Larry +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM + + + { + my $redirect = new Redirect $file ; + + # BTREE example 4 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h); + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + undef $x ; + untie %h ; + } + + ok(150, docat_del($file) eq <<'EOM') ; +Wall occurred 3 times +Larry is there +There are 2 Brick Walls +Wall => [Brick Brick Larry] +Smith => [John] +Dog => [] +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 5 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found); + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + } + + ok(151, docat_del($file) eq <<'EOM') ; +Larry Wall is there +Harry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 6 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found); + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + + unlink $filename ; + } + + ok(152, docat_del($file) eq <<'EOM') ; +Larry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 7 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + use Fcntl ; + + my ($filename, $x, %h, $st, $key, $value); + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + + unlink $filename ; + + } + + ok(153, docat_del($file) eq <<'EOM') ; +IN ORDER +Smith -> John +Wall -> Larry +Walls -> Brick +mouse -> mickey + +PARTIAL MATCH +Wa -> Wall -> Larry +A -> Smith -> John +a -> mouse -> mickey +EOM + +} + +#{ +# # R_SETCURSOR +# use strict ; +# my (%h, $db) ; +# unlink $Dfile; +# +# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +# +# $h{abc} = 33 ; +# my $k = "newest" ; +# my $v = 44 ; +# my $status = $db->put($k, $v, R_SETCURSOR) ; +# print "status = [$status]\n" ; +# ok(157, $status == 0) ; +# $status = $db->del($k, R_CURSOR) ; +# print "status = [$status]\n" ; +# ok(158, $status == 0) ; +# $k = "newest" ; +# ok(159, $db->get($k, $v, R_CURSOR)) ; +# +# ok(160, keys %h == 1) ; +# +# undef $db ; +# untie %h; +# unlink $Dfile; +#} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(154, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + %h = (); ; + ok(155, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # When iterating over a tied hash using "each", the key passed to FETCH + # will be recycled and passed to NEXTKEY. If a Source Filter modifies the + # key in FETCH via a filter_fetch_key method we need to check that the + # modified key doesn't get passed to NEXTKEY. + # Also Test "keys" & "values" while we are at it. + + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my $bad_key = 0 ; + my %h = () ; + my $db ; + ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; + $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; + + $h{'Alpha_ABC'} = 2 ; + $h{'Alpha_DEF'} = 5 ; + + ok(157, $h{'Alpha_ABC'} == 2); + ok(158, $h{'Alpha_DEF'} == 5); + + my ($k, $v) = ("",""); + while (($k, $v) = each %h) {} + ok(159, $bad_key == 0); + + $bad_key = 0 ; + foreach $k (keys %h) {} + ok(160, $bad_key == 0); + + $bad_key = 0 ; + foreach $v (values %h) {} + ok(161, $bad_key == 0); + + undef $db ; + untie %h ; + unlink $Dfile; +} + +{ + # now an error to pass 'compare' a non-code reference + my $dbh = new DB_File::BTREEINFO ; + + eval { $dbh->{compare} = 2 }; + ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/); + + eval { $dbh->{prefix} = 2 }; + ok(163, $@ =~ /^Key 'prefix' not associated with a code reference at/); + +} + + +{ + # recursion detection in btree + my %hash ; + unlink $Dfile; + my $dbh = new DB_File::BTREEINFO ; + $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ; + + + my (%h); + ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); + + eval { $hash{1} = 2; + $hash{4} = 5; + }; + + ok(165, $@ =~ /^DB_File btree_compare: recursion detected/); + { + no warnings; + untie %hash; + } + unlink $Dfile; +} + +{ + # Check that two callbacks don't interact + my %hash1 ; + my %hash2 ; + my $h1_count = 0; + my $h2_count = 0; + unlink $Dfile, $Dfile2; + my $dbh1 = new DB_File::BTREEINFO ; + $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ; + + my $dbh2 = new DB_File::BTREEINFO ; + $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ; + + + + my (%h); + ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); + ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); + + $hash1{DEFG} = 5; + $hash1{XYZ} = 2; + $hash1{ABCDE} = 5; + + $hash2{defg} = 5; + $hash2{xyz} = 2; + $hash2{abcde} = 5; + + ok(168, $h1_count > 0); + ok(169, $h1_count == $h2_count); + + ok(170, safeUntie \%hash1); + ok(171, safeUntie \%hash2); + unlink $Dfile, $Dfile2; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(172, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(173, $h{"fred"} eq "joe"); + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (174, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h{"fred"} = "joe" ; + + ok(175, $h{"fred"} eq "joe"); + + ok(176, $db->FIRSTKEY() eq "fred") ; + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (177, ! $@); + + undef $db ; + untie %h; + unlink $Dfile; +} + +exit ; diff --git a/bdb/perl/DB_File/t/db-hash.t b/bdb/perl/DB_File/t/db-hash.t new file mode 100644 index 00000000000..10623cc82a7 --- /dev/null +++ b/bdb/perl/DB_File/t/db-hash.t @@ -0,0 +1,981 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use warnings; +use strict; +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } + } +} + +use DB_File; +use Fcntl; + +print "1..143\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + $result = normalise($result) ; + unlink $file ; + return $result; +} + +sub normalise +{ + my $data = shift ; + $data =~ s#\r\n#\n#g + if $^O eq 'cygwin' ; + return $data ; +} + +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie %$hashref; + return $no_inner; +} + + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +unlink $Dfile; + +umask(0); + +# Check the interface to HASHINFO + +my $dbh = new DB_File::HASHINFO ; + +ok(1, ! defined $dbh->{bsize}) ; +ok(2, ! defined $dbh->{ffactor}) ; +ok(3, ! defined $dbh->{nelem}) ; +ok(4, ! defined $dbh->{cachesize}) ; +ok(5, ! defined $dbh->{hash}) ; +ok(6, ! defined $dbh->{lorder}) ; + +$dbh->{bsize} = 3000 ; +ok(7, $dbh->{bsize} == 3000 ); + +$dbh->{ffactor} = 9000 ; +ok(8, $dbh->{ffactor} == 9000 ); + +$dbh->{nelem} = 400 ; +ok(9, $dbh->{nelem} == 400 ); + +$dbh->{cachesize} = 65 ; +ok(10, $dbh->{cachesize} == 65 ); + +my $some_sub = sub {} ; +$dbh->{hash} = $some_sub; +ok(11, $dbh->{hash} eq $some_sub ); + +$dbh->{lorder} = 1234 ; +ok(12, $dbh->{lorder} == 1234 ); + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); +eval 'my $q = $dbh->{fred}' ; +ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); + + +# Now check the interface to HASH +my ($X, %h); +ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); +die "Could not tie: $!" unless $X; + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + +my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; + +ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) || + $noMode{$^O} ); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(17, !$i ); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +ok(18, $h{'abc'} eq 'ABC' ); +ok(19, !defined $h{'jimmy'} ); +ok(20, !exists $h{'jimmy'} ); +ok(21, exists $h{'abc'} ); + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + + +# tie to the same file again, do not supply a type - should default to HASH +ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(23, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(24, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(25, $#keys == 31) ; + +$h{'foo'} = ''; +ok(26, $h{'foo'} eq '' ); + +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(27, $result) ; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +ok(28, $ok ); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(29, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(30, join(':',200..400) eq join(':',@foo) ); + + +# Now check all the non-tie specific stuff + +# Check NOOVERWRITE will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(31, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(32, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(33, $status == 0 ); + +#check that previous put can be retrieved +$value = 0 ; +$status = $X->get('key', $value) ; +ok(34, $status == 0 ); +ok(35, $value eq 'value' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(36, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +{ + no warnings 'uninitialized' ; + ok(37, $h{'q'} eq undef ); +} + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +ok(38, $status == 1 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(39, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(40, $status == 0 ); +ok(41, $value eq 'A' ); + +# seq +# ### + +# ditto, but use put to replace the key/value pair. + +# use seq to walk backwards through a file - check that this reversed is + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(42, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(43, $status != 0 ); + +undef $X ; +untie %h ; + +unlink $Dfile; + +# clear +# ##### + +ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(45, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(46, $i == 0); + +untie %h ; +unlink $Dfile ; + + +# Now try an in memory file +ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + +# fd with an in memory file should return fail +$status = $X->fd ; +ok(48, $status == -1 ); + +undef $X ; +untie %h ; + +{ + # check ability to override the default hashing + my %x ; + my $filename = "xyz" ; + my $hi = new DB_File::HASHINFO ; + $::count = 0 ; + $hi->{hash} = sub { ++$::count ; length $_[0] } ; + ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; + $h{"abc"} = 123 ; + ok(50, $h{"abc"} == 123) ; + untie %x ; + unlink $filename ; + ok(51, $::count >0) ; +} + +{ + # check that attempting to tie an array to a DB_HASH will fail + + my $filename = "xyz" ; + my @x ; + eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; + ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + our (@ISA, @EXPORT); + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(53, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; + + main::ok(54, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(55, $@ eq "") ; + main::ok(56, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(57, $@ eq "") ; + main::ok(58, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(59, $@ eq "" ) ; + main::ok(60, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbhash.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + no warnings 'uninitialized'; + my($fk, $sk, $fv, $sv) = @_ ; + + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + if $fetch_key ne $fk ; + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + if $fetch_value ne $fv ; + print "# Store Key : expected '$sk' got '$store_key'\n" + if $store_key ne $sk ; + print "# Store Value : expected '$sv' got '$store_value'\n" + if $store_value ne $sv ; + print "# \$_ : expected 'original' got '$_'\n" + if $_ ne 'original' ; + + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(64, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(65, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(66, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + my ($k, $v) ; + $k = 'fred'; + ok(67, ! $db->seq($k, $v, R_FIRST) ) ; + ok(68, $k eq "fred") ; + ok(69, $v eq "joe") ; + # fk sk fv sv + ok(70, checkOutput( "fred", "fred", "joe", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(71, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(72, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(73, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $k = 'Fred'; $v =''; + ok(74, ! $db->seq($k, $v, R_FIRST) ) ; + ok(75, $k eq "FRED") ; + ok(76, $v eq "[Jxe]") ; + # fk sk fv sv + ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(78, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(79, $h{"fred"} eq "joe"); + ok(80, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + #ok(77, $db->FIRSTKEY() eq "fred") ; + $k = 'fred'; + ok(81, ! $db->seq($k, $v, R_FIRST) ) ; + ok(82, $k eq "fred") ; + ok(83, $v eq "joe") ; + # fk sk fv sv + ok(84, checkOutput( "fred", "fred", "joe", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(85, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(86, $h{"fred"} eq "joe"); + ok(87, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $k = 'fred'; + ok(88, ! $db->seq($k, $v, R_FIRST) ) ; + ok(89, $k eq "fred") ; + ok(90, $v eq "joe") ; + ok(91, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(93, $result{"store key"} eq "store key - 1: [fred]"); + ok(94, $result{"store value"} eq "store value - 1: [joe]"); + ok(95, ! defined $result{"fetch key"} ); + ok(96, ! defined $result{"fetch value"} ); + ok(97, $_ eq "original") ; + + ok(98, $db->FIRSTKEY() eq "fred") ; + ok(99, $result{"store key"} eq "store key - 1: [fred]"); + ok(100, $result{"store value"} eq "store value - 1: [joe]"); + ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(102, ! defined $result{"fetch value"} ); + ok(103, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(104, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(105, $result{"store value"} eq "store value - 2: [joe john]"); + ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(107, ! defined $result{"fetch value"} ); + ok(108, $_ eq "original") ; + + ok(109, $h{"fred"} eq "joe"); + ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(111, $result{"store value"} eq "store value - 2: [joe john]"); + ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(114, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(116, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + our (%h, $k, $v); + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + + unlink "fruit" ; + } + + ok(117, docat_del($file) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(118, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + %h = (); ; + ok(119, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # When iterating over a tied hash using "each", the key passed to FETCH + # will be recycled and passed to NEXTKEY. If a Source Filter modifies the + # key in FETCH via a filter_fetch_key method we need to check that the + # modified key doesn't get passed to NEXTKEY. + # Also Test "keys" & "values" while we are at it. + + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my $bad_key = 0 ; + my %h = () ; + my $db ; + ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; + $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; + + $h{'Alpha_ABC'} = 2 ; + $h{'Alpha_DEF'} = 5 ; + + ok(121, $h{'Alpha_ABC'} == 2); + ok(122, $h{'Alpha_DEF'} == 5); + + my ($k, $v) = ("",""); + while (($k, $v) = each %h) {} + ok(123, $bad_key == 0); + + $bad_key = 0 ; + foreach $k (keys %h) {} + ok(124, $bad_key == 0); + + $bad_key = 0 ; + foreach $v (values %h) {} + ok(125, $bad_key == 0); + + undef $db ; + untie %h ; + unlink $Dfile; +} + +{ + # now an error to pass 'hash' a non-code reference + my $dbh = new DB_File::HASHINFO ; + + eval { $dbh->{hash} = 2 }; + ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/); + +} + +{ + # recursion detection in hash + my %hash ; + unlink $Dfile; + my $dbh = new DB_File::HASHINFO ; + $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ; + + + my (%h); + ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); + + eval { $hash{1} = 2; + $hash{4} = 5; + }; + + ok(128, $@ =~ /^DB_File hash callback: recursion detected/); + { + no warnings; + untie %hash; + } + unlink $Dfile; +} + +{ + # Check that two hash's don't interact + my %hash1 ; + my %hash2 ; + my $h1_count = 0; + my $h2_count = 0; + unlink $Dfile, $Dfile2; + my $dbh1 = new DB_File::HASHINFO ; + $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ; + + my $dbh2 = new DB_File::HASHINFO ; + $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ; + + + + my (%h); + ok(129, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); + ok(130, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); + + $hash1{DEFG} = 5; + $hash1{XYZ} = 2; + $hash1{ABCDE} = 5; + + $hash2{defg} = 5; + $hash2{xyz} = 2; + $hash2{abcde} = 5; + + ok(131, $h1_count > 0); + ok(132, $h1_count == $h2_count); + + ok(133, safeUntie \%hash1); + ok(134, safeUntie \%hash2); + unlink $Dfile, $Dfile2; +} + +{ + # Passing undef for flags and/or mode when calling tie could cause + # Use of uninitialized value in subroutine entry + + + my $warn_count = 0 ; + #local $SIG{__WARN__} = sub { ++ $warn_count }; + my %hash1; + unlink $Dfile; + + tie %hash1, 'DB_File',$Dfile, undef; + ok(135, $warn_count == 0); + $warn_count = 0; + tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef; + ok(136, $warn_count == 0); + tie %hash1, 'DB_File',$Dfile, undef, undef; + ok(137, $warn_count == 0); + $warn_count = 0; + + unlink $Dfile; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(138, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(139, $h{"fred"} eq "joe"); + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (140, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h{"fred"} = "joe" ; + + ok(141, $h{"fred"} eq "joe"); + + ok(142, $db->FIRSTKEY() eq "fred") ; + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (143, ! $@); + + undef $db ; + untie %h; + unlink $Dfile; +} + +exit ; diff --git a/bdb/perl/DB_File/t/db-recno.t b/bdb/perl/DB_File/t/db-recno.t new file mode 100644 index 00000000000..5390b549376 --- /dev/null +++ b/bdb/perl/DB_File/t/db-recno.t @@ -0,0 +1,1428 @@ +#!./perl -w + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use warnings; +use strict; +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } + } +} + +use DB_File; +use Fcntl; +our ($dbh, $Dfile, $bad_ones, $FA); + +# full tied array support started in Perl 5.004_57 +# Double check to see if it is available. + +{ + sub try::TIEARRAY { bless [], "try" } + sub try::FETCHSIZE { $FA = 1 } + $FA = 0 ; + my @a ; + tie @a, 'try' ; + my $a = @a ; +} + + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + + return $result ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + normalise($result) ; + return $result; +} + +sub docat_del +{ + my $file = shift; + my $result = docat($file); + unlink $file ; + return $result; +} + +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie @$hashref; + return $no_inner; +} + +sub bad_one +{ + unless ($bad_ones++) { + print STDERR <<EOM ; +# +# Some older versions of Berkeley DB version 1 will fail db-recno +# tests 61, 63 and 65. +EOM + if ($^O eq 'darwin' + && $Config{db_version_major} == 1 + && $Config{db_version_minor} == 0 + && $Config{db_version_patch} == 0) { + print STDERR <<EOM ; +# +# For example Mac OS X 10.1.4 (or earlier) has such an old +# version of Berkeley DB. +EOM + } + + print STDERR <<EOM ; +# +# You can safely ignore the errors if you're never going to use the +# broken functionality (recno databases with a modified bval). +# Otherwise you'll have to upgrade your DB library. +# +# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the +# last versions that were released. Berkeley DB version 2 is continually +# being updated -- Check out http://www.sleepycat.com/ for more details. +# +EOM + } +} + +sub normalise +{ + return unless $^O eq 'cygwin' ; + foreach (@_) + { s#\r\n#\n#g } +} + +BEGIN +{ + { + local $SIG{__DIE__} ; + eval { require Data::Dumper ; import Data::Dumper } ; + } + + if ($@) { + *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ; + } +} + +my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms +my $total_tests = 158 ; +$total_tests += $splice_tests if $FA ; +print "1..$total_tests\n"; + +$Dfile = "recno.tmp"; +unlink $Dfile ; + +umask(0); + +# Check the interface to RECNOINFO + +$dbh = new DB_File::RECNOINFO ; +ok(1, ! defined $dbh->{bval}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{flags}) ; +ok(5, ! defined $dbh->{lorder}) ; +ok(6, ! defined $dbh->{reclen}) ; +ok(7, ! defined $dbh->{bfname}) ; + +$dbh->{bval} = 3000 ; +ok(8, $dbh->{bval} == 3000 ); + +$dbh->{cachesize} = 9000 ; +ok(9, $dbh->{cachesize} == 9000 ); + +$dbh->{psize} = 400 ; +ok(10, $dbh->{psize} == 400 ); + +$dbh->{flags} = 65 ; +ok(11, $dbh->{flags} == 65 ); + +$dbh->{lorder} = 123 ; +ok(12, $dbh->{lorder} == 123 ); + +$dbh->{reclen} = 1234 ; +ok(13, $dbh->{reclen} == 1234 ); + +$dbh->{bfname} = 1234 ; +ok(14, $dbh->{bfname} == 1234 ); + + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); +eval 'my $q = $dbh->{fred}' ; +ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); + +# Now check the interface to RECNOINFO + +my $X ; +my @h ; +ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + +my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; + +ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) + || $noMode{$^O} ); + +#my $l = @h ; +my $l = $X->length ; +ok(19, ($FA ? @h == 0 : !$l) ); + +my @data = qw( a b c d ever f g h i j k longername m n o p) ; + +$h[0] = shift @data ; +ok(20, $h[0] eq 'a' ); + +my $ i; +foreach (@data) + { $h[++$i] = $_ } + +unshift (@data, 'a') ; + +ok(21, defined $h[1] ); +ok(22, ! defined $h[16] ); +ok(23, $FA ? @h == @data : $X->length == @data ); + + +# Overwrite an entry & check fetch it +$h[3] = 'replaced' ; +$data[3] = 'replaced' ; +ok(24, $h[3] eq 'replaced' ); + +#PUSH +my @push_data = qw(added to the end) ; +($FA ? push(@h, @push_data) : $X->push(@push_data)) ; +push (@data, @push_data) ; +ok(25, $h[++$i] eq 'added' ); +ok(26, $h[++$i] eq 'to' ); +ok(27, $h[++$i] eq 'the' ); +ok(28, $h[++$i] eq 'end' ); + +# POP +my $popped = pop (@data) ; +my $value = ($FA ? pop @h : $X->pop) ; +ok(29, $value eq $popped) ; + +# SHIFT +$value = ($FA ? shift @h : $X->shift) ; +my $shifted = shift @data ; +ok(30, $value eq $shifted ); + +# UNSHIFT + +# empty list +($FA ? unshift @h,() : $X->unshift) ; +ok(31, ($FA ? @h == @data : $X->length == @data )); + +my @new_data = qw(add this to the start of the array) ; +$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; +unshift (@data, @new_data) ; +ok(32, $FA ? @h == @data : $X->length == @data ); +ok(33, $h[0] eq "add") ; +ok(34, $h[1] eq "this") ; +ok(35, $h[2] eq "to") ; +ok(36, $h[3] eq "the") ; +ok(37, $h[4] eq "start") ; +ok(38, $h[5] eq "of") ; +ok(39, $h[6] eq "the") ; +ok(40, $h[7] eq "array") ; +ok(41, $h[8] eq $data[8]) ; + +# Brief test for SPLICE - more thorough 'soak test' is later. +my @old; +if ($FA) { + @old = splice(@h, 1, 2, qw(bananas just before)); +} +else { + @old = $X->splice(1, 2, qw(bananas just before)); +} +ok(42, $h[0] eq "add") ; +ok(43, $h[1] eq "bananas") ; +ok(44, $h[2] eq "just") ; +ok(45, $h[3] eq "before") ; +ok(46, $h[4] eq "the") ; +ok(47, $h[5] eq "start") ; +ok(48, $h[6] eq "of") ; +ok(49, $h[7] eq "the") ; +ok(50, $h[8] eq "array") ; +ok(51, $h[9] eq $data[8]) ; +$FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old); + +# Now both arrays should be identical + +my $ok = 1 ; +my $j = 0 ; +foreach (@data) +{ + $ok = 0, last if $_ ne $h[$j ++] ; +} +ok(52, $ok ); + +# Neagtive subscripts + +# get the last element of the array +ok(53, $h[-1] eq $data[-1] ); +ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); + +# get the first element using a negative subscript +eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; +ok(55, $@ eq "" ); +ok(56, $h[0] eq "abcd" ); + +# now try to read before the start of the array +eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; +ok(57, $@ =~ '^Modification of non-creatable array value attempted' ); + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +ok(58, safeUntie \@h); + +unlink $Dfile; + + +{ + # Check bval defaults to \n + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(60, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + ok(61, $x eq "abc\ndef\n\nghi\n") ; +} + +{ + # Change bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{bval} = "-" ; + ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(63, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc-def--ghi-") ; + bad_one() unless $ok ; + ok(64, $ok) ; +} + +{ + # Check R_FIXEDLEN with default bval (space) + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{reclen} = 5 ; + ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(66, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc def ghi ") ; + bad_one() unless $ok ; + ok(67, $ok) ; +} + +{ + # Check R_FIXEDLEN with user-defined bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{bval} = "-" ; + $dbh->{reclen} = 5 ; + ok(68, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(69, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc--def-------ghi--") ; + bad_one() unless $ok ; + ok(70, $ok) ; +} + +{ + # check that attempting to tie an associative array to a DB_RECNO will fail + + my $filename = "xyz" ; + my %x ; + eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; + ok(71, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + our (@ISA, @EXPORT); + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE or die "Could not close: $!"; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(72, $@ eq "") ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; + die "Could not tie: $!" unless $X; + + main::ok(73, $@ eq "") ; + + my $ret = eval '$h[3] = 3 ; return $h[3] ' ; + main::ok(74, $@ eq "") ; + main::ok(75, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; + main::ok(76, $@ eq "") ; + main::ok(77, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(78, $@ eq "" ) ; + main::ok(79, $ret == 1) ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok(80, $@ eq "") ; + main::ok(81, $ret eq "[[11]]") ; + + undef $X; + main::ok(82, main::safeUntie \@h); + unlink "SubDB.pm", "recno.tmp" ; + +} + +{ + + # test $# + my $self ; + unlink $Dfile; + ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[2] = "ghi" ; + $h[3] = "jkl" ; + ok(84, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + ok(85, safeUntie \@h); + my $x = docat($Dfile) ; + ok(86, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to same length + ok(87, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 3 } + else + { $self->STORESIZE(4) } + ok(88, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + ok(89, safeUntie \@h); + $x = docat($Dfile) ; + ok(90, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to bigger + ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 6 } + else + { $self->STORESIZE(7) } + ok(92, $FA ? $#h == 6 : $self->length() == 7) ; + undef $self ; + ok(93, safeUntie \@h); + $x = docat($Dfile) ; + ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; + + # $# sets array smaller + ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 2 } + else + { $self->STORESIZE(3) } + ok(96, $FA ? $#h == 2 : $self->length() == 3) ; + undef $self ; + ok(97, safeUntie \@h); + $x = docat($Dfile) ; + ok(98, $x eq "abc\ndef\nghi\n") ; + + unlink $Dfile; + + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (@h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + if $fetch_key ne $fk ; + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + if $fetch_value ne $fv ; + print "# Store Key : expected '$sk' got '$store_key'\n" + if $store_key ne $sk ; + print "# Store Value : expected '$sv' got '$store_value'\n" + if $store_value ne $sv ; + print "# \$_ : expected 'original' got '$_'\n" + if $_ ne 'original' ; + + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + # fk sk fv sv + ok(100, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(101, $h[0] eq "joe"); + # fk sk fv sv + ok(102, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(103, $db->FIRSTKEY() == 0) ; + # fk sk fv sv + ok(104, checkOutput( 0, "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { ++ $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ *= 2 ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[1] = "Joe" ; + # fk sk fv sv + ok(105, checkOutput( "", 2, "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(106, $h[1] eq "[Jxe]"); + # fk sk fv sv + ok(107, checkOutput( "", 2, "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(108, $db->FIRSTKEY() == 1) ; + # fk sk fv sv + ok(109, checkOutput( 1, "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(110, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(111, $h[0] eq "joe"); + ok(112, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(113, $db->FIRSTKEY() == 0) ; + ok(114, checkOutput( 0, "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(115, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(116, $h[0] eq "joe"); + ok(117, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(118, $db->FIRSTKEY() == 0) ; + ok(119, checkOutput( "", "", "", "")) ; + + undef $db ; + ok(120, safeUntie \@h); + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (@h, $db) ; + + unlink $Dfile; + ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(122, $result{"store key"} eq "store key - 1: [0]"); + ok(123, $result{"store value"} eq "store value - 1: [joe]"); + ok(124, ! defined $result{"fetch key"} ); + ok(125, ! defined $result{"fetch value"} ); + ok(126, $_ eq "original") ; + + ok(127, $db->FIRSTKEY() == 0 ) ; + ok(128, $result{"store key"} eq "store key - 1: [0]"); + ok(129, $result{"store value"} eq "store value - 1: [joe]"); + ok(130, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(131, ! defined $result{"fetch value"} ); + ok(132, $_ eq "original") ; + + $h[7] = "john" ; + ok(133, $result{"store key"} eq "store key - 2: [0 7]"); + ok(134, $result{"store value"} eq "store value - 2: [joe john]"); + ok(135, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(136, ! defined $result{"fetch value"} ); + ok(137, $_ eq "original") ; + + ok(138, $h[0] eq "joe"); + ok(139, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(140, $result{"store value"} eq "store value - 2: [joe john]"); + ok(141, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(143, $_ eq "original") ; + + undef $db ; + ok(144, safeUntie \@h); + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_store_key (sub { $_ = $h[0] }) ; + + eval '$h[1] = 1234' ; + ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + ok(147, safeUntie \@h); + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $FA ? push @h, "green", "black" + : $x->push("green", "black") ; + + my $elements = $FA ? scalar @h : $x->length ; + print "The array contains $elements entries\n" ; + + my $last = $FA ? pop @h : $x->pop ; + print "popped $last\n" ; + + $FA ? unshift @h, "white" + : $x->unshift("white") ; + my $first = $FA ? shift @h : $x->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + undef $x ; + untie @h ; + + unlink $filename ; + } + + ok(148, docat_del($file) eq <<'EOM') ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +The last element is green +The 2nd last element is yellow +EOM + + my $save_output = "xyzt" ; + { + my $redirect = new Redirect $save_output ; + + use warnings FATAL => qw(all); + use strict ; + our (@h, $H, $file, $i); + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + + unlink $file ; + } + + ok(149, docat_del($save_output) eq <<'EOM') ; + +ORIGINAL +0: zero +1: one +2: two +3: three +4: four + +The last record was [four] +The first record was [zero] + +REVERSE +5: last +4: three +3: Newbie +2: one +1: New One +0: first + +REVERSE again +5: last +4: three +3: Newbie +2: one +1: New One +0: first +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my @h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + $h[0] = undef; + ok(150, $a eq "") ; + ok(151, safeUntie \@h); + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @h ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + @h = (); ; + ok(152, $a eq "") ; + ok(153, safeUntie \@h); + unlink $Dfile; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(155, $h[0] eq "joe"); + + eval { grep { $h[$_] } (1, 2, 3) }; + ok (156, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h[1] = "joe" ; + + ok(157, $h[1] eq "joe"); + + eval { grep { $h[$_] } (1, 2, 3) }; + ok (158, ! $@); + + undef $db ; + untie @h; + unlink $Dfile; +} + +# Only test splice if this is a newish version of Perl +exit unless $FA ; + +# Test SPLICE + +{ + # check that the splice warnings are under the same lexical control + # as their non-tied counterparts. + + use warnings; + use strict; + + my $a = ''; + my @a = (1); + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @tied ; + + tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + + # uninitialized offset + use warnings; + my $offset ; + $a = ''; + splice(@a, $offset); + ok(159, $a =~ /^Use of uninitialized value /); + $a = ''; + splice(@tied, $offset); + ok(160, $a =~ /^Use of uninitialized value in splice/); + + no warnings 'uninitialized'; + $a = ''; + splice(@a, $offset); + ok(161, $a eq ''); + $a = ''; + splice(@tied, $offset); + ok(162, $a eq ''); + + # uninitialized length + use warnings; + my $length ; + $a = ''; + splice(@a, 0, $length); + ok(163, $a =~ /^Use of uninitialized value /); + $a = ''; + splice(@tied, 0, $length); + ok(164, $a =~ /^Use of uninitialized value in splice/); + + no warnings 'uninitialized'; + $a = ''; + splice(@a, 0, $length); + ok(165, $a eq ''); + $a = ''; + splice(@tied, 0, $length); + ok(166, $a eq ''); + + # offset past end of array + use warnings; + $a = ''; + splice(@a, 3); + my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/); + $a = ''; + splice(@tied, 3); + ok(167, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/); + + no warnings 'misc'; + $a = ''; + splice(@a, 3); + ok(168, $a eq ''); + $a = ''; + splice(@tied, 3); + ok(169, $a eq ''); + + ok(170, safeUntie \@tied); + unlink $Dfile; +} + +# +# These are a few regression tests: bundles of five arguments to pass +# to test_splice(). The first four arguments correspond to those +# given to splice(), and the last says which context to call it in +# (scalar, list or void). +# +# The expected result is not needed because we get that by running +# Perl's built-in splice(). +# +my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', + 'rarely', 'paleness' ], + -4, -2, + [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ], + 'void' ], + + [ [ 'a' ], -2, 1, [ 'B' ], 'void' ], + + [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ], + 0, -4, + [ 'maids' ], + 'void' ], + + [ [ 'visibility', 'pocketful', 'rectangles' ], + -10, 0, + [ 'garbages' ], + 'void' ], + + [ [ 'sleeplessly' ], + 8, -4, + [ 'Margery', 'clearing', 'repercussion', 'clubs', + 'arise' ], + 'void' ], + + [ [ 'chastises', 'recalculates' ], + 0, 0, + [ 'momentariness', 'mediates', 'accents', 'toils', + 'regaled' ], + 'void' ], + + [ [ 'b', '' ], + 9, 8, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'b', '' ], + undef, undef, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'riheb' ], -8, undef, [], 'void' ], + + [ [ 'uft', 'qnxs', '' ], + 6, -2, + [ 'znp', 'mhnkh', 'bn' ], + 'void' ], + ); + +my $testnum = 171; +my $failed = 0; +require POSIX; my $tmp = POSIX::tmpnam(); +foreach my $test (@tests) { + my $err = test_splice(@$test); + if (defined $err) { + print STDERR "# failed: ", Dumper($test); + print STDERR "# error: $err\n"; + $failed = 1; + ok($testnum++, 0); + } + else { ok($testnum++, 1) } +} + +if ($failed) { + # Not worth running the random ones + print STDERR '# skipping ', $testnum++, "\n"; +} +else { + # A thousand randomly-generated tests + $failed = 0; + srand(0); + foreach (0 .. 1000 - 1) { + my $test = rand_test(); + my $err = test_splice(@$test); + if (defined $err) { + print STDERR "# failed: ", Dumper($test); + print STDERR "# error: $err\n"; + $failed = 1; + print STDERR "# skipping any remaining random tests\n"; + last; + } + } + + ok($testnum++, not $failed); +} + +die "testnum ($testnum) != total_tests ($total_tests) + 1" + if $testnum != $total_tests + 1; + +exit ; + +# Subroutines for SPLICE testing + +# test_splice() +# +# Test the new splice() against Perl's built-in one. The first four +# parameters are those passed to splice(), except that the lists must +# be (explicitly) passed by reference, and are not actually modified. +# (It's just a test!) The last argument specifies the context in +# which to call the functions: 'list', 'scalar', or 'void'. +# +# Returns: +# undef, if the two splices give the same results for the given +# arguments and context; +# +# an error message showing the difference, otherwise. +# +# Reads global variable $tmp. +# +sub test_splice { + die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5; + my ($array, $offset, $length, $list, $context) = @_; + my @array = @$array; + my @list = @$list; + + unlink $tmp; + + my @h; + my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO + or die "cannot open $tmp: $!"; + + my $i = 0; + foreach ( @array ) { $h[$i++] = $_ } + + return "basic DB_File sanity check failed" + if list_diff(\@array, \@h); + + # Output from splice(): + # Returned value (munged a bit), error msg, warnings + # + my ($s_r, $s_error, @s_warnings); + + my $gather_warning = sub { push @s_warnings, $_[0] }; + if ($context eq 'list') { + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = \@r; + } + elsif ($context eq 'scalar') { + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = [ $r ]; + } + elsif ($context eq 'void') { + eval { + local $SIG{__WARN__} = $gather_warning; + splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = []; + } + else { + die "bad context $context"; + } + + foreach ($s_error, @s_warnings) { + chomp; + s/ at \S+ line \d+\.$//; + } + + # Now do the same for DB_File's version of splice + my ($ms_r, $ms_error, @ms_warnings); + $gather_warning = sub { push @ms_warnings, $_[0] }; + if ($context eq 'list') { + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = \@r; + } + elsif ($context eq 'scalar') { + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = [ $r ]; + } + elsif ($context eq 'void') { + eval { + local $SIG{__WARN__} = $gather_warning; + splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = []; + } + else { + die "bad context $context"; + } + + foreach ($ms_error, @ms_warnings) { + chomp; + s/ at \S+ line \d+\.?.*//s; + } + + return "different errors: '$s_error' vs '$ms_error'" + if $s_error ne $ms_error; + return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r)) + if list_diff($s_r, $ms_r); + return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h)) + if list_diff(\@array, \@h); + + if ((scalar @s_warnings) != (scalar @ms_warnings)) { + return 'different number of warnings'; + } + + while (@s_warnings) { + my $sw = shift @s_warnings; + my $msw = shift @ms_warnings; + + if (defined $sw and defined $msw) { + $msw =~ s/ \(.+\)$//; + $msw =~ s/ in splice$// if $] < 5.006; + if ($sw ne $msw) { + return "different warning: '$sw' vs '$msw'"; + } + } + elsif (not defined $sw and not defined $msw) { + # Okay. + } + else { + return "one warning defined, another undef"; + } + } + + undef $H; + untie @h; + + open(TEXT, $tmp) or die "cannot open $tmp: $!"; + @h = <TEXT>; normalise @h; chomp @h; + close TEXT or die "cannot close $tmp: $!"; + return('list is different when re-read from disk: ' + . Dumper(\@array) . ' vs ' . Dumper(\@h)) + if list_diff(\@array, \@h); + + return undef; # success +} + + +# list_diff() +# +# Do two lists differ? +# +# Parameters: +# reference to first list +# reference to second list +# +# Returns true iff they differ. Only works for lists of (string or +# undef). +# +# Surely there is a better way to do this? +# +sub list_diff { + die 'usage: list_diff(ref to first list, ref to second list)' + if @_ != 2; + my ($a, $b) = @_; + my @a = @$a; my @b = @$b; + return 1 if (scalar @a) != (scalar @b); + for (my $i = 0; $i < @a; $i++) { + my ($ae, $be) = ($a[$i], $b[$i]); + if (defined $ae and defined $be) { + return 1 if $ae ne $be; + } + elsif (not defined $ae and not defined $be) { + # Two undefined values are 'equal' + } + else { + return 1; + } + } + return 0; +} + + +# rand_test() +# +# Think up a random ARRAY, OFFSET, LENGTH, LIST, and context. +# ARRAY or LIST might be empty, and OFFSET or LENGTH might be +# undefined. Return a 'test' - a listref of these five things. +# +sub rand_test { + die 'usage: rand_test()' if @_; + my @contexts = qw<list scalar void>; + my $context = $contexts[int(rand @contexts)]; + return [ rand_list(), + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + rand_list(), + $context ]; +} + + +sub rand_list { + die 'usage: rand_list()' if @_; + my @r; + + while (rand() > 0.1 * (scalar @r + 1)) { + push @r, rand_word(); + } + return \@r; +} + + +sub rand_word { + die 'usage: rand_word()' if @_; + my $r = ''; + my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>; + while (rand() > 0.1 * (length($r) + 1)) { + $r .= $chars[int(rand(scalar @chars))]; + } + return $r; +} + + diff --git a/bdb/perl/DB_File/typemap b/bdb/perl/DB_File/typemap new file mode 100644 index 00000000000..8ad7b1282dc --- /dev/null +++ b/bdb/perl/DB_File/typemap @@ -0,0 +1,46 @@ +# typemap for Perl 5 interface to Berkeley +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# last modified 10th December 2000 +# version 1.74 +# +#################################### DB SECTION +# +# + +u_int T_U_INT +DB_File T_PTROBJ +DBT T_dbtdatum +DBTKEY T_dbtkeydatum + +INPUT +T_dbtkeydatum + DBM_ckFilter($arg, filter_store_key, \"filter_store_key\"); + DBT_clear($var) ; + if (SvOK($arg)){ + if (db->type != DB_RECNO) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + else { + Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; + $var.data = & Value; + $var.size = (int)sizeof(recno_t); + } + } +T_dbtdatum + DBM_ckFilter($arg, filter_store_value, \"filter_store_value\"); + DBT_clear($var) ; + if (SvOK($arg)) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + +OUTPUT + +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/bdb/perl/DB_File/version.c b/bdb/perl/DB_File/version.c new file mode 100644 index 00000000000..03b17c18e60 --- /dev/null +++ b/bdb/perl/DB_File/version.c @@ -0,0 +1,82 @@ +/* + + version.c -- Perl 5 interface to Berkeley DB + + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 2nd Jan 2002 + version 1.802 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995-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. + + Changes: + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + 1.72 - No change. + 1.73 - Added support for threading + 1.74 - Added Perl core patch 7801. + + +*/ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <db.h> + +void +#ifdef CAN_PROTOTYPE +__getBerkeleyDBInfo(void) +#else +__getBerkeleyDBInfo() +#endif +{ +#ifdef dTHX + dTHX; +#endif + SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; + SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ; + SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ; + +#ifdef DB_VERSION_MAJOR + int Major, Minor, Patch ; + + (void)db_version(&Major, &Minor, &Patch) ; + + /* Check that the versions of db.h and libdb.a are the same */ + if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR + || Patch != DB_VERSION_PATCH) + croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n", + DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, + Major, Minor, Patch) ; + + /* check that libdb is recent enough -- we need 2.3.4 or greater */ + if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", + Major, Minor, Patch) ; + + { + char buffer[40] ; + sprintf(buffer, "%d.%d", Major, Minor) ; + sv_setpv(version_sv, buffer) ; + sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ; + sv_setpv(ver_sv, buffer) ; + } + +#else /* ! DB_VERSION_MAJOR */ + sv_setiv(version_sv, 1) ; + sv_setiv(ver_sv, 1) ; +#endif /* ! DB_VERSION_MAJOR */ + +#ifdef COMPAT185 + sv_setiv(compat_sv, 1) ; +#else /* ! COMPAT185 */ + sv_setiv(compat_sv, 0) ; +#endif /* ! COMPAT185 */ + +} |