diff options
Diffstat (limited to 'bdb/perl.BerkeleyDB')
49 files changed, 0 insertions, 19909 deletions
diff --git a/bdb/perl.BerkeleyDB/BerkeleyDB.pm b/bdb/perl.BerkeleyDB/BerkeleyDB.pm deleted file mode 100644 index cc172a2bd22..00000000000 --- a/bdb/perl.BerkeleyDB/BerkeleyDB.pm +++ /dev/null @@ -1,1227 +0,0 @@ - -package BerkeleyDB; - - -# Copyright (c) 1997-2001 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); - -$VERSION = '0.13'; - -require Exporter; -require DynaLoader; -require AutoLoader; -use IO ; - -@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. -@EXPORT = qw( - - DB_AFTER - DB_APPEND - DB_ARCH_ABS - DB_ARCH_DATA - DB_ARCH_LOG - DB_BEFORE - DB_BTREE - DB_BTREEMAGIC - DB_BTREEOLDVER - DB_BTREEVERSION - DB_CHECKPOINT - DB_CONSUME - DB_CREATE - DB_CURLSN - DB_CURRENT - DB_DBT_MALLOC - DB_DBT_PARTIAL - DB_DBT_USERMEM - DB_DELETED - DB_DELIMITER - DB_DUP - DB_DUPSORT - DB_ENV_APPINIT - DB_ENV_STANDALONE - DB_ENV_THREAD - DB_EXCL - DB_FILE_ID_LEN - DB_FIRST - DB_FIXEDLEN - DB_FLUSH - DB_FORCE - DB_GET_BOTH - DB_GET_RECNO - 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_JOIN_ITEM - DB_KEYEMPTY - DB_KEYEXIST - DB_KEYFIRST - DB_KEYLAST - DB_LAST - DB_LOCKMAGIC - DB_LOCKVERSION - DB_LOCK_CONFLICT - DB_LOCK_DEADLOCK - DB_LOCK_DEFAULT - DB_LOCK_GET - DB_LOCK_NORUN - DB_LOCK_NOTGRANTED - DB_LOCK_NOTHELD - DB_LOCK_NOWAIT - DB_LOCK_OLDEST - DB_LOCK_RANDOM - DB_LOCK_RIW_N - DB_LOCK_RW_N - DB_LOCK_YOUNGEST - DB_LOGMAGIC - DB_LOGOLDVER - DB_MAX_PAGES - DB_MAX_RECORDS - DB_MPOOL_CLEAN - DB_MPOOL_CREATE - DB_MPOOL_DIRTY - DB_MPOOL_DISCARD - DB_MPOOL_LAST - DB_MPOOL_NEW - DB_MPOOL_PRIVATE - DB_MUTEXDEBUG - DB_MUTEXLOCKS - DB_NEEDSPLIT - DB_NEXT - DB_NEXT_DUP - DB_NOMMAP - DB_NOOVERWRITE - DB_NOSYNC - DB_NOTFOUND - DB_PAD - DB_PAGEYIELD - DB_POSITION - DB_PREV - DB_PRIVATE - DB_QUEUE - DB_RDONLY - DB_RECNO - DB_RECNUM - DB_RECORDCOUNT - DB_RECOVER - DB_RECOVER_FATAL - DB_REGISTERED - DB_RENUMBER - DB_RMW - DB_RUNRECOVERY - DB_SEQUENTIAL - DB_SET - DB_SET_RANGE - DB_SET_RECNO - DB_SNAPSHOT - DB_SWAPBYTES - DB_TEMPORARY - DB_THREAD - DB_TRUNCATE - DB_TXNMAGIC - DB_TXNVERSION - DB_TXN_BACKWARD_ROLL - DB_TXN_CKP - DB_TXN_FORWARD_ROLL - 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_REDO - DB_TXN_SYNC - DB_TXN_UNDO - DB_USE_ENVIRON - DB_USE_ENVIRON_ROOT - DB_VERSION_MAJOR - DB_VERSION_MINOR - DB_VERSION_PATCH - DB_WRITECURSOR - ); - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - my $constname; - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined BerkeleyDB macro $constname"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -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->{ErrFile}) { - if (!isaFilehandle($got->{ErrFile})) { - my $handle = new IO::File ">$got->{ErrFile}" - or croak "Cannot open file $got->{ErrFile}: $!\n" ; - $got->{ErrFile} = $handle ; - } - } - - - 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); -} - -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 ) ; - -sub new -{ - # Usage: - # - # $env = new BerkeleyDB::Env - # [ -Home => $path, ] - # [ -Mode => mode, ] - # [ -Config => { name => value, name => value } - # [ -ErrFile => filename or filehandle, ] - # [ -ErrPrefix => "string", ] - # [ -Flags => DB_INIT_LOCK| ] - # [ -Cachesize => number ] - # [ -LockDetect => ] - # [ -Verbose => boolean ] - # ; - - my $pkg = shift ; - my $got = BerkeleyDB::ParseParameters({ - Home => undef, - Server => undef, - Mode => 0666, - ErrFile => undef, - ErrPrefix => undef, - Flags => 0, - Cachesize => 0, - LockDetect => 0, - Verbose => 0, - Config => undef, - }, @_) ; - - if (defined $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') - { $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 ; - - - 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 ; - -## 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; - croak "unshift is unsupported with Queue databases" - if $self->type == BerkeleyDB::DB_QUEUE() ; - if (@_) - { - my ($key, $value) = (0, 0) ; - my $cursor = $self->db_cursor() ; - if ($cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) == 0) - { - foreach $value (reverse @_) - { - $key = 0 ; - $cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ; - } - } - } -} - -sub PUSH -{ - my $self = shift; - if (@_) - { - my ($key, $value) = (0, 0) ; - my $cursor = $self->db_cursor() ; - if ($cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) == 0) - { - foreach $value (@_) - { - ++ $key ; - $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] , "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 deleted file mode 100644 index 2c5c3feb51e..00000000000 --- a/bdb/perl.BerkeleyDB/BerkeleyDB.pod +++ /dev/null @@ -1,1751 +0,0 @@ -=head1 NAME - -BerkeleyDB - Perl extension for Berkeley DB version 2 or 3 - -=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] - - $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() ; - $hash_ref = $db->db_stat() ; - $status = $db->db_key_range(); - $type = $db->type() ; - $status = $db->status() ; - $boolean = $db->byteswapped() ; - - ($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->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() - - $txn = $env->txn_begin() ; - $status = $txn->txn_prepare() - $status = $txn->txn_commit() - $status = $txn->txn_abort() - $status = $txn->txn_id() - - $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 and 3. 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 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. 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 or filehandle, ] - [ -ErrPrefix => "string", ] - [ -Flags => number, ] - [ -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 either the name of a file or a reference to a filehandle. 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 -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 $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 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. - -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. - -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. - -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. 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. - -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. - -=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, 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. - -=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 or 3.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 3.x. - -=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-2001 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 deleted file mode 100644 index 2bcff2d99d1..00000000000 --- a/bdb/perl.BerkeleyDB/BerkeleyDB.pod.P +++ /dev/null @@ -1,1518 +0,0 @@ -=head1 NAME - -BerkeleyDB - Perl extension for Berkeley DB version 2 or 3 - -=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] - - $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() ; - $hash_ref = $db->db_stat() ; - $status = $db->db_key_range(); - $type = $db->type() ; - $status = $db->status() ; - $boolean = $db->byteswapped() ; - - ($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->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() - - $txn = $env->txn_begin() ; - $status = $txn->txn_prepare() - $status = $txn->txn_commit() - $status = $txn->txn_abort() - $status = $txn->txn_id() - - $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 and 3. 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 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. 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 or filehandle, ] - [ -ErrPrefix => "string", ] - [ -Flags => number, ] - [ -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 either the name of a file or a reference to a filehandle. 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 -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 $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 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. - -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. - -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. - -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. 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. - -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. - -=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, 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. - -=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 or 3.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 3.x. - -=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-2001 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 deleted file mode 100644 index 19126c98b53..00000000000 --- a/bdb/perl.BerkeleyDB/BerkeleyDB.xs +++ /dev/null @@ -1,3927 +0,0 @@ -/* - - 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-2001 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" - -/* 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__ - -#ifndef PERL_VERSION -# include "patchlevel.h" -# define PERL_REVISION 5 -# define PERL_VERSION PATCHLEVEL -# define PERL_SUBVERSION SUBVERSION -#endif - -#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) - -# define PL_sv_undef sv_undef -# define PL_na na -# define PL_dirty dirty - -#endif - -#include <db.h> - -#if (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0) -# define IS_DB_3_0 -#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 - -/* need to define DEFSV & SAVE_DEFSV for older version of Perl */ -#ifndef DEFSV -# define DEFSV GvSV(defgv) -#endif - -#ifndef SAVE_DEFSV -# define SAVE_DEFSV SAVESPTR(GvSV(defgv)) -#endif - -#ifndef pTHX -# define pTHX -# define pTHX_ -# define aTHX -# define aTHX_ -#endif - -#ifndef dTHR -# define dTHR -#endif - -#ifndef newSVpvn -# define newSVpvn(a,b) newSVpv(a,b) -#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 ; - SV * 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 ; - SV * dup_compare ; - SV * prefix ; - SV * hash ; - 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 ; - 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, IV 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 - -#ifdef DBM_FILTERING -#define ckFilter(arg,type,name) \ - if (db->type) { \ - SV * save_defsv ; \ - /* printf("filtering %s\n", name) ;*/ \ - if (db->filtering) \ - softCrash("recursion detected in %s", name) ; \ - db->filtering = TRUE ; \ - save_defsv = newSVsv(DEFSV) ; \ - sv_setsv(DEFSV, arg) ; \ - PUSHMARK(sp) ; \ - (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ - sv_setsv(arg, DEFSV) ; \ - sv_setsv(DEFSV, save_defsv) ; \ - SvREFCNT_dec(save_defsv) ; \ - db->filtering = FALSE ; \ - /*printf("end of filtering %s\n", name) ;*/ \ - } -#else -#define ckFilter(type, sv, name) -#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) SvIV(*av_fetch((AV*)SvRV(x), 0, FALSE)) -#else -#define getInnerObject(x) SvIV((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 = IoOFP(sv_2io(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 = getInnerObject(sv) ; \ - i = (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 = (t) tmp ; \ - } - -#define SetValue_ovX(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\ - IV tmp = SvIV(GetInternalObject(sv));\ - i = (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) ; \ - 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) ; \ - } \ - 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); \ - 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); \ - } \ - 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 ; -static char ErrBuff[1000] ; - -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 */ - -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; -} - -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); - I32 ret = hv_iterinit(hv) ; - int all = 0 ; - int closed = 0 ; - Trace(("BerkeleyDB::Term::close_all_txns dirty=%d\n", PL_dirty)) ; - while ( he = hv_iternext(hv) ) { - tid = * (BerkeleyDB__Txn__Raw *) (IV) hv_iterkey(he, &len) ; - Trace((" Aborting Transaction [%d] in [%d] Active [%d]\n", tid->txn, tid, tid->active)); - if (tid->active) { - txn_abort(tid->txn); - ++ 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); - I32 ret = hv_iterinit(hv) ; - int all = 0 ; - int closed = 0 ; - Trace(("BerkeleyDB::Term::close_all_cursors \n")) ; - while ( he = hv_iternext(hv) ) { - db = * (BerkeleyDB__Cursor*) (IV) 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); - I32 ret = hv_iterinit(hv) ; - int all = 0 ; - int closed = 0 ; - Trace(("BerkeleyDB::Term::close_all_dbs\n" )) ; - while ( he = hv_iternext(hv) ) { - db = * (BerkeleyDB*) (IV) 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); - I32 ret = hv_iterinit(hv) ; - int all = 0 ; - int closed = 0 ; - Trace(("BerkeleyDB::Term::close_all_envs\n")) ; - while ( he = hv_iternext(hv) ) { - env = * (BerkeleyDB__Env*) (IV) 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) ; - 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", (IV)db) ; - if (db->filename) - Safefree(db->filename) ; - Safefree(db) ; -} - -static void -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); -} - - -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 */ - -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 ; -} - -static int -btree_compare(DB_callback const DBT * key1, const DBT * key2 ) -{ - dSP ; - void * data1, * data2 ; - int retval ; - int count ; - - data1 = key1->data ; - data2 = 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 ; - return (retval) ; - -} - -static int -dup_compare(DB_callback const DBT * key1, const DBT * key2 ) -{ - dSP ; - void * data1, * data2 ; - int retval ; - int count ; - - 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 = key1->data ; - data2 = 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 ; - return (retval) ; - -} - -static size_t -btree_prefix(DB_callback const DBT * key1, const DBT * key2 ) -{ - dSP ; - void * data1, * data2 ; - int retval ; - int count ; - - data1 = key1->data ; - data2 = 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 ; - - return (retval) ; -} - -static u_int32_t -hash_cb(DB_callback const void * data, u_int32_t size) -{ - dSP ; - int retval ; - int count ; - -#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 ; - - return (retval) ; -} - -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, IV 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, IV key, IV value) -{ - HV * hv = perl_get_hv(hash, TRUE); - SV ** ret = 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 , - 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 ; - - Trace(("_db_open(dbenv[%lu] ref_dbenv [%lu] 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 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 ; - - 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 [%d] 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 - } - - if ((Status = (dbp->open)(dbp, file, subname, type, flags, mode)) == 0) { -#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\n")); - RETVAL = db ; - RETVAL->dbp = dbp ; -#if DB_VERSION_MAJOR == 2 - RETVAL->type = dbp->type ; -#else /* DB_VERSION_MAJOR > 2 */ - RETVAL->type = dbp->get_type(dbp) ; -#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", (IV)RETVAL, 1) ; - Trace((" storing %d %d 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 ; -} - -static double -constant(char * name, int arg) -{ - errno = 0; - switch (*name) { - case 'A': - break; - case 'B': - break; - case 'C': - break; - case 'D': - if (strEQ(name, "DB_AFTER")) -#ifdef DB_AFTER - return DB_AFTER; -#else - goto not_there; -#endif - if (strEQ(name, "DB_APPEND")) -#ifdef DB_APPEND - return DB_APPEND; -#else - goto not_there; -#endif - if (strEQ(name, "DB_ARCH_ABS")) -#ifdef DB_ARCH_ABS - return DB_ARCH_ABS; -#else - goto not_there; -#endif - if (strEQ(name, "DB_ARCH_DATA")) -#ifdef DB_ARCH_DATA - return DB_ARCH_DATA; -#else - goto not_there; -#endif - if (strEQ(name, "DB_ARCH_LOG")) -#ifdef DB_ARCH_LOG - return DB_ARCH_LOG; -#else - goto not_there; -#endif - if (strEQ(name, "DB_BEFORE")) -#ifdef DB_BEFORE - return DB_BEFORE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_BTREE")) - return DB_BTREE; - if (strEQ(name, "DB_BTREEMAGIC")) -#ifdef DB_BTREEMAGIC - return DB_BTREEMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_BTREEOLDVER")) -#ifdef DB_BTREEOLDVER - return DB_BTREEOLDVER; -#else - goto not_there; -#endif - if (strEQ(name, "DB_BTREEVERSION")) -#ifdef DB_BTREEVERSION - return DB_BTREEVERSION; -#else - goto not_there; -#endif - if (strEQ(name, "DB_CHECKPOINT")) -#ifdef DB_CHECKPOINT - return DB_CHECKPOINT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_CONSUME")) -#ifdef DB_CONSUME - return DB_CONSUME; -#else - goto not_there; -#endif - if (strEQ(name, "DB_CREATE")) -#ifdef DB_CREATE - return DB_CREATE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_CURLSN")) -#ifdef DB_CURLSN - return DB_CURLSN; -#else - goto not_there; -#endif - if (strEQ(name, "DB_CURRENT")) -#ifdef DB_CURRENT - return DB_CURRENT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_DBT_MALLOC")) -#ifdef DB_DBT_MALLOC - return DB_DBT_MALLOC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_DBT_PARTIAL")) -#ifdef DB_DBT_PARTIAL - return DB_DBT_PARTIAL; -#else - goto not_there; -#endif - if (strEQ(name, "DB_DBT_USERMEM")) -#ifdef DB_DBT_USERMEM - return DB_DBT_USERMEM; -#else - goto not_there; -#endif - if (strEQ(name, "DB_DELETED")) -#ifdef DB_DELETED - return DB_DELETED; -#else - goto not_there; -#endif - if (strEQ(name, "DB_DELIMITER")) -#ifdef DB_DELIMITER - return DB_DELIMITER; -#else - goto not_there; -#endif - if (strEQ(name, "DB_DUP")) -#ifdef DB_DUP - return DB_DUP; -#else - goto not_there; -#endif - if (strEQ(name, "DB_DUPSORT")) -#ifdef DB_DUPSORT - return DB_DUPSORT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_ENV_APPINIT")) -#ifdef DB_ENV_APPINIT - return DB_ENV_APPINIT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_ENV_STANDALONE")) -#ifdef DB_ENV_STANDALONE - return DB_ENV_STANDALONE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_ENV_THREAD")) -#ifdef DB_ENV_THREAD - return DB_ENV_THREAD; -#else - goto not_there; -#endif - if (strEQ(name, "DB_EXCL")) -#ifdef DB_EXCL - return DB_EXCL; -#else - goto not_there; -#endif - if (strEQ(name, "DB_FILE_ID_LEN")) -#ifdef DB_FILE_ID_LEN - return DB_FILE_ID_LEN; -#else - goto not_there; -#endif - if (strEQ(name, "DB_FIRST")) -#ifdef DB_FIRST - return DB_FIRST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_FIXEDLEN")) -#ifdef DB_FIXEDLEN - return DB_FIXEDLEN; -#else - goto not_there; -#endif - if (strEQ(name, "DB_FLUSH")) -#ifdef DB_FLUSH - return DB_FLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "DB_FORCE")) -#ifdef DB_FORCE - return DB_FORCE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_GET_BOTH")) -#ifdef DB_GET_BOTH - return DB_GET_BOTH; -#else - goto not_there; -#endif - if (strEQ(name, "DB_GET_RECNO")) -#ifdef DB_GET_RECNO - return DB_GET_RECNO; -#else - goto not_there; -#endif - if (strEQ(name, "DB_HASH")) - return DB_HASH; - if (strEQ(name, "DB_HASHMAGIC")) -#ifdef DB_HASHMAGIC - return DB_HASHMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_HASHOLDVER")) -#ifdef DB_HASHOLDVER - return DB_HASHOLDVER; -#else - goto not_there; -#endif - if (strEQ(name, "DB_HASHVERSION")) -#ifdef DB_HASHVERSION - return DB_HASHVERSION; -#else - goto not_there; -#endif - if (strEQ(name, "DB_INCOMPLETE")) -#ifdef DB_INCOMPLETE - return DB_INCOMPLETE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_INIT_CDB")) -#ifdef DB_INIT_CDB - return DB_INIT_CDB; -#else - goto not_there; -#endif - if (strEQ(name, "DB_INIT_LOCK")) -#ifdef DB_INIT_LOCK - return DB_INIT_LOCK; -#else - goto not_there; -#endif - if (strEQ(name, "DB_INIT_LOG")) -#ifdef DB_INIT_LOG - return DB_INIT_LOG; -#else - goto not_there; -#endif - if (strEQ(name, "DB_INIT_MPOOL")) -#ifdef DB_INIT_MPOOL - return DB_INIT_MPOOL; -#else - goto not_there; -#endif - if (strEQ(name, "DB_INIT_TXN")) -#ifdef DB_INIT_TXN - return DB_INIT_TXN; -#else - goto not_there; -#endif - if (strEQ(name, "DB_JOIN_ITEM")) -#ifdef DB_JOIN_ITEM - return DB_JOIN_ITEM; -#else - goto not_there; -#endif - if (strEQ(name, "DB_KEYEMPTY")) -#ifdef DB_KEYEMPTY - return DB_KEYEMPTY; -#else - goto not_there; -#endif - if (strEQ(name, "DB_KEYEXIST")) -#ifdef DB_KEYEXIST - return DB_KEYEXIST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_KEYFIRST")) -#ifdef DB_KEYFIRST - return DB_KEYFIRST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_KEYLAST")) -#ifdef DB_KEYLAST - return DB_KEYLAST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LAST")) -#ifdef DB_LAST - return DB_LAST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCKMAGIC")) -#ifdef DB_LOCKMAGIC - return DB_LOCKMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCKVERSION")) -#ifdef DB_LOCKVERSION - return DB_LOCKVERSION; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_CONFLICT")) -#ifdef DB_LOCK_CONFLICT - return DB_LOCK_CONFLICT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_DEADLOCK")) -#ifdef DB_LOCK_DEADLOCK - return DB_LOCK_DEADLOCK; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_DEFAULT")) -#ifdef DB_LOCK_DEFAULT - return DB_LOCK_DEFAULT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_GET")) - return DB_LOCK_GET; - if (strEQ(name, "DB_LOCK_NORUN")) -#ifdef DB_LOCK_NORUN - return DB_LOCK_NORUN; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_NOTGRANTED")) -#ifdef DB_LOCK_NOTGRANTED - return DB_LOCK_NOTGRANTED; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_NOTHELD")) -#ifdef DB_LOCK_NOTHELD - return DB_LOCK_NOTHELD; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_NOWAIT")) -#ifdef DB_LOCK_NOWAIT - return DB_LOCK_NOWAIT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_OLDEST")) -#ifdef DB_LOCK_OLDEST - return DB_LOCK_OLDEST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_RANDOM")) -#ifdef DB_LOCK_RANDOM - return DB_LOCK_RANDOM; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_RIW_N")) -#ifdef DB_LOCK_RIW_N - return DB_LOCK_RIW_N; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_RW_N")) -#ifdef DB_LOCK_RW_N - return DB_LOCK_RW_N; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOCK_YOUNGEST")) -#ifdef DB_LOCK_YOUNGEST - return DB_LOCK_YOUNGEST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOGMAGIC")) -#ifdef DB_LOGMAGIC - return DB_LOGMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_LOGOLDVER")) -#ifdef DB_LOGOLDVER - return DB_LOGOLDVER; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MAX_PAGES")) -#ifdef DB_MAX_PAGES - return DB_MAX_PAGES; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MAX_RECORDS")) -#ifdef DB_MAX_RECORDS - return DB_MAX_RECORDS; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MPOOL_CLEAN")) -#ifdef DB_MPOOL_CLEAN - return DB_MPOOL_CLEAN; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MPOOL_CREATE")) -#ifdef DB_MPOOL_CREATE - return DB_MPOOL_CREATE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MPOOL_DIRTY")) -#ifdef DB_MPOOL_DIRTY - return DB_MPOOL_DIRTY; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MPOOL_DISCARD")) -#ifdef DB_MPOOL_DISCARD - return DB_MPOOL_DISCARD; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MPOOL_LAST")) -#ifdef DB_MPOOL_LAST - return DB_MPOOL_LAST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MPOOL_NEW")) -#ifdef DB_MPOOL_NEW - return DB_MPOOL_NEW; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MPOOL_PRIVATE")) -#ifdef DB_MPOOL_PRIVATE - return DB_MPOOL_PRIVATE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MUTEXDEBUG")) -#ifdef DB_MUTEXDEBUG - return DB_MUTEXDEBUG; -#else - goto not_there; -#endif - if (strEQ(name, "DB_MUTEXLOCKS")) -#ifdef DB_MUTEXLOCKS - return DB_MUTEXLOCKS; -#else - goto not_there; -#endif - if (strEQ(name, "DB_NEEDSPLIT")) -#ifdef DB_NEEDSPLIT - return DB_NEEDSPLIT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_NEXT")) -#ifdef DB_NEXT - return DB_NEXT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_NEXT_DUP")) -#ifdef DB_NEXT_DUP - return DB_NEXT_DUP; -#else - goto not_there; -#endif - if (strEQ(name, "DB_NOMMAP")) -#ifdef DB_NOMMAP - return DB_NOMMAP; -#else - goto not_there; -#endif - if (strEQ(name, "DB_NOOVERWRITE")) -#ifdef DB_NOOVERWRITE - return DB_NOOVERWRITE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_NOSYNC")) -#ifdef DB_NOSYNC - return DB_NOSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_NOTFOUND")) -#ifdef DB_NOTFOUND - return DB_NOTFOUND; -#else - goto not_there; -#endif - if (strEQ(name, "DB_PAD")) -#ifdef DB_PAD - return DB_PAD; -#else - goto not_there; -#endif - if (strEQ(name, "DB_PAGEYIELD")) -#ifdef DB_PAGEYIELD - return DB_PAGEYIELD; -#else - goto not_there; -#endif - if (strEQ(name, "DB_POSITION")) -#ifdef DB_POSITION - return DB_POSITION; -#else - goto not_there; -#endif - if (strEQ(name, "DB_PREV")) -#ifdef DB_PREV - return DB_PREV; -#else - goto not_there; -#endif - if (strEQ(name, "DB_PRIVATE")) -#ifdef DB_PRIVATE - return DB_PRIVATE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_QUEUE")) - return DB_QUEUE; - if (strEQ(name, "DB_RDONLY")) -#ifdef DB_RDONLY - return DB_RDONLY; -#else - goto not_there; -#endif - if (strEQ(name, "DB_RECNO")) - return DB_RECNO; - if (strEQ(name, "DB_RECNUM")) -#ifdef DB_RECNUM - return DB_RECNUM; -#else - goto not_there; -#endif - if (strEQ(name, "DB_RECORDCOUNT")) -#ifdef DB_RECORDCOUNT - return DB_RECORDCOUNT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_RECOVER")) -#ifdef DB_RECOVER - return DB_RECOVER; -#else - goto not_there; -#endif - if (strEQ(name, "DB_RECOVER_FATAL")) -#ifdef DB_RECOVER_FATAL - return DB_RECOVER_FATAL; -#else - goto not_there; -#endif - if (strEQ(name, "DB_REGISTERED")) -#ifdef DB_REGISTERED - return DB_REGISTERED; -#else - goto not_there; -#endif - if (strEQ(name, "DB_RENUMBER")) -#ifdef DB_RENUMBER - return DB_RENUMBER; -#else - goto not_there; -#endif - if (strEQ(name, "DB_RMW")) -#ifdef DB_RMW - return DB_RMW; -#else - goto not_there; -#endif - if (strEQ(name, "DB_RUNRECOVERY")) -#ifdef DB_RUNRECOVERY - return DB_RUNRECOVERY; -#else - goto not_there; -#endif - if (strEQ(name, "DB_SEQUENTIAL")) -#ifdef DB_SEQUENTIAL - return DB_SEQUENTIAL; -#else - goto not_there; -#endif - if (strEQ(name, "DB_SET")) -#ifdef DB_SET - return DB_SET; -#else - goto not_there; -#endif - if (strEQ(name, "DB_SET_RANGE")) -#ifdef DB_SET_RANGE - return DB_SET_RANGE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_SET_RECNO")) -#ifdef DB_SET_RECNO - return DB_SET_RECNO; -#else - goto not_there; -#endif - if (strEQ(name, "DB_SNAPSHOT")) -#ifdef DB_SNAPSHOT - return DB_SNAPSHOT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_SWAPBYTES")) -#ifdef DB_SWAPBYTES - return DB_SWAPBYTES; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TEMPORARY")) -#ifdef DB_TEMPORARY - return DB_TEMPORARY; -#else - goto not_there; -#endif - if (strEQ(name, "DB_THREAD")) -#ifdef DB_THREAD - return DB_THREAD; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TRUNCATE")) -#ifdef DB_TRUNCATE - return DB_TRUNCATE; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXNMAGIC")) -#ifdef DB_TXNMAGIC - return DB_TXNMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXNVERSION")) -#ifdef DB_TXNVERSION - return DB_TXNVERSION; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_BACKWARD_ROLL")) - return DB_TXN_BACKWARD_ROLL; - if (strEQ(name, "DB_TXN_CKP")) -#ifdef DB_TXN_CKP - return DB_TXN_CKP; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_FORWARD_ROLL")) - return DB_TXN_FORWARD_ROLL; - if (strEQ(name, "DB_TXN_LOCK_2PL")) -#ifdef DB_TXN_LOCK_2PL - return DB_TXN_LOCK_2PL; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_LOCK_MASK")) -#ifdef DB_TXN_LOCK_MASK - return DB_TXN_LOCK_MASK; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_LOCK_OPTIMIST")) -#ifdef DB_TXN_LOCK_OPTIMIST - return DB_TXN_LOCK_OPTIMIST; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_LOCK_OPTIMISTIC")) -#ifdef DB_TXN_LOCK_OPTIMISTIC - return DB_TXN_LOCK_OPTIMISTIC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_LOG_MASK")) -#ifdef DB_TXN_LOG_MASK - return DB_TXN_LOG_MASK; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_LOG_REDO")) -#ifdef DB_TXN_LOG_REDO - return DB_TXN_LOG_REDO; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_LOG_UNDO")) -#ifdef DB_TXN_LOG_UNDO - return DB_TXN_LOG_UNDO; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_LOG_UNDOREDO")) -#ifdef DB_TXN_LOG_UNDOREDO - return DB_TXN_LOG_UNDOREDO; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_NOSYNC")) -#ifdef DB_TXN_NOSYNC - return DB_TXN_NOSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_NOWAIT")) -#ifdef DB_TXN_NOWAIT - return DB_TXN_NOWAIT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_OPENFILES")) - return DB_TXN_OPENFILES; - if (strEQ(name, "DB_TXN_REDO")) -#ifdef DB_TXN_REDO - return DB_TXN_REDO; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_SYNC")) -#ifdef DB_TXN_SYNC - return DB_TXN_SYNC; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN_UNDO")) -#ifdef DB_TXN_UNDO - return DB_TXN_UNDO; -#else - goto not_there; -#endif - if (strEQ(name, "DB_UNKNOWN")) - return DB_UNKNOWN; - if (strEQ(name, "DB_USE_ENVIRON")) -#ifdef DB_USE_ENVIRON - return DB_USE_ENVIRON; -#else - goto not_there; -#endif - if (strEQ(name, "DB_USE_ENVIRON_ROOT")) -#ifdef DB_USE_ENVIRON_ROOT - return DB_USE_ENVIRON_ROOT; -#else - goto not_there; -#endif - if (strEQ(name, "DB_VERSION_MAJOR")) -#ifdef DB_VERSION_MAJOR - return DB_VERSION_MAJOR; -#else - goto not_there; -#endif - if (strEQ(name, "DB_VERSION_MINOR")) -#ifdef DB_VERSION_MINOR - return DB_VERSION_MINOR; -#else - goto not_there; -#endif - if (strEQ(name, "DB_VERSION_PATCH")) -#ifdef DB_VERSION_PATCH - return DB_VERSION_PATCH; -#else - goto not_there; -#endif - if (strEQ(name, "DB_WRITECURSOR")) -#ifdef DB_WRITECURSOR - return DB_WRITECURSOR; -#else - goto not_there; -#endif - break; - case 'E': - break; - case 'F': - break; - case 'G': - break; - case 'H': - break; - case 'I': - break; - case 'J': - break; - case 'K': - break; - case 'L': - break; - case 'M': - break; - case 'N': - break; - case 'O': - break; - case 'P': - break; - case 'Q': - break; - case 'R': - break; - case 'S': - break; - case 'T': - break; - case 'U': - break; - case 'V': - break; - case 'W': - break; - case 'X': - break; - case 'Y': - break; - case 'Z': - break; - case 'a': - break; - case 'b': - break; - case 'c': - break; - case 'd': - break; - case 'e': - break; - case 'f': - break; - case 'g': - break; - case 'h': - break; - case 'i': - break; - case 'j': - break; - case 'k': - break; - case 'l': - break; - case 'm': - break; - case 'n': - break; - case 'o': - break; - case 'p': - break; - case 'q': - break; - case 'r': - break; - case 's': - break; - case 't': - break; - case 'u': - break; - case 'v': - break; - case 'w': - break; - case 'x': - break; - case 'y': - break; - case 'z': - break; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - - -MODULE = BerkeleyDB PACKAGE = BerkeleyDB PREFIX = env_ - -char * -DB_VERSION_STRING() - CODE: - RETVAL = DB_VERSION_STRING ; - OUTPUT: - RETVAL - - -double -constant(name,arg) - char * name - int arg - -#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 ; - 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 - -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 * server = NULL ; - char ** config = NULL ; - int flags = 0 ; - int cachesize = 0 ; - int lk_detect = 0 ; - int mode = 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_pv(server, "Server", char *) ; - SetValue_iv(cachesize, "Cachesize") ; - SetValue_iv(lk_detect, "LockDetect") ; -#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) ; - - if ((sv = readHash(hash, "ErrFile")) && sv != &PL_sv_undef) { - env->db_errfile = IoOFP(sv_2io(sv)) ; - RETVAL->ErrHandle = newRV(sv) ; - } - /* SetValue_io(RETVAL->Env.db_errfile, "ErrFile") ; */ - SetValue_iv(env->db_verbose, "Verbose") ; - /* env->db_errbuf = RETVAL->ErrBuff ; */ - 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", (IV)RETVAL, 1) ; - else { - if (RETVAL->ErrHandle) - SvREFCNT_dec(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 ; - 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_3_1 - /* 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 - if (status == 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)) ; - - if ((sv = readHash(hash, "ErrFile")) && sv != &PL_sv_undef) { - env->set_errfile(env, IoOFP(sv_2io(sv))) ; - RETVAL->ErrHandle = newRV(sv) ; - } - /* SetValue_iv(RETVAL->Env.db_verbose, "Verbose") ; */ /* TODO */ - SetValue_iv(mode, "Mode") ; - /* RETVAL->Env.db_errbuf = RETVAL->ErrBuff ; */ - env->set_errcall(env, db_errcall_cb) ; - RETVAL->active = TRUE ; -#ifdef IS_DB_3_0 - 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", (IV)RETVAL, 1) ; - else { - (env->close)(env, 0) ; - if (RETVAL->ErrHandle) - SvREFCNT_dec(RETVAL->ErrHandle) ; - if (RETVAL->ErrPrefix) - SvREFCNT_dec(RETVAL->ErrPrefix) ; - Safefree(RETVAL) ; - RETVAL = NULL ; - } -#endif /* DB_VERSION_MAJOR > 2 */ - } - OUTPUT: - RETVAL - -BerkeleyDB::Txn::Raw -_txn_begin(env, pid=NULL, flags=0) - BerkeleyDB::Env env - BerkeleyDB::Txn pid - u_int32_t flags - 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 - txn_begin(env->Env, p_id, &txn, flags) ; -#endif - if (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", (IV)RETVAL, 1) ; - } - else - RETVAL = NULL ; - } - OUTPUT: - RETVAL - - -#if DB_VERSION_MAJOR == 2 -# define env_txn_checkpoint(e,k,m) txn_checkpoint(e->Env->tx_info, k, m) -#else /* DB 3.0 or better */ -# ifdef AT_LEAST_DB_3_1 -# define env_txn_checkpoint(e,k,m) txn_checkpoint(e->Env, k, m, 0) -# else -# define env_txn_checkpoint(e,k,m) txn_checkpoint(e->Env, k, m) -# endif -#endif -DualType -env_txn_checkpoint(env, kbyte, min) - BerkeleyDB::Env env - long kbyte - long min - -HV * -txn_stat(env) - BerkeleyDB::Env env - HV * RETVAL = NULL ; - CODE: - { - DB_TXN_STAT * stat ; -#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 - 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 - 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", (IV)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) - SvREFCNT_dec(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", (IV)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", (IV)txn, 1) ; */ - 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_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_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 -#if defined(IS_DB_3_0) || defined(AT_LEAST_DB_3_2) - RETVAL = env->Status = env->Env->set_mutexlocks(env->Env, do_lock); -#else /* DB 3.1 */ - RETVAL = env->Status = db_env_set_mutexlocks(do_lock); -#endif -#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 ; - - Trace(("_db_open_hash start\n")) ; - hash = (HV*) SvRV(ref) ; - SetValue_pv(file, "Filename", char *) ; - SetValue_pv(subname, "Subname", char *) ; - 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, file, subname, DB_HASH, flags, mode, &info) ; - Trace(("_db_open_hash end\n")) ; - } - OUTPUT: - RETVAL - - -HV * -db_stat(db, flags=0) - BerkeleyDB::Common db - int flags - 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 ; - db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; - 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 - hv_store_iv(RETVAL, "hash_nelem", stat->hash_nelem); - 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 ; - static char * Names[] = {"", "Btree", "Hash", "Recno"} ; - - hash = (HV*) SvRV(ref) ; - SetValue_pv(file, "Filename", char *) ; - SetValue_pv(subname, "Subname", char *) ; - 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, file, subname, DB_UNKNOWN, flags, mode, &info) ; - XPUSHs(sv_2mortal(newSViv((IV)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 ; - - hash = (HV*) SvRV(ref) ; - SetValue_pv(file, "Filename", char*) ; - SetValue_pv(subname, "Subname", char *) ; - 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) { - 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 - 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) { - info.bt_prefix = btree_prefix ; - db->prefix = newSVsv(sv) ; - } - - RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, file, subname, DB_BTREE, flags, mode, &info) ; - } - OUTPUT: - RETVAL - - -HV * -db_stat(db, flags=0) - BerkeleyDB::Common db - int flags - HV * RETVAL = NULL ; - INIT: - ckActive_Database(db->active) ; - CODE: - { - DB_BTREE_STAT * stat ; - db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; - 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 ; - - hash = (HV*) SvRV(ref) ; - SetValue_pv(file, "Fname", char*) ; - 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") ; - 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, 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 ; - - hash = (HV*) SvRV(ref) ; - SetValue_pv(file, "Fname", char*) ; - 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.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_PAD) ; - } - 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, file, subname, DB_QUEUE, flags, mode, &info) ; -#endif - } - OUTPUT: - RETVAL - -HV * -db_stat(db, flags=0) - BerkeleyDB::Common db - int flags - 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 ; - db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; - 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) - BerkeleyDB::Common db - int flags - 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", (IV)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) - BerkeleyDB::Common db - u_int32_t flags - 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->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 ; - 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", (IV)RETVAL, 1) ; - } - } - OUTPUT: - RETVAL - -BerkeleyDB::Cursor::Raw -_db_join(db, cursors, flags=0) - BerkeleyDB::Common db - AV * cursors - u_int32_t flags - 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) ; - BerkeleyDB__Cursor cur = (BerkeleyDB__Cursor) getInnerObject(obj) ; - 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 ; - 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", (IV)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 - RETVAL = db->dbp->get_byteswapped(db->dbp) ; -#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: - setFilter(filter_fetch_key) ; - -SV * -filter_store_key(db, code) - BerkeleyDB::Common db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_key) ; - -SV * -filter_fetch_value(db, code) - BerkeleyDB::Common db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_value) ; - -SV * -filter_store_value(db, code) - BerkeleyDB::Common db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_value) ; - -#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) - BerkeleyDB::Common db - DBTKEY key - u_int flags - INIT: - ckActive_Database(db->active) ; - CurrentDB = db ; - - -#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) - BerkeleyDB::Common db - u_int flags - DBTKEY_B key - DBT_OPT data - INIT: - ckActive_Database(db->active) ; - CurrentDB = db ; - SetPartial(data,db) ; - OUTPUT: - key if (flagSet(DB_SET_RECNO)) OutputValue(ST(1), key) ; - 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) - BerkeleyDB::Common db - DBTKEY key - DBT data - u_int flags - INIT: - ckActive_Database(db->active) ; - CurrentDB = db ; - /* SetPartial(data,db) ; */ - OUTPUT: - 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) - BerkeleyDB::Common db - DBTKEY_B key - double less = NO_INIT - double equal = NO_INIT - double greater = NO_INIT - u_int32_t flags - 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) - BerkeleyDB::Common db - u_int flags - 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(%d in %d) active [%d]\n", txn->txn, txn, txn->active)); - ckActive_Transaction(txn->active) ; - db->txn = txn->txn ; - } - else { - Trace(("_Txn(undef) \n")); - db->txn = NULL ; - } - - - - -MODULE = BerkeleyDB::Cursor PACKAGE = BerkeleyDB::Cursor PREFIX = cu_ - -BerkeleyDB::Cursor::Raw -_c_dup(db, flags=0) - BerkeleyDB::Cursor db - u_int32_t flags - 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 ; - 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", (IV)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", (IV)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", (IV)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) - BerkeleyDB::Cursor db - int flags - 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) - BerkeleyDB::Cursor db - int flags - DBTKEY_B key - DBT_B data - INIT: - Trace(("c_get db [%d] flags [%d]\n", 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_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) - BerkeleyDB::Cursor db - DBTKEY key - DBT data - int flags - 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) - BerkeleyDB::Cursor db - u_int32_t count = NO_INIT - int flags - 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) - BerkeleyDB::TxnMgr txnmgr - BerkeleyDB::Txn pid - u_int32_t flags - 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 - txn_begin(txnmgr->env->Env, p_id, &txn, flags) ; -#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", (IV)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) txn_checkpoint(t->env->Env->tx_info, k, m) -#else -# ifdef AT_LEAST_DB_3_1 -# define xx_txn_checkpoint(t,k,m) txn_checkpoint(t->env->Env, k, m, 0) -# else -# define xx_txn_checkpoint(t,k,m) txn_checkpoint(t->env->Env, k, m) -# endif -#endif -DualType -xx_txn_checkpoint(txnp, kbyte, min) - BerkeleyDB::TxnMgr txnp - long kbyte - long min - -HV * -txn_stat(txnp) - BerkeleyDB::TxnMgr txnp - HV * RETVAL = NULL ; - CODE: - { - DB_TXN_STAT * stat ; -#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 - 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) - const char * dir - int flags - 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) - txn_abort(tid->txn) ; - RETVAL = (int)tid ; - hash_delete("BerkeleyDB::Term::Txn", (IV)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 - -#define xx_txn_prepare(t) (t->Status = txn_prepare(t->txn)) -DualType -xx_txn_prepare(tid) - BerkeleyDB::Txn tid - INIT: - ckActive_Transaction(tid->active) ; - -#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 -DualType -_txn_commit(tid, flags=0) - BerkeleyDB::Txn tid - u_int32_t flags - INIT: - ckActive_Transaction(tid->active) ; - hash_delete("BerkeleyDB::Term::Txn", (IV)tid) ; - tid->active = FALSE ; - -#define _txn_abort(t) (t->Status = txn_abort(t->txn)) -DualType -_txn_abort(tid) - BerkeleyDB::Txn tid - INIT: - ckActive_Transaction(tid->active) ; - hash_delete("BerkeleyDB::Term::Txn", (IV)tid) ; - tid->active = FALSE ; - -#define xx_txn_id(t) txn_id(t->txn) -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 - CODE: - { - DBT value ; - - CurrentDB = db ; - 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 deleted file mode 100644 index ba9a9c0085d..00000000000 --- a/bdb/perl.BerkeleyDB/BerkeleyDB/Btree.pm +++ /dev/null @@ -1,8 +0,0 @@ - -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 deleted file mode 100644 index 8e7bc7e78c7..00000000000 --- a/bdb/perl.BerkeleyDB/BerkeleyDB/Hash.pm +++ /dev/null @@ -1,8 +0,0 @@ - -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 deleted file mode 100644 index dcaccd4d0c7..00000000000 --- a/bdb/perl.BerkeleyDB/Changes +++ /dev/null @@ -1,112 +0,0 @@ -Revision history for Perl extension BerkeleyDB. - -0.01 23 October 1997 - * first alpha release as BerkDB. - -0.02 30 October 1997 - * renamed module to BerkeleyDB - * fixed a few bugs & added more tests - -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.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.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.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.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.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.09 29th November 1999 - * the queue.t & subdb.t test harnesses were outputting a few - spurious warnings. This has been fixed. - -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.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.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.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. - diff --git a/bdb/perl.BerkeleyDB/MANIFEST b/bdb/perl.BerkeleyDB/MANIFEST deleted file mode 100644 index 3b8a820d56e..00000000000 --- a/bdb/perl.BerkeleyDB/MANIFEST +++ /dev/null @@ -1,49 +0,0 @@ -BerkeleyDB.pm -BerkeleyDB.pod -BerkeleyDB.pod.P -BerkeleyDB.xs -BerkeleyDB/Btree.pm -BerkeleyDB/Hash.pm -Changes -config.in -dbinfo -hints/solaris.pl -hints/irix_6_5.pl -Makefile.PL -MANIFEST -mkconsts -mkpod -README -t/btree.t -t/db-3.0.t -t/db-3.1.t -t/db-3.2.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 -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 diff --git a/bdb/perl.BerkeleyDB/Makefile.PL b/bdb/perl.BerkeleyDB/Makefile.PL deleted file mode 100644 index 399a6761886..00000000000 --- a/bdb/perl.BerkeleyDB/Makefile.PL +++ /dev/null @@ -1,112 +0,0 @@ -#! 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 ; - -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 deleted file mode 100644 index aa905fa8011..00000000000 --- a/bdb/perl.BerkeleyDB/README +++ /dev/null @@ -1,464 +0,0 @@ - BerkeleyDB - - Version 0.13 - - 15th Jan 2001 - - Copyright (c) 1997-2001 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 3. (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. - -Wrong db.h ----------- - -If you get an error like this when building this module: - - 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:93: parse error before `DB_INFO' - BerkeleyDB.xs:93: warning: no semicolon at end of struct or union - BerkeleyDB.xs:94: warning: data definition has no type or storage class - BerkeleyDB.xs:95: parse error before `0x80000000' - BerkeleyDB.xs:110: parse error before `}' - BerkeleyDB.xs:110: warning: data definition has no type or storage class - BerkeleyDB.xs:117: parse error before `DB_ENV' - ... - -This error usually happens when if you only have Berkeley DB version 1 -on your system or you have both version 1 and version 2 (or 3) of Berkeley -DB installed on your system. When building BerkeleyDB it attempts -to use the db.h for Berkeley DB version 1. This perl module can only -be built with Berkeley DB version 2 or 3. - -This symptom can imply: - - 1. You don't have Berkeley DB version 2 or 3 installed on your system - at all. - Solution: get & install Berkeley DB. - - 2. You do have Berkeley DB 2 or 3 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 version -2 (or 3) of Berkeley DB installed on your system and BerkeleyDB attempts -to build using the db.h for Berkeley DB version 2/3 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 or 3. - -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 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 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 "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."\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 deleted file mode 100644 index 12d53bcf91c..00000000000 --- a/bdb/perl.BerkeleyDB/Todo +++ /dev/null @@ -1,57 +0,0 @@ - - * 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 deleted file mode 100644 index c23e6689cb3..00000000000 --- a/bdb/perl.BerkeleyDB/config.in +++ /dev/null @@ -1,51 +0,0 @@ -# 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 -#INCLUDE = ./libraries/2.7.5 -#INCLUDE = ./libraries/3.0.55 -#INCLUDE = ./libraries/3.1.17 -INCLUDE = ./libraries/3.2.7 - -# 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 -#LIB = ./libraries/2.7.5 -#LIB = ./libraries/3.0.55 -#LIB = ./libraries/3.1.17 -LIB = ./libraries/3.2.7 - -# 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/dbinfo b/bdb/perl.BerkeleyDB/dbinfo deleted file mode 100755 index 415411aff8e..00000000000 --- a/bdb/perl.BerkeleyDB/dbinfo +++ /dev/null @@ -1,109 +0,0 @@ -#!/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-2001 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 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 or greater", - } - }, - 0x042253 => { - Type => "Queue", - Versions => - { - 1 => "3.0.x", - 2 => "3.1.x", - 3 => "3.2.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/irix_6_5.pl b/bdb/perl.BerkeleyDB/hints/irix_6_5.pl deleted file mode 100644 index b531673e6e0..00000000000 --- a/bdb/perl.BerkeleyDB/hints/irix_6_5.pl +++ /dev/null @@ -1 +0,0 @@ -$self->{LIBS} = [ "@{$self->{LIBS}} -lthread" ]; diff --git a/bdb/perl.BerkeleyDB/hints/solaris.pl b/bdb/perl.BerkeleyDB/hints/solaris.pl deleted file mode 100644 index ddd941d634a..00000000000 --- a/bdb/perl.BerkeleyDB/hints/solaris.pl +++ /dev/null @@ -1 +0,0 @@ -$self->{LIBS} = [ "@{$self->{LIBS}} -lmt" ]; diff --git a/bdb/perl.BerkeleyDB/mkconsts b/bdb/perl.BerkeleyDB/mkconsts deleted file mode 100644 index 24ef4fca7b2..00000000000 --- a/bdb/perl.BerkeleyDB/mkconsts +++ /dev/null @@ -1,211 +0,0 @@ -#!/usr/bin/perl - -%constants = ( - # Symbol 0 = define, 1 = enum - DB_AFTER => 0, - DB_APPEND => 0, - DB_ARCH_ABS => 0, - DB_ARCH_DATA => 0, - DB_ARCH_LOG => 0, - DB_BEFORE => 0, - DB_BTREE => 1, - DB_BTREEMAGIC => 0, - DB_BTREEOLDVER => 0, - DB_BTREEVERSION => 0, - DB_CHECKPOINT => 0, - DB_CONSUME => 0, - DB_CREATE => 0, - DB_CURLSN => 0, - DB_CURRENT => 0, - DB_DBT_MALLOC => 0, - DB_DBT_PARTIAL => 0, - DB_DBT_USERMEM => 0, - DB_DELETED => 0, - DB_DELIMITER => 0, - DB_DUP => 0, - DB_DUPSORT => 0, - DB_ENV_APPINIT => 0, - DB_ENV_STANDALONE => 0, - DB_ENV_THREAD => 0, - DB_EXCL => 0, - DB_FILE_ID_LEN => 0, - DB_FIRST => 0, - DB_FIXEDLEN => 0, - DB_FLUSH => 0, - DB_FORCE => 0, - DB_GET_BOTH => 0, - DB_GET_RECNO => 0, - DB_HASH => 1, - DB_HASHMAGIC => 0, - DB_HASHOLDVER => 0, - DB_HASHVERSION => 0, - DB_INCOMPLETE => 0, - DB_INIT_CDB => 0, - DB_INIT_LOCK => 0, - DB_INIT_LOG => 0, - DB_INIT_MPOOL => 0, - DB_INIT_TXN => 0, - DB_JOIN_ITEM => 0, - DB_KEYEMPTY => 0, - DB_KEYEXIST => 0, - DB_KEYFIRST => 0, - DB_KEYLAST => 0, - DB_LAST => 0, - DB_LOCK_CONFLICT => 0, - DB_LOCK_DEADLOCK => 0, - DB_LOCK_DEFAULT => 0, - DB_LOCK_GET => 1, - DB_LOCK_NORUN => 0, - DB_LOCK_NOTGRANTED => 0, - DB_LOCK_NOTHELD => 0, - DB_LOCK_NOWAIT => 0, - DB_LOCK_OLDEST => 0, - DB_LOCK_RANDOM => 0, - DB_LOCK_RIW_N => 0, - DB_LOCK_RW_N => 0, - DB_LOCK_YOUNGEST => 0, - DB_LOCKMAGIC => 0, - DB_LOCKVERSION => 0, - DB_LOGMAGIC => 0, - DB_LOGOLDVER => 0, - DB_MAX_PAGES => 0, - DB_MAX_RECORDS => 0, - DB_MPOOL_CLEAN => 0, - DB_MPOOL_CREATE => 0, - DB_MPOOL_DIRTY => 0, - DB_MPOOL_DISCARD => 0, - DB_MPOOL_LAST => 0, - DB_MPOOL_NEW => 0, - DB_MPOOL_PRIVATE => 0, - DB_MUTEXDEBUG => 0, - DB_MUTEXLOCKS => 0, - DB_NEEDSPLIT => 0, - DB_NEXT => 0, - DB_NEXT_DUP => 0, - DB_NOMMAP => 0, - DB_NOOVERWRITE => 0, - DB_NOSYNC => 0, - DB_NOTFOUND => 0, - DB_PAD => 0, - DB_PAGEYIELD => 0, - DB_POSITION => 0, - DB_PREV => 0, - DB_PRIVATE => 0, - DB_QUEUE => 1, - DB_RDONLY => 0, - DB_RECNO => 1, - DB_RECNUM => 0, - DB_RECORDCOUNT => 0, - DB_RECOVER => 0, - DB_RECOVER_FATAL => 0, - DB_REGISTERED => 0, - DB_RENUMBER => 0, - DB_RMW => 0, - DB_RUNRECOVERY => 0, - DB_SEQUENTIAL => 0, - DB_SET => 0, - DB_SET_RANGE => 0, - DB_SET_RECNO => 0, - DB_SNAPSHOT => 0, - DB_SWAPBYTES => 0, - DB_TEMPORARY => 0, - DB_THREAD => 0, - DB_TRUNCATE => 0, - DB_TXN_ABORT => 1, - DB_TXN_BACKWARD_ROLL => 1, - DB_TXN_CKP => 0, - DB_TXN_FORWARD_ROLL => 1, - DB_TXN_LOCK_2PL => 0, - DB_TXN_LOCK_MASK => 0, - DB_TXN_LOCK_OPTIMISTIC => 0, - DB_TXN_LOG_MASK => 0, - DB_TXN_LOG_REDO => 0, - DB_TXN_LOG_UNDO => 0, - DB_TXN_LOG_UNDOREDO => 0, - DB_TXN_NOSYNC => 0, - DB_TXN_NOWAIT => 0, - DB_TXN_SYNC => 0, - DB_TXN_OPENFILES => 1, - DB_TXN_REDO => 0, - DB_TXN_UNDO => 0, - DB_TXNMAGIC => 0, - DB_TXNVERSION => 0, - DB_TXN_LOCK_OPTIMIST => 0, - DB_UNKNOWN => 1, - DB_USE_ENVIRON => 0, - DB_USE_ENVIRON_ROOT => 0, - DB_VERSION_MAJOR => 0, - DB_VERSION_MINOR => 0, - DB_VERSION_PATCH => 0, - DB_WRITECURSOR => 0, - ) ; - -sub OutputXS -{ - # skip to the marker - if (0) { - while (<>) - { - last if /^MARKER/ ; - print ; - } - } - - foreach my $key (sort keys %constants) - { - my $isEnum = $constants{$key} ; - - if ($isEnum) { - print <<EOM - if (strEQ(name, "$key")) - return $key; -EOM - } - else - { - print <<EOM - if (strEQ(name, "$key")) -#ifdef $key - return $key; -#else - goto not_there; -#endif -EOM - } - - } - - if (0) { - while (<>) - { - print ; - } - } -} - -sub OutputPM -{ - # skip to the marker - if (0) { - while (<>) - { - last if /^MARKER/ ; - print ; - } - } - - foreach my $key (sort keys %constants) - { - print "\t$key\n"; - } - - if (0) { - while (<>) - { - print ; - } - } -} - -OutputXS() if $ARGV[0] =~ /xs/i ; -OutputPM() if $ARGV[0] =~ /pm/i ; diff --git a/bdb/perl.BerkeleyDB/mkpod b/bdb/perl.BerkeleyDB/mkpod deleted file mode 100755 index 44bbf3fbf4f..00000000000 --- a/bdb/perl.BerkeleyDB/mkpod +++ /dev/null @@ -1,146 +0,0 @@ -#!/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 deleted file mode 100644 index 143ec95afbc..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.004 +++ /dev/null @@ -1,44 +0,0 @@ -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 deleted file mode 100644 index 1b05eb4e02b..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.004_01 +++ /dev/null @@ -1,217 +0,0 @@ -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 deleted file mode 100644 index 238f8737941..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.004_02 +++ /dev/null @@ -1,217 +0,0 @@ -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 deleted file mode 100644 index 06331eac922..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.004_03 +++ /dev/null @@ -1,223 +0,0 @@ -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 deleted file mode 100644 index a227dc700d9..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.004_04 +++ /dev/null @@ -1,209 +0,0 @@ -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 deleted file mode 100644 index 51c8bf35009..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.004_05 +++ /dev/null @@ -1,209 +0,0 @@ -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 deleted file mode 100644 index effee3e8275..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.005 +++ /dev/null @@ -1,209 +0,0 @@ -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 deleted file mode 100644 index 2a05dd545f6..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.005_01 +++ /dev/null @@ -1,209 +0,0 @@ -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 deleted file mode 100644 index 5dd57ddc03f..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.005_02 +++ /dev/null @@ -1,264 +0,0 @@ -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 deleted file mode 100644 index 115f9f5b909..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.005_03 +++ /dev/null @@ -1,250 +0,0 @@ -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 deleted file mode 100644 index 1f9b3b620de..00000000000 --- a/bdb/perl.BerkeleyDB/patches/5.6.0 +++ /dev/null @@ -1,294 +0,0 @@ -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/t/btree.t b/bdb/perl.BerkeleyDB/t/btree.t deleted file mode 100644 index 97bb3257c97..00000000000 --- a/bdb/perl.BerkeleyDB/t/btree.t +++ /dev/null @@ -1,976 +0,0 @@ -#!./perl -w - -# ID: %I%, %G% - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -#use Config; -# -#BEGIN { -# if(-d "lib" && -f "TEST") { -# if ($Config{'extensions'} !~ /\bBerkeleyDB\b/ ) { -# print "1..74\n"; -# exit 0; -# } -# } -#} - -use BerkeleyDB; -use File::Path qw(rmtree); - -print "1..243\n"; - -my %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", -) ; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\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, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - - 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 ; - rmtree $home ; -} - - -{ - # 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" ; - rmtree $home if -e $home ; - ok 177, mkdir($home, 0777) ; - 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 ; - - - # 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 181, $ret == 0 ; - - # should be able to see all the records - - ok 182, my $cursor = $db1->db_cursor() ; - my ($k, $v) = ("", "") ; - my $count = 0 ; - # sequence forwards - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 183, $count == 3 ; - undef $cursor ; - - # now abort the transaction - #ok 151, $txn->txn_abort() == 0 ; - ok 184, (my $Z = $txn->txn_abort()) == 0 ; - - # there shouldn't be any records in the database - $count = 0 ; - # sequence forwards - ok 185, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 186, $count == 0 ; - - undef $txn ; - undef $cursor ; - undef $db1 ; - undef $env ; - untie %hash ; - rmtree $home ; -} - -{ - # DB_DUP - - my $lex = new LexFile $Dfile ; - my %hash ; - ok 187, 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 188, keys %hash == 6 ; - - # create a cursor - ok 189, my $cursor = $db->db_cursor() ; - - my $key = "Wall" ; - my $value ; - ok 190, $cursor->c_get($key, $value, DB_SET) == 0 ; - ok 191, $key eq "Wall" && $value eq "Larry" ; - ok 192, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 193, $key eq "Wall" && $value eq "Stone" ; - ok 194, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 195, $key eq "Wall" && $value eq "Brick" ; - ok 196, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 197, $key eq "Wall" && $value eq "Brick" ; - - my $ref = $db->db_stat() ; - ok 198, ($ref->{bt_flags} | DB_DUP) == DB_DUP ; - - 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 199, my $db = new BerkeleyDB::Btree -Filename => $Dfile, - -Flags => DB_CREATE, - -Minkey =>3 , - -Pagesize => 2 **12 - ; - - my $ref = $db->db_stat() ; - ok 200, $ref->{$recs} == 0; - ok 201, $ref->{'bt_minkey'} == 3; - ok 202, $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 203, $ret == 0 ; - - $ref = $db->db_stat() ; - ok 204, $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 205, $@ eq "" ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB", -Filename => "dbbtree.tmp", - -Flags => DB_CREATE, - -Mode => 0640 ); - ' ; - - main::ok 206, $@ eq "" ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok 207, $@ eq "" ; - main::ok 208, $ret == 7 ; - - my $value = 0; - $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ; - main::ok 209, $@ eq "" ; - main::ok 210, $ret == 10 ; - - $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; - main::ok 211, $@ eq "" ; - main::ok 212, $ret == 1 ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok 213, $@ eq "" ; - main::ok 214, $ret eq "[[10]]" ; - - unlink "SubDB.pm", "dbbtree.tmp" ; - -} - -{ - # DB_RECNUM, DB_SET_RECNO & DB_GET_RECNO - - my $lex = new LexFile $Dfile ; - my %hash ; - my ($k, $v) = ("", ""); - ok 215, 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 216, $ret == 0 ; - - # db_get & DB_SET_RECNO - $k = 1 ; - ok 217, $db->db_get($k, $v, DB_SET_RECNO) == 0; - ok 218, $k eq "B one" && $v == 1 ; - - $k = 3 ; - ok 219, $db->db_get($k, $v, DB_SET_RECNO) == 0; - ok 220, $k eq "D three" && $v == 3 ; - - $k = 4 ; - ok 221, $db->db_get($k, $v, DB_SET_RECNO) == 0; - ok 222, $k eq "E four" && $v == 4 ; - - $k = 0 ; - ok 223, $db->db_get($k, $v, DB_SET_RECNO) == 0; - ok 224, $k eq "A zero" && $v == 0 ; - - # cursor & DB_SET_RECNO - - # create the cursor - ok 225, my $cursor = $db->db_cursor() ; - - $k = 2 ; - ok 226, $db->db_get($k, $v, DB_SET_RECNO) == 0; - ok 227, $k eq "C two" && $v == 2 ; - - $k = 0 ; - ok 228, $cursor->c_get($k, $v, DB_SET_RECNO) == 0; - ok 229, $k eq "A zero" && $v == 0 ; - - $k = 3 ; - ok 230, $db->db_get($k, $v, DB_SET_RECNO) == 0; - ok 231, $k eq "D three" && $v == 3 ; - - # cursor & DB_GET_RECNO - ok 232, $cursor->c_get($k, $v, DB_FIRST) == 0 ; - ok 233, $k eq "A zero" && $v == 0 ; - ok 234, $cursor->c_get($k, $v, DB_GET_RECNO) == 0; - ok 235, $v == 0 ; - - ok 236, $cursor->c_get($k, $v, DB_NEXT) == 0 ; - ok 237, $k eq "B one" && $v == 1 ; - ok 238, $cursor->c_get($k, $v, DB_GET_RECNO) == 0; - ok 239, $v == 1 ; - - ok 240, $cursor->c_get($k, $v, DB_LAST) == 0 ; - ok 241, $k eq "E four" && $v == 4 ; - ok 242, $cursor->c_get($k, $v, DB_GET_RECNO) == 0; - ok 243, $v == 4 ; - -} - diff --git a/bdb/perl.BerkeleyDB/t/db-3.0.t b/bdb/perl.BerkeleyDB/t/db-3.0.t deleted file mode 100644 index 9c324dc7bab..00000000000 --- a/bdb/perl.BerkeleyDB/t/db-3.0.t +++ /dev/null @@ -1,128 +0,0 @@ -#!./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 File::Path qw(rmtree); - -BEGIN -{ - if ($BerkeleyDB::db_version < 3) { - print "1..0 # Skipped - this needs Berkeley DB 3.x or better\n" ; - exit 0 ; - } -} - -print "1..14\n"; - - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - - -my $Dfile = "dbhash.tmp"; - -umask(0); - -{ - # set_mutexlocks - - my $home = "./fred" ; - ok 1, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - mkdir "./fred", 0777 ; - chdir "./fred" ; - ok 2, my $env = new BerkeleyDB::Env -Flags => DB_CREATE ; - ok 3, $env->set_mutexlocks(0) == 0 ; - chdir ".." ; - undef $env ; - rmtree $home ; -} - -{ - # c_dup - - - my $lex = new LexFile $Dfile ; - my %hash ; - my ($k, $v) ; - ok 4, 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 5, $ret == 0 ; - - # create a cursor - ok 6, my $cursor = $db->db_cursor() ; - - # point to a specific k/v pair - $k = "green" ; - ok 7, $cursor->c_get($k, $v, DB_SET) == 0 ; - ok 8, $v eq "house" ; - - # duplicate the cursor - my $dup_cursor = $cursor->c_dup(DB_POSITION); - ok 9, $dup_cursor ; - - # move original cursor off green/house - $cursor->c_get($k, $v, DB_NEXT) ; - ok 10, $k ne "green" ; - ok 11, $v ne "house" ; - - # duplicate cursor should still be on green/house - ok 12, $dup_cursor->c_get($k, $v, DB_CURRENT) == 0; - ok 13, $k eq "green" ; - ok 14, $v eq "house" ; - -} diff --git a/bdb/perl.BerkeleyDB/t/db-3.1.t b/bdb/perl.BerkeleyDB/t/db-3.1.t deleted file mode 100644 index 35076b6cd49..00000000000 --- a/bdb/perl.BerkeleyDB/t/db-3.1.t +++ /dev/null @@ -1,172 +0,0 @@ -#!./perl -w - -# ID: %I%, %G% - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -#use Config; -# -#BEGIN { -# if(-d "lib" && -f "TEST") { -# if ($Config{'extensions'} !~ /\bBerkeleyDB\b/ ) { -# print "1..74\n"; -# exit 0; -# } -# } -#} - -use BerkeleyDB; -use File::Path qw(rmtree); - -BEGIN -{ - if ($BerkeleyDB::db_version < 3.1) { - print "1..0 # Skipping test, this needs Berkeley DB 3.1.x or better\n" ; - exit 0 ; - } -} - -print "1..25\n"; - -my %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", -) ; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -my $Dfile = "dbhash.tmp"; -my $Dfile2 = "dbhash2.tmp"; -my $Dfile3 = "dbhash3.tmp"; -unlink $Dfile; - -umask(0) ; - - - -{ - # c_count - - my $lex = new LexFile $Dfile ; - my %hash ; - ok 1, 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 2, keys %hash == 6 ; - - # create a cursor - ok 3, my $cursor = $db->db_cursor() ; - - my $key = "Wall" ; - my $value ; - ok 4, $cursor->c_get($key, $value, DB_SET) == 0 ; - ok 5, $key eq "Wall" && $value eq "Larry" ; - - my $count ; - ok 6, $cursor->c_count($count) == 0 ; - ok 7, $count == 4 ; - - $key = "Smith" ; - ok 8, $cursor->c_get($key, $value, DB_SET) == 0 ; - ok 9, $key eq "Smith" && $value eq "John" ; - - ok 10, $cursor->c_count($count) == 0 ; - ok 11, $count == 1 ; - - - undef $db ; - undef $cursor ; - untie %hash ; - -} - -{ - # db_key_range - - my $lex = new LexFile $Dfile ; - my %hash ; - ok 12, 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 13, keys %hash == 6 ; - - my $key = "Wall" ; - my ($less, $equal, $greater) ; - ok 14, $db->db_key_range($key, $less, $equal, $greater) == 0 ; - - ok 15, $less != 0 ; - ok 16, $equal != 0 ; - ok 17, $greater != 0 ; - - $key = "Smith" ; - ok 18, $db->db_key_range($key, $less, $equal, $greater) == 0 ; - - ok 19, $less == 0 ; - ok 20, $equal != 0 ; - ok 21, $greater != 0 ; - - $key = "NotThere" ; - ok 22, $db->db_key_range($key, $less, $equal, $greater) == 0 ; - - ok 23, $less == 0 ; - ok 24, $equal == 0 ; - ok 25, $greater == 1 ; - - undef $db ; - untie %hash ; - -} diff --git a/bdb/perl.BerkeleyDB/t/db-3.2.t b/bdb/perl.BerkeleyDB/t/db-3.2.t deleted file mode 100644 index 0cff248733c..00000000000 --- a/bdb/perl.BerkeleyDB/t/db-3.2.t +++ /dev/null @@ -1,90 +0,0 @@ -#!./perl -w - -# ID: %I%, %G% - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -#use Config; -# -#BEGIN { -# if(-d "lib" && -f "TEST") { -# if ($Config{'extensions'} !~ /\bBerkeleyDB\b/ ) { -# print "1..74\n"; -# exit 0; -# } -# } -#} - -use BerkeleyDB; -use File::Path qw(rmtree); - -BEGIN -{ - if ($BerkeleyDB::db_version < 3.2) { - print "1..0 # Skipping test, this needs Berkeley DB 3.2.x or better\n" ; - exit 0 ; - } -} - -print "1..1\n"; - -my %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", -) ; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -my $Dfile = "dbhash.tmp"; -my $Dfile2 = "dbhash2.tmp"; -my $Dfile3 = "dbhash3.tmp"; -unlink $Dfile; - -umask(0) ; - - - -{ - # set_q_extentsize - - ok 1, 1 ; -} - diff --git a/bdb/perl.BerkeleyDB/t/destroy.t b/bdb/perl.BerkeleyDB/t/destroy.t deleted file mode 100644 index e3a1e2a97c6..00000000000 --- a/bdb/perl.BerkeleyDB/t/destroy.t +++ /dev/null @@ -1,141 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -print "1..13\n"; - - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - - -my $Dfile = "dbhash.tmp"; -my $home = "./fred" ; - -umask(0); - -{ - # let object destroction kill everything - - my $lex = new LexFile $Dfile ; - my %hash ; - my $value ; - - rmtree $home if -e $home ; - ok 1, mkdir($home, 0777) ; - 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 ; - - - # 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 5, $ret == 0 ; - - # should be able to see all the records - - ok 6, my $cursor = $db1->db_cursor() ; - my ($k, $v) = ("", "") ; - my $count = 0 ; - # sequence forwards - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 7, $count == 3 ; - undef $cursor ; - - # now abort the transaction - ok 8, $txn->txn_abort() == 0 ; - - # there shouldn't be any records in the database - $count = 0 ; - # sequence forwards - ok 9, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 10, $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 11, my $db1 = tie %hash, 'BerkeleyDB::Hash', - -Filename => $Dfile, - -Flags => DB_CREATE ; - my $count = 0 ; - # sequence forwards - ok 12, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 13, $count == 0 ; -} - -rmtree $home ; - diff --git a/bdb/perl.BerkeleyDB/t/env.t b/bdb/perl.BerkeleyDB/t/env.t deleted file mode 100644 index 5d0197f85c0..00000000000 --- a/bdb/perl.BerkeleyDB/t/env.t +++ /dev/null @@ -1,279 +0,0 @@ -#!./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 File::Path qw(rmtree); - -print "1..52\n"; - - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - - -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, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - mkdir "./fred", 0777 ; - chdir "./fred" ; - ok 12, my $env = new BerkeleyDB::Env -Flags => DB_CREATE ; - chdir ".." ; - undef $env ; - rmtree $home ; -} - -{ - # create an environment with a Home - my $home = "./fred" ; - ok 13, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - ok 14, my $env = new BerkeleyDB::Env -Home => $home, - -Flags => DB_CREATE ; - - undef $env ; - rmtree $home ; -} - -{ - # 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 ; - - 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, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - 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 ; - rmtree $home ; -} - -{ - # -ErrFile with a filename - my $errfile = "./errfile" ; - my $home = "./fred" ; - ok 24, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - 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 ; - rmtree $home ; -} - -{ - # -ErrFile with a filehandle - use IO ; - my $home = "./fred" ; - ok 30, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - my $errfile = "./errfile" ; - my $lex = new LexFile $errfile ; - ok 31, my $ef = new IO::File ">$errfile" ; - ok 32, my $env = new BerkeleyDB::Env( -ErrFile => $ef , - -Flags => DB_CREATE, - -Home => $home) ; - my $db = new BerkeleyDB::Hash -Filename => $Dfile, - -Env => $env, - -Flags => -1; - ok 33, !$db ; - - ok 34, $BerkeleyDB::Error =~ /^illegal flag specified to (db_open|DB->open)/; - $ef->close() ; - ok 35, -e $errfile ; - my $contents = "" ; - $contents = docat($errfile) ; - chomp $contents ; - ok 36, $BerkeleyDB::Error eq $contents ; - undef $env ; - rmtree $home ; -} - -{ - # -ErrPrefix - use IO ; - my $home = "./fred" ; - ok 37, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - my $errfile = "./errfile" ; - my $lex = new LexFile $errfile ; - ok 38, 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 39, !$db ; - - ok 40, $BerkeleyDB::Error =~ /^PREFIX: illegal flag specified to (db_open|DB->open)/; - ok 41, -e $errfile ; - my $contents = docat($errfile) ; - chomp $contents ; - ok 42, $BerkeleyDB::Error eq $contents ; - - # change the prefix on the fly - my $old = $env->errPrefix("NEW ONE") ; - ok 43, $old eq "PREFIX" ; - - $db = new BerkeleyDB::Hash -Filename => $Dfile, - -Env => $env, - -Flags => -1; - ok 44, !$db ; - ok 45, $BerkeleyDB::Error =~ /^NEW ONE: illegal flag specified to (db_open|DB->open)/; - $contents = docat($errfile) ; - chomp $contents ; - ok 46, $contents =~ /$BerkeleyDB::Error$/ ; - undef $env ; - rmtree $home ; -} - -{ - # 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 47, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - ok 48, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ; - ok 49, -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 50, $env ; - - ok 51, my $txn_mgr = $env->TxnMgr() ; - - ok 52, $env->db_appexit() == 0 ; - - #rmtree $home ; -} - -# test -Verbose -# test -Flags -# db_value_set diff --git a/bdb/perl.BerkeleyDB/t/examples.t b/bdb/perl.BerkeleyDB/t/examples.t deleted file mode 100644 index 4b6702d540a..00000000000 --- a/bdb/perl.BerkeleyDB/t/examples.t +++ /dev/null @@ -1,482 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -print "1..7\n"; - -my $FA = 0 ; - -{ - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - $FA = 0 ; - my @a ; - tie @a, 'try' ; - my $a = @a ; -} - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -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 -{ - 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; -} - -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 deleted file mode 100644 index fe0922318ca..00000000000 --- a/bdb/perl.BerkeleyDB/t/examples.t.T +++ /dev/null @@ -1,496 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -print "1..7\n"; - -my $FA = 0 ; - -{ - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - $FA = 0 ; - my @a ; - tie @a, 'try' ; - my $a = @a ; -} - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -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 -{ - 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; -} - -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 deleted file mode 100644 index 9cc1fa72c29..00000000000 --- a/bdb/perl.BerkeleyDB/t/examples3.t +++ /dev/null @@ -1,213 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -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 $FA = 0 ; - -{ - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - $FA = 0 ; - my @a ; - tie @a, 'try' ; - my $a = @a ; -} - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -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 -{ - 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; -} - -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 deleted file mode 100644 index 573c04903e3..00000000000 --- a/bdb/perl.BerkeleyDB/t/examples3.t.T +++ /dev/null @@ -1,217 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -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 $FA = 0 ; - -{ - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - $FA = 0 ; - my @a ; - tie @a, 'try' ; - my $a = @a ; -} - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -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 -{ - 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; -} - -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 deleted file mode 100644 index 8bcdc7f3f90..00000000000 --- a/bdb/perl.BerkeleyDB/t/filter.t +++ /dev/null @@ -1,244 +0,0 @@ -#!./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 File::Path qw(rmtree); - -print "1..46\n"; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\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 deleted file mode 100644 index 1a42c60acb2..00000000000 --- a/bdb/perl.BerkeleyDB/t/hash.t +++ /dev/null @@ -1,777 +0,0 @@ -#!./perl -w - -# ID: %I%, %G% - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -#use Config; -# -#BEGIN { -# if(-d "lib" && -f "TEST") { -# if ($Config{'extensions'} !~ /\bBerkeleyDB\b/ ) { -# print "1..74\n"; -# exit 0; -# } -# } -#} - -use BerkeleyDB; -use File::Path qw(rmtree); - -print "1..210\n"; - -my %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", -) ; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\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, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - - 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 ; - rmtree $home ; -} - -{ - # 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" ; - rmtree $home if -e $home ; - ok 146, mkdir($home, 0777) ; - 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 ; - - - # 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 150, $ret == 0 ; - - # should be able to see all the records - - ok 151, my $cursor = $db1->db_cursor() ; - my ($k, $v) = ("", "") ; - my $count = 0 ; - # sequence forwards - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 152, $count == 3 ; - undef $cursor ; - - # now abort the transaction - ok 153, $txn->txn_abort() == 0 ; - - # there shouldn't be any records in the database - $count = 0 ; - # sequence forwards - ok 154, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 155, $count == 0 ; - - undef $txn ; - undef $cursor ; - undef $db1 ; - undef $env ; - untie %hash ; - rmtree $home ; -} - - -{ - # DB_DUP - - my $lex = new LexFile $Dfile ; - my %hash ; - ok 156, 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 157, keys %hash == 6 ; - - # create a cursor - ok 158, my $cursor = $db->db_cursor() ; - - my $key = "Wall" ; - my $value ; - ok 159, $cursor->c_get($key, $value, DB_SET) == 0 ; - ok 160, $key eq "Wall" && $value eq "Larry" ; - ok 161, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 162, $key eq "Wall" && $value eq "Stone" ; - ok 163, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 164, $key eq "Wall" && $value eq "Brick" ; - ok 165, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 166, $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 167, $cursor->c_get($k, $v, DB_SET) == 0 ; - ok 168, $k eq "Wall" && $v eq "Larry" ; - ok 169, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ; - ok 170, $k eq "Wall" && $v eq "Stone" ; - ok 171, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ; - ok 172, $k eq "Wall" && $v eq "Brick" ; - 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) == 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 176, tie %h, "BerkeleyDB::Hash", -Filename => $Dfile, - -DupCompare => sub { $_[0] cmp $_[1] }, - -Property => DB_DUP|DB_DUPSORT, - -Flags => DB_CREATE ; - - ok 177, 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 178, my $cursor = (tied %h)->db_cursor() ; - $key = 9 ; $value = ""; - ok 179, $cursor->c_get($key, $value, DB_SET) == 0 ; - ok 180, $key == 9 && $value eq 11 ; - ok 181, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 182, $key == 9 && $value == 2 ; - ok 183, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 184, $key == 9 && $value eq "x" ; - - $cursor = (tied %g)->db_cursor() ; - $key = 9 ; - ok 185, $cursor->c_get($key, $value, DB_SET) == 0 ; - ok 186, $key == 9 && $value eq "x" ; - ok 187, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 188, $key == 9 && $value == 2 ; - ok 189, $cursor->c_get($key, $value, DB_NEXT) == 0 ; - ok 190, $key == 9 && $value == 11 ; - - -} - -{ - # get_dup etc - my $lex = new LexFile $Dfile; - my %hh ; - - ok 191, 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 192, scalar $YY->get_dup('Unknown') == 0 ; - ok 193, scalar $YY->get_dup('Smith') == 1 ; - ok 194, scalar $YY->get_dup('Wall') == 3 ; - - # now in list context - my @unknown = $YY->get_dup('Unknown') ; - ok 195, "@unknown" eq "" ; - - my @smith = $YY->get_dup('Smith') ; - ok 196, "@smith" eq "John" ; - - { - my @wall = $YY->get_dup('Wall') ; - my %wall ; - @wall{@wall} = @wall ; - ok 197, (@wall == 3 && $wall{'Larry'} - && $wall{'Stone'} && $wall{'Brick'}); - } - - # hash - my %unknown = $YY->get_dup('Unknown', 1) ; - ok 198, keys %unknown == 0 ; - - my %smith = $YY->get_dup('Smith', 1) ; - ok 199, keys %smith == 1 && $smith{'John'} ; - - my %wall = $YY->get_dup('Wall', 1) ; - ok 200, 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 201, $@ eq "" ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB", -Filename => "dbhash.tmp", - -Flags => DB_CREATE, - -Mode => 0640 ); - ' ; - - main::ok 202, $@ eq "" ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok 203, $@ eq "" ; - main::ok 204, $ret == 7 ; - - my $value = 0; - $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ; - main::ok 205, $@ eq "" ; - main::ok 206, $ret == 10 ; - - $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; - main::ok 207, $@ eq "" ; - main::ok 208, $ret == 1 ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok 209, $@ eq "" ; - main::ok 210, $ret eq "[[10]]" ; - - unlink "SubDB.pm", "dbhash.tmp" ; - -} diff --git a/bdb/perl.BerkeleyDB/t/join.t b/bdb/perl.BerkeleyDB/t/join.t deleted file mode 100644 index f986d76f734..00000000000 --- a/bdb/perl.BerkeleyDB/t/join.t +++ /dev/null @@ -1,270 +0,0 @@ -#!./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 File::Path qw(rmtree); - -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"; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -my $Dfile1 = "dbhash1.tmp"; -my $Dfile2 = "dbhash2.tmp"; -my $Dfile3 = "dbhash3.tmp"; -unlink $Dfile1, $Dfile2, $Dfile3 ; - -umask(0) ; - -sub addData -{ - my $db = shift ; - my @data = @_ ; - die "addData odd data\n" unless @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) ; -} - -{ - # 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" ; - rmtree $home if -e $home ; - ok 6, mkdir($home, 0777) ; - 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 ; - rmtree $home ; -} - diff --git a/bdb/perl.BerkeleyDB/t/mldbm.t b/bdb/perl.BerkeleyDB/t/mldbm.t deleted file mode 100644 index eb6673b35f5..00000000000 --- a/bdb/perl.BerkeleyDB/t/mldbm.t +++ /dev/null @@ -1,166 +0,0 @@ -#!/usr/bin/perl -w - -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 ; - } -} - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -print "1..12\n"; - -{ -package BTREE ; - -use BerkeleyDB ; -use MLDBM qw(BerkeleyDB::Btree) ; -use Data::Dumper; - -$filename = 'testmldbm' ; - -unlink $filename ; -$MLDBM::UseDB = "BerkeleyDB::Btree" ; -$db = tie %o, MLDBM, -Filename => $filename, - -Flags => DB_CREATE - or die $!; -::ok 1, $db ; -::ok 2, $db->type() == DB_BTREE ; - -$c = [\'c']; -$b = {}; -$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; -$first = Data::Dumper->new([@o{qw(a b c)}], [qw(a b c)])->Quotekeys(0)->Dump; -$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 ; - -unlink $filename ; -} - -{ - -package HASH ; - -use BerkeleyDB ; -use MLDBM qw(BerkeleyDB::Hash) ; -use Data::Dumper; - -$filename = 'testmldbm' ; - -unlink $filename ; -$MLDBM::UseDB = "BerkeleyDB::Hash" ; -$db = tie %o, MLDBM, -Filename => $filename, - -Flags => DB_CREATE - or die $!; -::ok 7, $db ; -::ok 8, $db->type() == DB_HASH ; - - -$c = [\'c']; -$b = {}; -$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; -$first = Data::Dumper->new([@o{qw(a b c)}], [qw(a b c)])->Quotekeys(0)->Dump; -$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 ; - -unlink $filename ; - -} diff --git a/bdb/perl.BerkeleyDB/t/queue.t b/bdb/perl.BerkeleyDB/t/queue.t deleted file mode 100644 index 0f459a43a69..00000000000 --- a/bdb/perl.BerkeleyDB/t/queue.t +++ /dev/null @@ -1,837 +0,0 @@ -#!./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 File::Path qw(rmtree); - -BEGIN -{ - if ($BerkeleyDB::db_version < 3) { - print "1..0 # Skipping test, Queue needs Berkeley DB 3.x or better\n" ; - exit 0 ; - } -} - -print "1..197\n"; - -my %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", - ) ; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - -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 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, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - - 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 ; - rmtree $home ; -} - - -{ - # 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 - - # full tied array support started in Perl 5.004_57 - # just double check. - my $FA = 0 ; - { - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - my @a ; - tie @a, 'try' ; - my $a = @a ; - } - - 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" ; - rmtree $home if -e $home ; - ok 169, mkdir($home, 0777) ; - 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 => " " ; - - - # 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 ; - rmtree $home ; -} - - -{ - # 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 179, my $db = new BerkeleyDB::Queue -Filename => $Dfile, - -Flags => DB_CREATE, - -Pagesize => 4 * 1024, - -Len => $rec_len, - -Pad => " " - ; - - my $ref = $db->db_stat() ; - ok 180, $ref->{$recs} == 0; - ok 181, $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 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::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 184, $@ eq "" ; - my @h ; - my $X ; - my $rec_len = 34 ; - eval ' - $X = tie(@h, "SubDB", -Filename => "dbbtree.tmp", - -Flags => DB_CREATE, - -Mode => 0640 , - -Len => $rec_len, - -Pad => " " - ); - ' ; - - 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]]" ; - - unlink "SubDB.pm", "dbbtree.tmp" ; - -} - -{ - # DB_APPEND - - my $lex = new LexFile $Dfile; - my @array ; - my $value ; - my $rec_len = 21 ; - ok 194, 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 195, $db->db_put($k, "fred", DB_APPEND) == 0 ; - ok 196, $k == 4 ; - ok 197, $array[4] eq fillout("fred", $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 deleted file mode 100644 index 0f210f540c3..00000000000 --- a/bdb/perl.BerkeleyDB/t/recno.t +++ /dev/null @@ -1,967 +0,0 @@ -#!./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 File::Path qw(rmtree); - -print "1..218\n"; - -my %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", -) ; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - -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 ; -} - -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, -d $home ? chmod 0777, $home : mkdir($home, 0777) ; - - 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 ; - rmtree $home ; -} - - -{ - # 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 - - # full tied array support started in Perl 5.004_57 - # just double check. - my $FA = 0 ; - { - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - my @a ; - tie @a, 'try' ; - my $a = @a ; - } - - 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" ; - rmtree $home if -e $home ; - ok 167, mkdir($home, 0777) ; - 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 ; - - - # 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 171, $ret == 0 ; - - # should be able to see all the records - - ok 172, 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 173, $count == 3 ; - undef $cursor ; - - # now abort the transaction - ok 174, $txn->txn_abort() == 0 ; - - # there shouldn't be any records in the database - $count = 0 ; - # sequence forwards - ok 175, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 176, $count == 0 ; - - undef $txn ; - undef $cursor ; - undef $db1 ; - undef $env ; - untie @array ; - rmtree $home ; -} - - -{ - # db_stat - - my $lex = new LexFile $Dfile ; - my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ; - my @array ; - my ($k, $v) ; - ok 177, my $db = new BerkeleyDB::Recno -Filename => $Dfile, - -Flags => DB_CREATE, - -Pagesize => 4 * 1024, - ; - - my $ref = $db->db_stat() ; - ok 178, $ref->{$recs} == 0; - ok 179, $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 180, $ret == 0 ; - - $ref = $db->db_stat() ; - ok 181, $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 182, $@ eq "" ; - my @h ; - my $X ; - eval ' - $X = tie(@h, "SubDB", -Filename => "dbbtree.tmp", - -Flags => DB_CREATE, - -Mode => 0640 ); - ' ; - - main::ok 183, $@ eq "" ; - - my $ret = eval '$h[1] = 3 ; return $h[1] ' ; - main::ok 184, $@ eq "" ; - main::ok 185, $ret == 7 ; - - my $value = 0; - $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ; - main::ok 186, $@ eq "" ; - main::ok 187, $ret == 10 ; - - $ret = eval ' DB_NEXT eq main::DB_NEXT ' ; - main::ok 188, $@ eq "" ; - main::ok 189, $ret == 1 ; - - $ret = eval '$X->A_new_method(1) ' ; - main::ok 190, $@ eq "" ; - main::ok 191, $ret eq "[[10]]" ; - - unlink "SubDB.pm", "dbbtree.tmp" ; - -} - -{ - # variable length records, DB_DELIMETER -- defaults to \n - - my $lex = new LexFile $Dfile, $Dfile2 ; - touch $Dfile2 ; - my @array ; - my $value ; - ok 192, 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 193, $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 194, 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 195, $x eq "abc-def--ghi-"; -} - -{ - # fixed length records, default DB_PAD - - 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 , - -Len => 5, - -Source => $Dfile2 ; - $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, change 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, - -Pad => "-", - -Source => $Dfile2 ; - $array[0] = "abc" ; - $array[1] = "def" ; - $array[3] = "ghi" ; - untie @array ; - - my $x = docat($Dfile2) ; - ok 199, $x eq "abc--def-------ghi--" ; -} - -{ - # DB_RENUMBER - - my $lex = new LexFile $Dfile; - my @array ; - my $value ; - ok 200, 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 201, my ($length, $joined) = joiner($db, "|") ; - ok 202, $length == 3 ; - ok 203, $joined eq "abc|def|ghi"; - - ok 204, $db->db_del(1) == 0 ; - ok 205, ($length, $joined) = joiner($db, "|") ; - ok 206, $length == 2 ; - ok 207, $joined eq "abc|ghi"; - - undef $db ; - untie @array ; - -} - -{ - # DB_APPEND - - my $lex = new LexFile $Dfile; - my @array ; - my $value ; - ok 208, 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 209, $db->db_put($k, "fred", DB_APPEND) == 0 ; - ok 210, $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 211, 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 212, $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 213, 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 214, $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 215, 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 216, $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 217, 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 218, $x eq "abc--def-------ghi--" ; -} - -__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 deleted file mode 100644 index 0a856bbb1c6..00000000000 --- a/bdb/perl.BerkeleyDB/t/strict.t +++ /dev/null @@ -1,220 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -print "1..44\n"; - - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - - -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 ; - - rmtree $home if -e $home ; - ok 1, mkdir($home, 0777) ; - 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" ; - - rmtree $home if -e $home ; -} - -{ - # closing an environment with an open database - my $lex = new LexFile $Dfile ; - my %hash ; - - rmtree $home if -e $home ; - ok 7, mkdir($home, 0777) ; - 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 ; - rmtree $home if -e $home ; -} - -{ - # closing a transaction & a database - my $lex = new LexFile $Dfile ; - my %hash ; - my $status ; - - rmtree $home if -e $home ; - ok 11, mkdir($home, 0777) ; - 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 "" ; - 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 ; - - rmtree $home if -e $home ; - ok 20, mkdir($home, 0777) ; - 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" ; - rmtree $home if -e $home ; -} - -{ - # 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" ; - rmtree $home if -e $home ; -} - -{ - # closing a transaction & a cursor - my $lex = new LexFile $Dfile ; - my %hash ; - my $status ; - - rmtree $home if -e $home ; - ok 33, mkdir($home, 0777) ; - 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 "" ; - eval { $status = $env->db_appexit() ; } ; - ok 43, $status == 0 ; - ok 44, $@ eq "" ; - #print "[$@]\n" ; - rmtree $home if -e $home ; -} - diff --git a/bdb/perl.BerkeleyDB/t/subdb.t b/bdb/perl.BerkeleyDB/t/subdb.t deleted file mode 100644 index 290e5d691e4..00000000000 --- a/bdb/perl.BerkeleyDB/t/subdb.t +++ /dev/null @@ -1,296 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -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 %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", - ) ; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub addData -{ - my $db = shift ; - my @data = @_ ; - die "addData odd data\n" unless @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) ; -} - -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 ; - - 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 deleted file mode 100644 index 6bef1887ea3..00000000000 --- a/bdb/perl.BerkeleyDB/t/txn.t +++ /dev/null @@ -1,354 +0,0 @@ -#!./perl -w - -use strict ; - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; - } -} - -use BerkeleyDB; -use File::Path qw(rmtree); - -print "1..50\n"; - - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - - -my $Dfile = "dbhash.tmp"; - -umask(0); - -{ - # error cases - - my $lex = new LexFile $Dfile ; - my %hash ; - my $value ; - - my $home = "./fred" ; - rmtree $home if -e $home ; - ok 1, mkdir($home, 0777) ; - 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 ; - rmtree $home ; - -} - -{ - # transaction - abort works - - my $lex = new LexFile $Dfile ; - my %hash ; - my $value ; - - my $home = "./fred" ; - rmtree $home if -e $home ; - ok 5, mkdir($home, 0777) ; - 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 ; - - - # 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 9, $ret == 0 ; - - # should be able to see all the records - - ok 10, my $cursor = $db1->db_cursor() ; - my ($k, $v) = ("", "") ; - my $count = 0 ; - # sequence forwards - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 11, $count == 3 ; - undef $cursor ; - - # now abort the transaction - ok 12, $txn->txn_abort() == 0 ; - - # there shouldn't be any records in the database - $count = 0 ; - # sequence forwards - ok 13, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 14, $count == 0 ; - - my $stat = $env->txn_stat() ; - ok 15, $stat->{'st_naborts'} == 1 ; - - undef $txn ; - undef $cursor ; - undef $db1 ; - undef $env ; - untie %hash ; - rmtree $home ; -} - -{ - # transaction - abort works via txnmgr - - my $lex = new LexFile $Dfile ; - my %hash ; - my $value ; - - my $home = "./fred" ; - rmtree $home if -e $home ; - ok 16, mkdir($home, 0777) ; - ok 17, my $env = new BerkeleyDB::Env -Home => $home, - -Flags => DB_CREATE|DB_INIT_TXN| - DB_INIT_MPOOL|DB_INIT_LOCK ; - ok 18, my $txn_mgr = $env->TxnMgr() ; - ok 19, my $txn = $txn_mgr->txn_begin() ; - ok 20, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, - -Flags => DB_CREATE , - -Env => $env, - -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 21, $ret == 0 ; - - # should be able to see all the records - - ok 22, my $cursor = $db1->db_cursor() ; - my ($k, $v) = ("", "") ; - my $count = 0 ; - # sequence forwards - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 23, $count == 3 ; - undef $cursor ; - - # now abort the transaction - ok 24, $txn->txn_abort() == 0 ; - - # there shouldn't be any records in the database - $count = 0 ; - # sequence forwards - ok 25, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 26, $count == 0 ; - - my $stat = $txn_mgr->txn_stat() ; - ok 27, $stat->{'st_naborts'} == 1 ; - - undef $txn ; - undef $cursor ; - undef $db1 ; - undef $txn_mgr ; - undef $env ; - untie %hash ; - rmtree $home ; -} - -{ - # transaction - commit works - - my $lex = new LexFile $Dfile ; - my %hash ; - my $value ; - - my $home = "./fred" ; - rmtree $home if -e $home ; - ok 28, mkdir($home, 0777) ; - ok 29, my $env = new BerkeleyDB::Env -Home => $home, - -Flags => DB_CREATE|DB_INIT_TXN| - DB_INIT_MPOOL|DB_INIT_LOCK ; - ok 30, my $txn = $env->txn_begin() ; - ok 31, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, - -Flags => DB_CREATE , - -Env => $env, - -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 32, $ret == 0 ; - - # should be able to see all the records - - ok 33, my $cursor = $db1->db_cursor() ; - my ($k, $v) = ("", "") ; - my $count = 0 ; - # sequence forwards - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 34, $count == 3 ; - undef $cursor ; - - # now commit the transaction - ok 35, $txn->txn_commit() == 0 ; - - $count = 0 ; - # sequence forwards - ok 36, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 37, $count == 3 ; - - my $stat = $env->txn_stat() ; - ok 38, $stat->{'st_naborts'} == 0 ; - - undef $txn ; - undef $cursor ; - undef $db1 ; - undef $env ; - untie %hash ; - rmtree $home ; -} - -{ - # transaction - commit works via txnmgr - - my $lex = new LexFile $Dfile ; - my %hash ; - my $value ; - - my $home = "./fred" ; - rmtree $home if -e $home ; - ok 39, mkdir($home, 0777) ; - ok 40, my $env = new BerkeleyDB::Env -Home => $home, - -Flags => DB_CREATE|DB_INIT_TXN| - DB_INIT_MPOOL|DB_INIT_LOCK ; - ok 41, my $txn_mgr = $env->TxnMgr() ; - ok 42, my $txn = $txn_mgr->txn_begin() ; - ok 43, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, - -Flags => DB_CREATE , - -Env => $env, - -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 44, $ret == 0 ; - - # should be able to see all the records - - ok 45, my $cursor = $db1->db_cursor() ; - my ($k, $v) = ("", "") ; - my $count = 0 ; - # sequence forwards - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 46, $count == 3 ; - undef $cursor ; - - # now commit the transaction - ok 47, $txn->txn_commit() == 0 ; - - $count = 0 ; - # sequence forwards - ok 48, $cursor = $db1->db_cursor() ; - while ($cursor->c_get($k, $v, DB_NEXT) == 0) { - ++ $count ; - } - ok 49, $count == 3 ; - - my $stat = $txn_mgr->txn_stat() ; - ok 50, $stat->{'st_naborts'} == 0 ; - - undef $txn ; - undef $cursor ; - undef $db1 ; - undef $txn_mgr ; - undef $env ; - untie %hash ; - rmtree $home ; -} - diff --git a/bdb/perl.BerkeleyDB/t/unknown.t b/bdb/perl.BerkeleyDB/t/unknown.t deleted file mode 100644 index e72021f0b18..00000000000 --- a/bdb/perl.BerkeleyDB/t/unknown.t +++ /dev/null @@ -1,212 +0,0 @@ -#!./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 File::Path qw(rmtree); - -print "1..41\n"; - -{ - package LexFile ; - - sub new - { - my $self = shift ; - unlink @_ ; - bless [ @_ ], $self ; - } - - sub DESTROY - { - my $self = shift ; - unlink @{ $self } ; - } -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub writeFile -{ - my $name = shift ; - open(FH, ">$name") or return 0 ; - print FH @_ ; - close FH ; - return 1 ; -} - -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/typemap b/bdb/perl.BerkeleyDB/typemap deleted file mode 100644 index d6c4c7647ce..00000000000 --- a/bdb/perl.BerkeleyDB/typemap +++ /dev/null @@ -1,275 +0,0 @@ -# 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 = ($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 = ($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 = ($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 = ($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 = ($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 = ($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 = ($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 = ($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 = getInnerObject($arg) ; - $var = ($type) tmp; - } - else - croak(\"$var is not of type ${ntype}\") - -T_dbtkeydatum - 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 - 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 - 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)) { - 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)) { - 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, (IV)$var); - -T_SV_REF_NULL - sv_setiv($arg, (IV)$var); - -T_HV_REF_NULL - sv_setiv($arg, (IV)$var); - -T_HV_REF - sv_setiv($arg, (IV)$var); - -T_P_REF - sv_setiv($arg, (IV)$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); |