diff options
Diffstat (limited to 'db/perl/BerkeleyDB')
50 files changed, 19349 insertions, 0 deletions
diff --git a/db/perl/BerkeleyDB/BerkeleyDB.pm b/db/perl/BerkeleyDB/BerkeleyDB.pm new file mode 100644 index 000000000..03374e4d6 --- /dev/null +++ b/db/perl/BerkeleyDB/BerkeleyDB.pm @@ -0,0 +1,1231 @@ + +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.16'; + +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_CONSUME_WAIT + 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_JOINENV + 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 +DB_TMP_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' || $k eq 'DB_TMP_DIR') + { $obj->set_tmp_dir($v) } + else { + $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; + croak $BerkeleyDB::Error + } + } + } + return $obj ; +} + + +sub TxnMgr +{ + my $env = shift ; + my ($addr) = $env->_TxnMgr() ; + my $obj ; + $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ; + return $obj ; +} + +sub txn_begin +{ + my $env = shift ; + my ($addr) = $env->_txn_begin(@_) ; + my $obj ; + $obj = bless [$addr, $env] , "BerkeleyDB::Txn" if $addr ; + return $obj ; +} + +sub DESTROY +{ + my $self = shift ; + $self->_DESTROY() ; +} + +package BerkeleyDB::Hash ; + +use vars qw(@ISA) ; +@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; +use UNIVERSAL qw( isa ) ; +use Carp ; + +sub new +{ + my $self = shift ; + my $got = BerkeleyDB::ParseParameters( + { + # Generic Stuff + Filename => undef, + Subname => undef, + #Flags => BerkeleyDB::DB_CREATE(), + Flags => 0, + Property => 0, + Mode => 0666, + Cachesize => 0, + Lorder => 0, + Pagesize => 0, + Env => undef, + #Tie => undef, + Txn => undef, + + # Hash specific + Ffactor => 0, + Nelem => 0, + Hash => undef, + DupCompare => undef, + + # BerkeleyDB specific + ReadKey => undef, + WriteKey => undef, + ReadValue => undef, + WriteValue => undef, + }, @_) ; + + croak("Env not of type BerkeleyDB::Env") + if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); + + croak("Txn not of type BerkeleyDB::Txn") + if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); + + croak("-Tie needs a reference to a hash") + if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; + + my ($addr) = _db_open_hash($self, $got); + my $obj ; + if ($addr) { + $obj = bless [$addr] , $self ; + push @{ $obj }, $got->{Env} if $got->{Env} ; + $obj->Txn($got->{Txn}) if $got->{Txn} ; + } + return $obj ; +} + +*TIEHASH = \&new ; + + +package BerkeleyDB::Btree ; + +use vars qw(@ISA) ; +@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; +use UNIVERSAL qw( isa ) ; +use Carp ; + +sub new +{ + my $self = shift ; + my $got = BerkeleyDB::ParseParameters( + { + # Generic Stuff + Filename => undef, + Subname => undef, + #Flags => BerkeleyDB::DB_CREATE(), + Flags => 0, + Property => 0, + Mode => 0666, + Cachesize => 0, + Lorder => 0, + Pagesize => 0, + Env => undef, + #Tie => undef, + Txn => undef, + + # Btree specific + Minkey => 0, + Compare => undef, + DupCompare => undef, + Prefix => undef, + }, @_) ; + + croak("Env not of type BerkeleyDB::Env") + if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); + + croak("Txn not of type BerkeleyDB::Txn") + if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); + + croak("-Tie needs a reference to a hash") + if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; + + my ($addr) = _db_open_btree($self, $got); + my $obj ; + if ($addr) { + $obj = bless [$addr] , $self ; + push @{ $obj }, $got->{Env} if $got->{Env} ; + $obj->Txn($got->{Txn}) if $got->{Txn} ; + } + return $obj ; +} + +*BerkeleyDB::Btree::TIEHASH = \&BerkeleyDB::Btree::new ; + + +package BerkeleyDB::Recno ; + +use vars qw(@ISA) ; +@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; +use UNIVERSAL qw( isa ) ; +use Carp ; + +sub new +{ + my $self = shift ; + my $got = BerkeleyDB::ParseParameters( + { + # Generic Stuff + Filename => undef, + Subname => undef, + #Flags => BerkeleyDB::DB_CREATE(), + Flags => 0, + Property => 0, + Mode => 0666, + Cachesize => 0, + Lorder => 0, + Pagesize => 0, + Env => undef, + #Tie => undef, + Txn => undef, + + # Recno specific + Delim => undef, + Len => undef, + Pad => undef, + Source => undef, + ArrayBase => 1, # lowest index in array + }, @_) ; + + croak("Env not of type BerkeleyDB::Env") + if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); + + croak("Txn not of type BerkeleyDB::Txn") + if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); + + croak("Tie needs a reference to an array") + if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; + + croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") + if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; + + + $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; + + my ($addr) = _db_open_recno($self, $got); + my $obj ; + if ($addr) { + $obj = bless [$addr] , $self ; + push @{ $obj }, $got->{Env} if $got->{Env} ; + $obj->Txn($got->{Txn}) if $got->{Txn} ; + } + return $obj ; +} + +*BerkeleyDB::Recno::TIEARRAY = \&BerkeleyDB::Recno::new ; +*BerkeleyDB::Recno::db_stat = \&BerkeleyDB::Btree::db_stat ; + +package BerkeleyDB::Queue ; + +use vars qw(@ISA) ; +@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; +use UNIVERSAL qw( isa ) ; +use Carp ; + +sub new +{ + my $self = shift ; + my $got = BerkeleyDB::ParseParameters( + { + # Generic Stuff + Filename => undef, + Subname => undef, + #Flags => BerkeleyDB::DB_CREATE(), + Flags => 0, + Property => 0, + Mode => 0666, + Cachesize => 0, + Lorder => 0, + Pagesize => 0, + Env => undef, + #Tie => undef, + Txn => undef, + + # Queue specific + Len => undef, + Pad => undef, + ArrayBase => 1, # lowest index in array + ExtentSize => undef, + }, @_) ; + + croak("Env not of type BerkeleyDB::Env") + if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); + + croak("Txn not of type BerkeleyDB::Txn") + if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); + + croak("Tie needs a reference to an array") + if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; + + croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") + if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; + + $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; + + my ($addr) = _db_open_queue($self, $got); + my $obj ; + if ($addr) { + $obj = bless [$addr] , $self ; + push @{ $obj }, $got->{Env} if $got->{Env} ; + $obj->Txn($got->{Txn}) if $got->{Txn} ; + } + return $obj ; +} + +*BerkeleyDB::Queue::TIEARRAY = \&BerkeleyDB::Queue::new ; + +## 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/db/perl/BerkeleyDB/BerkeleyDB.pod b/db/perl/BerkeleyDB/BerkeleyDB.pod new file mode 100644 index 000000000..0509fd5fe --- /dev/null +++ b/db/perl/BerkeleyDB/BerkeleyDB.pod @@ -0,0 +1,1760 @@ +=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() ; + $db->Txn($txn); + $txn->Txn($db1, $db2,...); + $status = $txn->txn_prepare() + $status = $txn->txn_commit() + $status = $txn->txn_abort() + $status = $txn->txn_id() + + $status = $env->set_lg_dir(); + $status = $env->set_lg_bsize(); + $status = $env->set_lg_max(); + + $status = $env->set_data_dir() ; + $status = $env->set_tmp_dir() ; + + $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/db/perl/BerkeleyDB/BerkeleyDB.pod.P b/db/perl/BerkeleyDB/BerkeleyDB.pod.P new file mode 100644 index 000000000..da1c5e60a --- /dev/null +++ b/db/perl/BerkeleyDB/BerkeleyDB.pod.P @@ -0,0 +1,1527 @@ +=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() ; + $db->Txn($txn); + $txn->Txn($db1, $db2,...); + $status = $txn->txn_prepare() + $status = $txn->txn_commit() + $status = $txn->txn_abort() + $status = $txn->txn_id() + + $status = $env->set_lg_dir(); + $status = $env->set_lg_bsize(); + $status = $env->set_lg_max(); + + $status = $env->set_data_dir() ; + $status = $env->set_tmp_dir() ; + + $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/db/perl/BerkeleyDB/BerkeleyDB.xs b/db/perl/BerkeleyDB/BerkeleyDB.xs new file mode 100644 index 000000000..c2230e053 --- /dev/null +++ b/db/perl/BerkeleyDB/BerkeleyDB.xs @@ -0,0 +1,4058 @@ +/* + + 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 + +#ifdef USE_PERLIO +# define GetFILEptr(sv) PerlIO_findFILE(IoOFP(sv_2io(sv))) +#else +# define GetFILEptr(sv) IoOFP(sv_2io(sv)) +#endif + +#include <db.h> + +#if (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0) +# define IS_DB_3_0_x +#endif + +#if DB_VERSION_MAJOR >= 3 +# define AT_LEAST_DB_3 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 1) +# define AT_LEAST_DB_3_1 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + +#if DB_VERSION_MAJOR > 3 || \ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 2) ||\ + (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 2 && DB_VERSION_PATCH >= 6) +# define AT_LEAST_DB_3_2_6 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3) +# define AT_LEAST_DB_3_3 +#endif + +/* 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 + +#ifndef PTR2IV +# define PTR2IV(d) (IV)(d) +#endif /* PTR2IV */ + +#ifndef INT2PTR +# define INT2PTR(any,d) (any)(d) +#endif /* INT2PTR */ + +#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, char * key); + +#ifdef TRACE +# define Trace(x) printf x +#else +# define Trace(x) +#endif + +#ifdef ALLOW_RECNO_OFFSET +# define RECNO_BASE db->array_base +#else +# define RECNO_BASE 1 +#endif + +#if DB_VERSION_MAJOR == 2 +# define flagSet_DB2(i, f) i |= f +#else +# define flagSet_DB2(i, f) +#endif + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define flagSet(bitmask) (flags & (bitmask)) +#else +# define flagSet(bitmask) ((flags & DB_OPFLAGS_MASK) == (bitmask)) +#endif + +#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) (*av_fetch((AV*)SvRV(x), 0, FALSE)) +#else +#define getInnerObject(x) ((SV*)SvRV(sv)) +#endif + +#define my_sv_setpvn(sv, d, s) (s ? sv_setpvn(sv, d, s) : sv_setpv(sv, "") ) + +#define SetValue_iv(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = SvIV(sv) +#define SetValue_io(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = GetFILEptr(sv) +#define SetValue_sv(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = sv +#define SetValue_pv(i, k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = (t)SvPV(sv,PL_na) +#define SetValue_pvx(i, k, t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \ + i = (t)SvPVX(sv) +#define SetValue_ov(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\ + IV tmp = SvIV(getInnerObject(sv)) ; \ + i = INT2PTR(t, tmp) ; \ + } + +#define SetValue_ovx(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\ + HV * hv = (HV *)GetInternalObject(sv); \ + SV ** svp = hv_fetch(hv, "db", 2, FALSE);\ + IV tmp = SvIV(*svp); \ + i = INT2PTR(t, tmp) ; \ + } + +#define SetValue_ovX(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\ + IV tmp = SvIV(GetInternalObject(sv));\ + i = INT2PTR(t, tmp) ; \ + } + +#define LastDBerror DB_RUNRECOVERY + +#define setDUALerrno(var, err) \ + sv_setnv(var, (double)err) ; \ + sv_setpv(var, ((err) ? db_strerror(err) : "")) ;\ + SvNOK_on(var); + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + 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 ; +#if 0 +static char ErrBuff[1000] ; +#endif + +#ifdef AT_LEAST_DB_3_3 +# if PERL_REVISION == 5 && PERL_VERSION <= 4 + +/* saferealloc in perl5.004 will croak if it is given a NULL pointer*/ +void * +MyRealloc(void * ptr, size_t size) +{ + if (ptr == NULL ) + return safemalloc(size) ; + else + return saferealloc(ptr, size) ; +} + +# else +# define MyRealloc saferealloc +# endif +#endif + +static char * +my_strdup(const char *s) +{ + if (s == NULL) + return NULL ; + + { + MEM_SIZE l = strlen(s); + char *s1 = (char *)safemalloc(l); + + Copy(s, s1, (MEM_SIZE)l, char); + return s1; + } +} + +#if DB_VERSION_MAJOR == 2 +static char * +db_strerror(int err) +{ + if (err == 0) + return "" ; + + if (err > 0) + return Strerror(err) ; + + switch (err) { + case DB_INCOMPLETE: + return ("DB_INCOMPLETE: Sync was unable to complete"); + case DB_KEYEMPTY: + return ("DB_KEYEMPTY: Non-existent key/data pair"); + case DB_KEYEXIST: + return ("DB_KEYEXIST: Key/data pair already exists"); + case DB_LOCK_DEADLOCK: + return ( + "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock"); + case DB_LOCK_NOTGRANTED: + return ("DB_LOCK_NOTGRANTED: Lock not granted"); + case DB_LOCK_NOTHELD: + return ("DB_LOCK_NOTHELD: Lock not held by locker"); + case DB_NOTFOUND: + return ("DB_NOTFOUND: No matching key/data pair found"); + case DB_RUNRECOVERY: + return ("DB_RUNRECOVERY: Fatal error, run database recovery"); + default: + return "Unknown Error" ; + + } +} +#endif /* DB_VERSION_MAJOR == 2 */ + +#ifdef TRACE +#if DB_VERSION_MAJOR > 2 +static char * +my_db_strerror(int err) +{ + static char buffer[1000] ; + SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; + sprintf(buffer, "%d: %s", err, db_strerror(err)) ; + if (err && sv) { + strcat(buffer, ", ") ; + strcat(buffer, SvPVX(sv)) ; + } + return buffer; +} +#endif +#endif + +static void +close_everything(void) +{ + dTHR; + Trace(("close_everything\n")) ; + /* Abort All Transactions */ + { + BerkeleyDB__Txn__Raw tid ; + HE * he ; + I32 len ; + HV * hv = perl_get_hv("BerkeleyDB::Term::Txn", TRUE); + int all = 0 ; + int closed = 0 ; + (void)hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_txns dirty=%d\n", PL_dirty)) ; + while ( (he = hv_iternext(hv)) ) { + tid = * (BerkeleyDB__Txn__Raw *) hv_iterkey(he, &len) ; + Trace((" Aborting Transaction [%d] in [%d] Active [%d]\n", tid->txn, tid, tid->active)); + if (tid->active) { + 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); + int all = 0 ; + int closed = 0 ; + (void) hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_cursors \n")) ; + while ( (he = hv_iternext(hv)) ) { + db = * (BerkeleyDB__Cursor*) hv_iterkey(he, &len) ; + Trace((" Closing Cursor [%d] in [%d] Active [%d]\n", db->cursor, db, db->active)); + if (db->active) { + ((db->cursor)->c_close)(db->cursor) ; + ++ closed ; + } + db->active = FALSE ; + ++ all ; + } + Trace(("End of BerkeleyDB::Term::close_all_cursors closed %d of %d cursors\n",closed, all)) ; + } + + /* Close All Databases */ + { + BerkeleyDB db ; + HE * he ; + I32 len ; + HV * hv = perl_get_hv("BerkeleyDB::Term::Db", TRUE); + int all = 0 ; + int closed = 0 ; + (void)hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_dbs\n" )) ; + while ( (he = hv_iternext(hv)) ) { + db = * (BerkeleyDB*) hv_iterkey(he, &len) ; + Trace((" Closing Database [%d] in [%d] Active [%d]\n", db->dbp, db, db->active)); + if (db->active) { + (db->dbp->close)(db->dbp, 0) ; + ++ closed ; + } + db->active = FALSE ; + ++ all ; + } + Trace(("End of BerkeleyDB::Term::close_all_dbs closed %d of %d dbs\n",closed, all)) ; + } + + /* Close All Environments */ + { + BerkeleyDB__Env env ; + HE * he ; + I32 len ; + HV * hv = perl_get_hv("BerkeleyDB::Term::Env", TRUE); + int all = 0 ; + int closed = 0 ; + (void)hv_iterinit(hv) ; + Trace(("BerkeleyDB::Term::close_all_envs\n")) ; + while ( (he = hv_iternext(hv)) ) { + env = * (BerkeleyDB__Env*) hv_iterkey(he, &len) ; + Trace((" Closing Environment [%d] in [%d] Active [%d]\n", env->Env, env, env->active)); + if (env->active) { +#if DB_VERSION_MAJOR == 2 + db_appexit(env->Env) ; +#else + (env->Env->close)(env->Env, 0) ; +#endif + ++ closed ; + } + env->active = FALSE ; + ++ all ; + } + Trace(("End of BerkeleyDB::Term::close_all_envs closed %d of %d dbs\n",closed, all)) ; + } + + Trace(("end close_everything\n")) ; + +} + +static void +destroyDB(BerkeleyDB db) +{ + dTHR; + if (! PL_dirty && db->active) { + -- db->open_cursors ; + ((db->dbp)->close)(db->dbp, 0) ; + } + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->dup_compare) + SvREFCNT_dec(db->dup_compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; +#ifdef DBM_FILTERING + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; +#endif + hash_delete("BerkeleyDB::Term::Db", (char *)db) ; + if (db->filename) + Safefree(db->filename) ; + Safefree(db) ; +} + +static 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 */ + +#if 0 +static SV * +GetInternalObject(SV * sv) +{ + SV * info = (SV*) NULL ; + SV * s ; + MAGIC * mg ; + + Trace(("in GetInternalObject %d\n", sv)) ; + if (sv == NULL || !SvROK(sv)) + return NULL ; + + s = SvRV(sv) ; + if (SvMAGICAL(s)) + { + if (SvTYPE(s) == SVt_PVHV || SvTYPE(s) == SVt_PVAV) + mg = mg_find(s, 'P') ; + else + mg = mg_find(s, 'q') ; + + /* all this testing is probably overkill, but till I know more + about global destruction it stays. + */ + /* if (mg && mg->mg_obj && SvRV(mg->mg_obj) && SvPVX(SvRV(mg->mg_obj))) */ + if (mg && mg->mg_obj && SvRV(mg->mg_obj) ) + info = SvRV(mg->mg_obj) ; + else + info = s ; + } + + Trace(("end of GetInternalObject %d\n", info)) ; + return info ; +} +#endif + +static int +btree_compare(DB_callback const DBT * key1, const DBT * key2 ) +{ + dSP ; + char * data1, * data2 ; + int retval ; + int count ; + + data1 = (char*) key1->data ; + data2 = (char*) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + softCrash ("in btree_compare - expected 1 return value from compare sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + return (retval) ; + +} + +static int +dup_compare(DB_callback const DBT * key1, const DBT * key2 ) +{ + dSP ; + char * 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 = (char*) key1->data ; + data2 = (char*) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->dup_compare, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + softCrash ("dup_compare: expected 1 return value from compare sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + return (retval) ; + +} + +static size_t +btree_prefix(DB_callback const DBT * key1, const DBT * key2 ) +{ + dSP ; + char * data1, * data2 ; + int retval ; + int count ; + + data1 = (char*) key1->data ; + data2 = (char*) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + softCrash ("btree_prefix: expected 1 return value from prefix sub, got %d", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + 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, char * key) +{ + HV * hv = perl_get_hv(hash, TRUE); + (void) hv_delete(hv, (char*)&key, sizeof(key), G_DISCARD); +} + +static void +hash_store_iv(char * hash, char * key, IV value) +{ + HV * hv = perl_get_hv(hash, TRUE); + (void)hv_store(hv, (char*)&key, sizeof(key), newSViv(value), 0); + /* printf("hv_store returned %d\n", ret) ; */ +} + +static void +hv_store_iv(HV * hash, char * key, IV value) +{ + hv_store(hash, key, strlen(key), newSViv(value), 0); +} + +static BerkeleyDB +my_db_open( + BerkeleyDB db , + SV * ref, + SV * ref_dbenv , + BerkeleyDB__Env dbenv , + 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 ; +#ifdef AT_LEAST_DB_3_3 + dbp->set_alloc(dbp, safemalloc, MyRealloc, safefree) ; +#endif + RETVAL->dbp = dbp ; +#if DB_VERSION_MAJOR == 2 + RETVAL->type = dbp->type ; +#else /* DB_VERSION_MAJOR > 2 */ +#ifdef AT_LEAST_DB_3_3 + dbp->get_type(dbp, &RETVAL->type) ; +#else /* DB 3.0 -> 3.2 */ + RETVAL->type = dbp->get_type(dbp) ; +#endif +#endif /* DB_VERSION_MAJOR > 2 */ + RETVAL->recno_or_queue = (RETVAL->type == DB_RECNO || + RETVAL->type == DB_QUEUE) ; + RETVAL->filename = my_strdup(file) ; + RETVAL->Status = Status ; + RETVAL->active = TRUE ; + hash_store_iv("BerkeleyDB::Term::Db", (char *)RETVAL, 1) ; + Trace((" storing %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_CONSUME_WAIT")) +#ifdef DB_CONSUME_WAIT + return DB_CONSUME_WAIT; +#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_JOINENV")) +#ifdef DB_JOINENV + return DB_JOINENV; +#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 = NULL ; + const char * subdb = NULL ; + BerkeleyDB__Env env = NULL ; + DB_ENV * dbenv = NULL ; + u_int32_t flags = 0 ; + + hash = (HV*) SvRV(ref) ; + SetValue_pv(db, "Filename", char *) ; + SetValue_pv(subdb, "Subname", char *) ; + SetValue_iv(flags, "Flags") ; + SetValue_ov(env, "Env", BerkeleyDB__Env) ; + if (env) + dbenv = env->Env ; + RETVAL = db_create(&dbp, dbenv, 0) ; + if (RETVAL == 0) { + RETVAL = dbp->remove(dbp, db, subdb, flags) ; + } +#endif + } + OUTPUT: + RETVAL + +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 ; + 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 = GetFILEptr(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", (char *)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 ; +#ifdef AT_LEAST_DB_3_3 + env->set_alloc(env, safemalloc, MyRealloc, safefree) ; +#endif + if (status == 0 && cachesize) { + status = env->set_cachesize(env, 0, cachesize, 0) ; + Trace(("set_cachesize [%d] returned %s\n", + cachesize, my_db_strerror(status))); + } + + if (status == 0 && lk_detect) { + status = env->set_lk_detect(env, lk_detect) ; + Trace(("set_lk_detect [%d] returned %s\n", + lk_detect, my_db_strerror(status))); + } +#ifdef AT_LEAST_DB_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) + { + int mode = 0 ; + /* Take a copy of the error prefix */ + if (errprefix) { + Trace(("copying errprefix\n" )) ; + RETVAL->ErrPrefix = newSVsv(errprefix) ; + SvPOK_only(RETVAL->ErrPrefix) ; + } + if (RETVAL->ErrPrefix) + env->set_errpfx(env, SvPVX(RETVAL->ErrPrefix)) ; + + if ((sv = readHash(hash, "ErrFile")) && sv != &PL_sv_undef) { + env->set_errfile(env, GetFILEptr(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_x + status = (env->open)(env, home, config, flags, mode) ; +#else /* > 3.0 */ + status = (env->open)(env, home, flags, mode) ; +#endif + Trace(("ENV->open returned %s\n", my_db_strerror(status))) ; + } + + if (status == 0) + hash_store_iv("BerkeleyDB::Term::Env", (char *)RETVAL, 1) ; + else { + (env->close)(env, 0) ; + if (RETVAL->ErrHandle) + 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) + u_int32_t flags + BerkeleyDB::Env env + BerkeleyDB::Txn pid + CODE: + { + DB_TXN *txn ; + DB_TXN *p_id = NULL ; + Trace(("txn_begin pid %d, flags %d\n", pid, flags)) ; +#if DB_VERSION_MAJOR == 2 + if (env->Env->tx_info == NULL) + softCrash("Transaction Manager not enabled") ; +#endif + if (!env->txn_enabled) + softCrash("Transaction Manager not enabled") ; + if (pid) + p_id = pid->txn ; + env->TxnMgrStatus = +#if DB_VERSION_MAJOR == 2 + txn_begin(env->Env->tx_info, p_id, &txn) ; +#else + 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", (char *)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 ; +#ifdef AT_LEAST_DB_3_3 + if(txn_stat(env->Env, &stat) == 0) { +#else +#if DB_VERSION_MAJOR == 2 + if(txn_stat(env->Env->tx_info, &stat, safemalloc) == 0) { +#else + if(txn_stat(env->Env, &stat, safemalloc) == 0) { +#endif +#endif + 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", (char *)env) ; + OUTPUT: + RETVAL + + +void +_DESTROY(env) + BerkeleyDB::Env env + int RETVAL = 0 ; + CODE: + Trace(("In BerkeleyDB::Env::DESTROY\n")); + Trace((" env %ld Env %ld dirty %d\n", env, &env->Env, PL_dirty)) ; + if (env->active) +#if DB_VERSION_MAJOR == 2 + db_appexit(env->Env) ; +#else + (env->Env->close)(env->Env, 0) ; +#endif + if (env->ErrHandle) + 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", (char *)env) ; + Trace(("End of BerkeleyDB::Env::DESTROY %d\n", RETVAL)) ; + +BerkeleyDB::TxnMgr::Raw +_TxnMgr(env) + BerkeleyDB::Env env + INIT: + ckActive_Environment(env->active) ; + if (!env->txn_enabled) + softCrash("Transaction Manager not enabled") ; + CODE: + ZMALLOC(RETVAL, BerkeleyDB_TxnMgr_type) ; + RETVAL->env = env ; + /* hash_store_iv("BerkeleyDB::Term::TxnMgr", (char *)txn, 1) ; */ + OUTPUT: + RETVAL + +int +set_lg_dir(env, dir) + BerkeleyDB::Env env + char * dir + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("$env->set_lg_dir needs Berkeley DB 3.1 or better") ; +#else + RETVAL = env->Status = env->Env->set_lg_dir(env->Env, dir); +#endif + OUTPUT: + RETVAL + +int +set_lg_bsize(env, bsize) + BerkeleyDB::Env env + u_int32_t bsize + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3 + softCrash("$env->set_lg_bsize needs Berkeley DB 3.0.55 or better") ; +#else + RETVAL = env->Status = env->Env->set_lg_bsize(env->Env, bsize); +#endif + OUTPUT: + RETVAL + +int +set_lg_max(env, lg_max) + BerkeleyDB::Env env + u_int32_t lg_max + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3 + softCrash("$env->set_lg_max needs Berkeley DB 3.0.55 or better") ; +#else + RETVAL = env->Status = env->Env->set_lg_max(env->Env, lg_max); +#endif + OUTPUT: + RETVAL + +int +set_data_dir(env, dir) + BerkeleyDB::Env env + char * dir + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("$env->set_data_dir needs Berkeley DB 3.1 or better") ; +#else + RETVAL = env->Status = env->Env->set_data_dir(env->Env, dir); +#endif + OUTPUT: + RETVAL + +int +set_tmp_dir(env, dir) + BerkeleyDB::Env env + char * dir + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("$env->set_tmp_dir needs Berkeley DB 3.1 or better") ; +#else + RETVAL = env->Status = env->Env->set_tmp_dir(env->Env, dir); +#endif + OUTPUT: + RETVAL + +int +set_mutexlocks(env, do_lock) + BerkeleyDB::Env env + int do_lock + INIT: + ckActive_Database(env->active) ; + CODE: +#ifndef AT_LEAST_DB_3 + softCrash("$env->set_setmutexlocks needs Berkeley DB 3.0 or better") ; +#else +#if defined(AT_LEAST_DB_3_2_6) || defined(IS_DB_3_0_x) + RETVAL = env->Status = env->Env->set_mutexlocks(env->Env, do_lock); +#else /* DB 3.1 or 3.2.3 */ + RETVAL = env->Status = db_env_set_mutexlocks(do_lock); +#endif +#endif + 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) + int flags + BerkeleyDB::Common db + HV * RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { +#if DB_VERSION_MAJOR == 2 + softCrash("$db->db_stat for a Hash needs Berkeley DB 3.x or better") ; +#else + DB_HASH_STAT * stat ; +#ifdef AT_LEAST_DB_3_3 + db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ; +#else + db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; +#endif + if (db->Status == 0) { + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "hash_magic", stat->hash_magic) ; + hv_store_iv(RETVAL, "hash_version", stat->hash_version); + hv_store_iv(RETVAL, "hash_pagesize", stat->hash_pagesize); +#ifdef AT_LEAST_DB_3_1 + hv_store_iv(RETVAL, "hash_nkeys", stat->hash_nkeys); + hv_store_iv(RETVAL, "hash_ndata", stat->hash_ndata); +#else + hv_store_iv(RETVAL, "hash_nrecs", stat->hash_nrecs); +#endif + 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(PTR2IV(RETVAL)))); + if (RETVAL) + XPUSHs(sv_2mortal(newSVpv(Names[RETVAL->type], 0))) ; + else + XPUSHs(sv_2mortal(newSViv((IV)NULL))); + } + + + +MODULE = BerkeleyDB::Btree PACKAGE = BerkeleyDB::Btree PREFIX = btree_ + +BerkeleyDB::Btree::Raw +_db_open_btree(self, ref) + char * self + SV * ref + CODE: + { + HV * hash ; + SV * sv ; + DB_INFO info ; + BerkeleyDB__Env dbenv = NULL; + SV * ref_dbenv = NULL; + const char * file = NULL ; + const char * subname = NULL ; + int flags = 0 ; + int mode = 0 ; + BerkeleyDB db ; + + 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) + int flags + BerkeleyDB::Common db + HV * RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { + DB_BTREE_STAT * stat ; +#ifdef AT_LEAST_DB_3_3 + db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ; +#else + db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; +#endif + if (db->Status == 0) { + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "bt_magic", stat->bt_magic); + hv_store_iv(RETVAL, "bt_version", stat->bt_version); +#if DB_VERSION_MAJOR > 2 + hv_store_iv(RETVAL, "bt_metaflags", stat->bt_metaflags) ; + hv_store_iv(RETVAL, "bt_flags", stat->bt_metaflags) ; +#else + hv_store_iv(RETVAL, "bt_flags", stat->bt_flags) ; +#endif + hv_store_iv(RETVAL, "bt_maxkey", stat->bt_maxkey) ; + hv_store_iv(RETVAL, "bt_minkey", stat->bt_minkey); + hv_store_iv(RETVAL, "bt_re_len", stat->bt_re_len); + hv_store_iv(RETVAL, "bt_re_pad", stat->bt_re_pad); + hv_store_iv(RETVAL, "bt_pagesize", stat->bt_pagesize); + hv_store_iv(RETVAL, "bt_levels", stat->bt_levels); +#ifdef AT_LEAST_DB_3_1 + hv_store_iv(RETVAL, "bt_nkeys", stat->bt_nkeys); + hv_store_iv(RETVAL, "bt_ndata", stat->bt_ndata); +#else + hv_store_iv(RETVAL, "bt_nrecs", stat->bt_nrecs); +#endif + hv_store_iv(RETVAL, "bt_int_pg", stat->bt_int_pg); + hv_store_iv(RETVAL, "bt_leaf_pg", stat->bt_leaf_pg); + hv_store_iv(RETVAL, "bt_dup_pg", stat->bt_dup_pg); + hv_store_iv(RETVAL, "bt_over_pg", stat->bt_over_pg); + hv_store_iv(RETVAL, "bt_free", stat->bt_free); +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 + hv_store_iv(RETVAL, "bt_freed", stat->bt_freed); + hv_store_iv(RETVAL, "bt_pfxsaved", stat->bt_pfxsaved); + hv_store_iv(RETVAL, "bt_split", stat->bt_split); + hv_store_iv(RETVAL, "bt_rootsplit", stat->bt_rootsplit); + hv_store_iv(RETVAL, "bt_fastsplit", stat->bt_fastsplit); + hv_store_iv(RETVAL, "bt_added", stat->bt_added); + hv_store_iv(RETVAL, "bt_deleted", stat->bt_deleted); + hv_store_iv(RETVAL, "bt_get", stat->bt_get); + hv_store_iv(RETVAL, "bt_cache_hit", stat->bt_cache_hit); + hv_store_iv(RETVAL, "bt_cache_miss", stat->bt_cache_miss); +#endif + hv_store_iv(RETVAL, "bt_int_pgfree", stat->bt_int_pgfree); + hv_store_iv(RETVAL, "bt_leaf_pgfree", stat->bt_leaf_pgfree); + hv_store_iv(RETVAL, "bt_dup_pgfree", stat->bt_dup_pgfree); + hv_store_iv(RETVAL, "bt_over_pgfree", stat->bt_over_pgfree); + safefree(stat) ; + } + } + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Recno PACKAGE = BerkeleyDB::Recno PREFIX = recno_ + +BerkeleyDB::Recno::Raw +_db_open_recno(self, ref) + char * self + SV * ref + CODE: + { + HV * hash ; + SV * sv ; + DB_INFO info ; + BerkeleyDB__Env dbenv = NULL; + SV * ref_dbenv = NULL; + const char * file = NULL ; + const char * subname = NULL ; + int flags = 0 ; + int mode = 0 ; + BerkeleyDB db ; + + 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) + int flags + BerkeleyDB::Common db + HV * RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { +#if DB_VERSION_MAJOR == 2 + softCrash("$db->db_stat for a Queue needs Berkeley DB 3.x or better") ; +#else /* Berkeley DB 3, or better */ + DB_QUEUE_STAT * stat ; +#ifdef AT_LEAST_DB_3_3 + db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ; +#else + db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ; +#endif + if (db->Status == 0) { + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "qs_magic", stat->qs_magic) ; + hv_store_iv(RETVAL, "qs_version", stat->qs_version); +#ifdef AT_LEAST_DB_3_1 + hv_store_iv(RETVAL, "qs_nkeys", stat->qs_nkeys); + hv_store_iv(RETVAL, "qs_ndata", stat->qs_ndata); +#else + hv_store_iv(RETVAL, "qs_nrecs", stat->qs_nrecs); +#endif + hv_store_iv(RETVAL, "qs_pages", stat->qs_pages); + hv_store_iv(RETVAL, "qs_pagesize", stat->qs_pagesize); + hv_store_iv(RETVAL, "qs_pgfree", stat->qs_pgfree); + hv_store_iv(RETVAL, "qs_re_len", stat->qs_re_len); + hv_store_iv(RETVAL, "qs_re_pad", stat->qs_re_pad); +#ifdef AT_LEAST_DB_3_2 +#else + hv_store_iv(RETVAL, "qs_start", stat->qs_start); +#endif + hv_store_iv(RETVAL, "qs_first_recno", stat->qs_first_recno); + hv_store_iv(RETVAL, "qs_cur_recno", stat->qs_cur_recno); +#if DB_VERSION_MAJOR >= 3 + hv_store_iv(RETVAL, "qs_metaflags", stat->qs_metaflags); +#endif + safefree(stat) ; + } +#endif + } + OUTPUT: + RETVAL + + +MODULE = BerkeleyDB::Common PACKAGE = BerkeleyDB::Common PREFIX = dab_ + + +DualType +db_close(db,flags=0) + int flags + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CurrentDB = db ; + CODE: + Trace(("BerkeleyDB::Common::db_close %d\n", db)); +#ifdef STRICT_CLOSE + if (db->txn) + softCrash("attempted to close a database while a transaction was still open") ; + if (db->open_cursors) + softCrash("attempted to close a database with %d open cursor(s)", + db->open_cursors) ; +#endif /* STRICT_CLOSE */ + RETVAL = db->Status = ((db->dbp)->close)(db->dbp, flags) ; + if (db->parent_env && db->parent_env->open_dbs) + -- db->parent_env->open_dbs ; + db->active = FALSE ; + hash_delete("BerkeleyDB::Term::Db", (char *)db) ; + -- db->open_cursors ; + Trace(("end of BerkeleyDB::Common::db_close\n")); + OUTPUT: + RETVAL + +void +dab__DESTROY(db) + BerkeleyDB::Common db + CODE: + CurrentDB = db ; + Trace(("In BerkeleyDB::Common::_DESTROY db %d dirty=%d\n", db, PL_dirty)) ; + destroyDB(db) ; + Trace(("End of BerkeleyDB::Common::DESTROY \n")) ; + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 +#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur) +#else +#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur,flags) +#endif +BerkeleyDB::Cursor::Raw +_db_cursor(db, flags=0) + u_int32_t flags + BerkeleyDB::Common db + BerkeleyDB::Cursor RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { + DBC * cursor ; + CurrentDB = db ; + if ((db->Status = db_cursor(db, db->txn, &cursor, flags)) == 0){ + ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ; + db->open_cursors ++ ; + RETVAL->parent_db = db ; + RETVAL->cursor = cursor ; + RETVAL->dbp = db->dbp ; + RETVAL->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", (char *)RETVAL, 1) ; + } + } + OUTPUT: + RETVAL + +BerkeleyDB::Cursor::Raw +_db_join(db, cursors, flags=0) + u_int32_t flags + BerkeleyDB::Common db + AV * cursors + BerkeleyDB::Cursor RETVAL = NULL ; + INIT: + ckActive_Database(db->active) ; + CODE: + { +#if DB_VERSION_MAJOR == 2 && (DB_VERSION_MINOR < 5 || (DB_VERSION_MINOR == 5 && DB_VERSION_PATCH < 2)) + softCrash("join needs Berkeley DB 2.5.2 or later") ; +#else /* Berkeley DB >= 2.5.2 */ + DBC * join_cursor ; + DBC ** cursor_list ; + I32 count = av_len(cursors) + 1 ; + int i ; + CurrentDB = db ; + if (count < 1 ) + softCrash("db_join: No cursors in parameter list") ; + cursor_list = (DBC **)safemalloc(sizeof(DBC*) * (count + 1)); + for (i = 0 ; i < count ; ++i) { + SV * obj = (SV*) * av_fetch(cursors, i, FALSE) ; + IV tmp = SvIV(getInnerObject(obj)) ; + BerkeleyDB__Cursor cur = INT2PTR(BerkeleyDB__Cursor, tmp); + cursor_list[i] = cur->cursor ; + } + cursor_list[i] = NULL ; +#if DB_VERSION_MAJOR == 2 + if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, flags, &join_cursor)) == 0){ +#else + if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, &join_cursor, flags)) == 0){ +#endif + ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ; + db->open_cursors ++ ; + RETVAL->parent_db = db ; + RETVAL->cursor = join_cursor ; + RETVAL->dbp = db->dbp ; + RETVAL->type = db->type ; + RETVAL->filename = my_strdup(db->filename) ; + RETVAL->compare = db->compare ; + RETVAL->dup_compare = db->dup_compare ; + RETVAL->prefix = db->prefix ; + RETVAL->hash = db->hash ; + RETVAL->partial = db->partial ; + RETVAL->doff = db->doff ; + RETVAL->dlen = db->dlen ; + RETVAL->active = TRUE ; +#ifdef ALLOW_RECNO_OFFSET + RETVAL->array_base = db->array_base ; +#endif /* ALLOW_RECNO_OFFSET */ +#ifdef DBM_FILTERING + RETVAL->filtering = FALSE ; + RETVAL->filter_fetch_key = db->filter_fetch_key ; + RETVAL->filter_store_key = db->filter_store_key ; + RETVAL->filter_fetch_value = db->filter_fetch_value ; + RETVAL->filter_store_value = db->filter_store_value ; +#endif + /* RETVAL->info ; */ + hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ; + } + safefree(cursor_list) ; +#endif /* Berkeley DB >= 2.5.2 */ + } + OUTPUT: + RETVAL + +int +ArrayOffset(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: +#ifdef ALLOW_RECNO_OFFSET + RETVAL = db->array_base ? 0 : 1 ; +#else + RETVAL = 0 ; +#endif /* ALLOW_RECNO_OFFSET */ + OUTPUT: + RETVAL + +int +type(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: + RETVAL = db->type ; + OUTPUT: + RETVAL + +int +byteswapped(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 + softCrash("byteswapped needs Berkeley DB 2.5 or later") ; +#else +#if DB_VERSION_MAJOR == 2 + RETVAL = db->dbp->byteswapped ; +#else +#ifdef AT_LEAST_DB_3_3 + db->dbp->get_byteswapped(db->dbp, &RETVAL) ; +#else + RETVAL = db->dbp->get_byteswapped(db->dbp) ; +#endif +#endif +#endif + OUTPUT: + RETVAL + +DualType +status(db) + BerkeleyDB::Common db + CODE: + RETVAL = db->Status ; + OUTPUT: + RETVAL + +#ifdef DBM_FILTERING + +#define setFilter(ftype) \ + { \ + if (db->ftype) \ + RETVAL = sv_mortalcopy(db->ftype) ; \ + ST(0) = RETVAL ; \ + if (db->ftype && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->ftype) ; \ + db->ftype = NULL ; \ + } \ + else if (code) { \ + if (db->ftype) \ + sv_setsv(db->ftype, code) ; \ + else \ + db->ftype = newSVsv(code) ; \ + } \ + } + + +SV * +filter_fetch_key(db, code) + BerkeleyDB::Common db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + 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) + u_int flags + BerkeleyDB::Common db + DBTKEY key + 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) + u_int flags + BerkeleyDB::Common db + 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) + u_int flags + BerkeleyDB::Common db + DBTKEY key + DBT data + 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) + u_int32_t flags + BerkeleyDB::Common db + DBTKEY_B key + double less = 0.0 ; + double equal = 0.0 ; + double greater = 0.0 ; + CODE: + { +#ifndef AT_LEAST_DB_3_1 + softCrash("key_range needs Berkeley DB 3.1.x or later") ; +#else + DB_KEY_RANGE range ; + range.less = range.equal = range.greater = 0.0 ; + ckActive_Database(db->active) ; + CurrentDB = db ; + RETVAL = db_key_range(db, key, range, flags); + if (RETVAL == 0) { + less = range.less ; + equal = range.equal; + greater = range.greater; + } +#endif + } + OUTPUT: + RETVAL + less + equal + greater + + +#define db_fd(d, x) (db->Status = (db->dbp->fd)(db->dbp, &x)) +DualType +db_fd(db) + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CODE: + CurrentDB = db ; + db_fd(db, RETVAL) ; + OUTPUT: + RETVAL + + +#define db_sync(db, fl) (db->Status = (db->dbp->sync)(db->dbp, fl)) +DualType +db_sync(db, flags=0) + u_int flags + BerkeleyDB::Common db + INIT: + ckActive_Database(db->active) ; + CurrentDB = db ; + +void +_Txn(db, txn=NULL) + BerkeleyDB::Common db + BerkeleyDB::Txn txn + INIT: + ckActive_Database(db->active) ; + CODE: + if (txn) { + Trace(("_Txn(%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) + u_int32_t flags + BerkeleyDB::Cursor db + BerkeleyDB::Cursor RETVAL = NULL ; + INIT: + CurrentDB = db->parent_db ; + ckActive_Database(db->active) ; + CODE: + { +#ifndef AT_LEAST_DB_3 + softCrash("c_dup needs at least Berkeley DB 3.0.x"); +#else + DBC * newcursor ; + db->Status = ((db->cursor)->c_dup)(db->cursor, &newcursor, flags) ; + if (db->Status == 0){ + ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ; + db->parent_db->open_cursors ++ ; + RETVAL->parent_db = db->parent_db ; + RETVAL->cursor = newcursor ; + RETVAL->dbp = db->dbp ; + RETVAL->type = db->type ; + RETVAL->recno_or_queue = db->recno_or_queue ; + RETVAL->filename = my_strdup(db->filename) ; + RETVAL->compare = db->compare ; + RETVAL->dup_compare = db->dup_compare ; + RETVAL->prefix = db->prefix ; + RETVAL->hash = db->hash ; + RETVAL->partial = db->partial ; + RETVAL->doff = db->doff ; + RETVAL->dlen = db->dlen ; + RETVAL->active = TRUE ; +#ifdef ALLOW_RECNO_OFFSET + RETVAL->array_base = db->array_base ; +#endif /* ALLOW_RECNO_OFFSET */ +#ifdef DBM_FILTERING + RETVAL->filtering = FALSE ; + RETVAL->filter_fetch_key = db->filter_fetch_key ; + RETVAL->filter_store_key = db->filter_store_key ; + RETVAL->filter_fetch_value = db->filter_fetch_value ; + RETVAL->filter_store_value = db->filter_store_value ; +#endif /* DBM_FILTERING */ + /* RETVAL->info ; */ + hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ; + } +#endif + } + OUTPUT: + RETVAL + +DualType +_c_close(db) + BerkeleyDB::Cursor db + INIT: + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ; + CODE: + RETVAL = db->Status = + ((db->cursor)->c_close)(db->cursor) ; + db->active = FALSE ; + if (db->parent_db->open_cursors) + -- db->parent_db->open_cursors ; + OUTPUT: + RETVAL + +void +_DESTROY(db) + BerkeleyDB::Cursor db + CODE: + CurrentDB = db->parent_db ; + Trace(("In BerkeleyDB::Cursor::_DESTROY db %d dirty=%d active=%d\n", db, PL_dirty, db->active)); + hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ; + if (db->active) + ((db->cursor)->c_close)(db->cursor) ; + if (db->parent_db->open_cursors) + -- db->parent_db->open_cursors ; + Safefree(db->filename) ; + Safefree(db) ; + Trace(("End of BerkeleyDB::Cursor::_DESTROY\n")) ; + +DualType +status(db) + BerkeleyDB::Cursor db + CODE: + RETVAL = db->Status ; + OUTPUT: + RETVAL + + +#define cu_c_del(c,f) (c->Status = ((c->cursor)->c_del)(c->cursor,f)) +DualType +cu_c_del(db, flags=0) + int flags + BerkeleyDB::Cursor db + INIT: + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + OUTPUT: + RETVAL + + +#define cu_c_get(c,k,d,f) (c->Status = (c->cursor->c_get)(c->cursor,&k,&d,f)) +DualType +cu_c_get(db, key, data, flags=0) + int flags + BerkeleyDB::Cursor db + DBTKEY_B key + DBT_B data + INIT: + Trace(("c_get db [%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) + int flags + BerkeleyDB::Cursor db + DBTKEY key + DBT data + INIT: + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + /* SetPartial(data,db) ; */ + OUTPUT: + RETVAL + +#define cu_c_count(c,p,f) (c->Status = (c->cursor->c_count)(c->cursor,&p,f)) +DualType +cu_c_count(db, count, flags=0) + int flags + BerkeleyDB::Cursor db + u_int32_t count = NO_INIT + CODE: +#ifndef AT_LEAST_DB_3_1 + softCrash("c_count needs at least Berkeley DB 3.1.x"); +#else + Trace(("c_get count [%d] flags [%d]\n", db, flags)) ; + CurrentDB = db->parent_db ; + ckActive_Cursor(db->active) ; + RETVAL = cu_c_count(db, count, flags) ; + Trace((" c_count got %d duplicates\n", count)) ; +#endif + OUTPUT: + RETVAL + count + +MODULE = BerkeleyDB::TxnMgr PACKAGE = BerkeleyDB::TxnMgr PREFIX = xx_ + +BerkeleyDB::Txn::Raw +_txn_begin(txnmgr, pid=NULL, flags=0) + u_int32_t flags + BerkeleyDB::TxnMgr txnmgr + BerkeleyDB::Txn pid + CODE: + { + DB_TXN *txn ; + DB_TXN *p_id = NULL ; +#if DB_VERSION_MAJOR == 2 + if (txnmgr->env->Env->tx_info == NULL) + softCrash("Transaction Manager not enabled") ; +#endif + if (pid) + p_id = pid->txn ; + txnmgr->env->TxnMgrStatus = +#if DB_VERSION_MAJOR == 2 + txn_begin(txnmgr->env->Env->tx_info, p_id, &txn) ; +#else + 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", (char *)RETVAL, 1) ; + } + else + RETVAL = NULL ; + } + OUTPUT: + RETVAL + + +DualType +status(mgr) + BerkeleyDB::TxnMgr mgr + CODE: + RETVAL = mgr->env->TxnMgrStatus ; + OUTPUT: + RETVAL + + +void +_DESTROY(mgr) + BerkeleyDB::TxnMgr mgr + CODE: + Trace(("In BerkeleyDB::TxnMgr::DESTROY dirty=%d\n", PL_dirty)) ; + Safefree(mgr) ; + Trace(("End of BerkeleyDB::TxnMgr::DESTROY\n")) ; + +DualType +txn_close(txnp) + BerkeleyDB::TxnMgr txnp + NOT_IMPLEMENTED_YET + + +#if DB_VERSION_MAJOR == 2 +# define xx_txn_checkpoint(t,k,m) 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 ; +#ifdef AT_LEAST_DB_3_3 + if(txn_stat(txnp->env->Env, &stat) == 0) { +#else +#if DB_VERSION_MAJOR == 2 + if(txn_stat(txnp->env->Env->tx_info, &stat, safemalloc) == 0) { +#else + if(txn_stat(txnp->env->Env, &stat, safemalloc) == 0) { +#endif +#endif + RETVAL = (HV*)sv_2mortal((SV*)newHV()) ; + hv_store_iv(RETVAL, "st_time_ckp", stat->st_time_ckp) ; + hv_store_iv(RETVAL, "st_last_txnid", stat->st_last_txnid) ; + hv_store_iv(RETVAL, "st_maxtxns", stat->st_maxtxns) ; + hv_store_iv(RETVAL, "st_naborts", stat->st_naborts) ; + hv_store_iv(RETVAL, "st_nbegins", stat->st_nbegins) ; + hv_store_iv(RETVAL, "st_ncommits", stat->st_ncommits) ; + hv_store_iv(RETVAL, "st_nactive", stat->st_nactive) ; +#if DB_VERSION_MAJOR > 2 + hv_store_iv(RETVAL, "st_maxnactive", stat->st_maxnactive) ; + hv_store_iv(RETVAL, "st_regsize", stat->st_regsize) ; + hv_store_iv(RETVAL, "st_region_wait", stat->st_region_wait) ; + hv_store_iv(RETVAL, "st_region_nowait", stat->st_region_nowait) ; +#endif + safefree(stat) ; + } + } + OUTPUT: + RETVAL + + +BerkeleyDB::TxnMgr +txn_open(dir, flags, mode, dbenv) + int flags + const char * dir + int mode + BerkeleyDB::Env dbenv + NOT_IMPLEMENTED_YET + + +MODULE = BerkeleyDB::Txn PACKAGE = BerkeleyDB::Txn PREFIX = xx_ + +DualType +status(tid) + BerkeleyDB::Txn tid + CODE: + RETVAL = tid->Status ; + OUTPUT: + RETVAL + +int +_DESTROY(tid) + BerkeleyDB::Txn tid + CODE: + Trace(("In BerkeleyDB::Txn::_DESTROY txn [%d] active [%d] dirty=%d\n", tid->txn, tid->active, PL_dirty)) ; + if (tid->active) + txn_abort(tid->txn) ; + RETVAL = (int)tid ; + hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ; + Safefree(tid) ; + Trace(("End of BerkeleyDB::Txn::DESTROY\n")) ; + OUTPUT: + RETVAL + +#define xx_txn_unlink(d,f,e) txn_unlink(d,f,&(e->Env)) +DualType +xx_txn_unlink(dir, force, dbenv) + const char * dir + int force + BerkeleyDB::Env dbenv + NOT_IMPLEMENTED_YET + +#ifdef AT_LEAST_DB_3_3 +#define xx_txn_prepare(t) (t->Status = txn_prepare(t->txn, 0)) +#else +#define xx_txn_prepare(t) (t->Status = txn_prepare(t->txn)) +#endif +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) + u_int32_t flags + BerkeleyDB::Txn tid + INIT: + ckActive_Transaction(tid->active) ; + hash_delete("BerkeleyDB::Term::Txn", (char *)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", (char *)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/db/perl/BerkeleyDB/BerkeleyDB/Btree.pm b/db/perl/BerkeleyDB/BerkeleyDB/Btree.pm new file mode 100644 index 000000000..ba9a9c008 --- /dev/null +++ b/db/perl/BerkeleyDB/BerkeleyDB/Btree.pm @@ -0,0 +1,8 @@ + +package BerkeleyDB::Btree ; + +# This file is only used for MLDBM + +use BerkeleyDB ; + +1 ; diff --git a/db/perl/BerkeleyDB/BerkeleyDB/Hash.pm b/db/perl/BerkeleyDB/BerkeleyDB/Hash.pm new file mode 100644 index 000000000..8e7bc7e78 --- /dev/null +++ b/db/perl/BerkeleyDB/BerkeleyDB/Hash.pm @@ -0,0 +1,8 @@ + +package BerkeleyDB::Hash ; + +# This file is only used for MLDBM + +use BerkeleyDB ; + +1 ; diff --git a/db/perl/BerkeleyDB/Changes b/db/perl/BerkeleyDB/Changes new file mode 100644 index 000000000..f647bea85 --- /dev/null +++ b/db/perl/BerkeleyDB/Changes @@ -0,0 +1,129 @@ +Revision history for Perl extension BerkeleyDB. + +0.16 26 1 August 2001 + * added support for Berkeley DB 3.3.x (but no support for any of the + new features just yet) + +0.15 26 April 2001 + * Fixed a bug in the processing of the flags options in + db_key_range. + * added support for set_lg_max & set_lg_bsize + * allow DB_TMP_DIR and DB_TEMP_DIR + * the -Filename parameter to BerkeleyDB::Queue didn't work. + * added symbol DB_CONSUME_WAIT + +0.14 21st January 2001 + * Silenced the warnings when build with a 64-bit Perl. + * Can now build with DB 3.2.3h (part of MySQL). The test harness + takes an age to do the queue test, but it does eventually pass. + * Mentioned the problems that occur when perl is built with sfio. + +0.13 15th January 2001 + * Added support to allow this module to build with Berkeley DB 3.2 + * Updated dbinfo to support Berkeley DB 3.1 & 3.2 file format + changes. + * Documented the Solaris 2.7 core dump problem in README. + * Tidied up the test harness to fix a problem on Solaris where the + "fred" directory wasn't being deleted when it should have been. + * two calls to "open" clashed with a win32 macro. + * size argument for hash_cb is different for Berkeley DB 3.x + * Documented the issue of building on Linux. + * Added -Server, -CacheSize & -LockDetect options + [original patch supplied by Graham Barr] + * Added support for set_mutexlocks, c_count, set_q_extentsize, + key_range, c_dup + * Dropped the "attempted to close a Cursor with an open transaction" + error in c_close. The correct behaviour is that the cursor + should be closed before committing/aborting the transaction. + +0.12 2nd August 2000 + * Serious bug with get fixed. Spotted by Sleepycat. + * Added hints file for Solaris & Irix (courtesy of Albert Chin-A-Young) + +0.11 4th June 2000 + * When built with Berkeley Db 3.x there can be a clash with the close + macro. + * Typo in the definition of DB_WRITECURSOR + * The flags parameter wasn't getting sent to db_cursor + * Plugged small memory leak in db_cursor (DESTROY wasn't freeing + memory) + * Can be built with Berkeley DB 3.1 + +0.10 8th December 1999 + * The DESTROY method was missing for BerkeleyDB::Env. This resulted in + a memory leak. Fixed. + * If opening an environment or database failed, there was a small + memory leak. This has been fixed. + * A thread-enabled Perl it could core when a database was closed. + Problem traced to the strdup function. + +0.09 29th November 1999 + * the queue.t & subdb.t test harnesses were outputting a few + spurious warnings. This has been fixed. + +0.08 28nd November 1999 + * More documentation updates + * Changed reference to files in /tmp in examples.t + * Fixed a typo in softCrash that caused problems when building + with a thread-enabled Perl. + * BerkeleyDB::Error wasn't initialised properly. + * ANSI-ified all the static C functions in BerkeleyDB.xs + * Added support for the following DB 3.x features: + + The Queue database type + + db_remove + + subdatabases + + db_stat for Hash & Queue + +0.07 21st September 1999 + * Numerous small bug fixes. + * Added support for sorting duplicate values DB_DUPSORT. + * Added support for DB_GET_BOTH & DB_NEXT_DUP. + * Added get_dup (from DB_File). + * beefed up the documentation. + * Forgot to add the DB_INIT_CDB in BerkeleyDB.pm in previous release. + * Merged the DBM Filter code from DB_File into BerkeleyDB. + * Fixed a nasty bug where a closed transaction was still used with + with dp_put, db_get etc. + * Added logic to gracefully close everything whenever a fatal error + happens. Previously the plug was just pulled. + * It is now a fatal error to explicitly close an environment if there + is still an open database; a database when there are open cursors or + an open transaction; and a cursor if there is an open transaction. + Using object destruction doesn't have this issue, as object + references will ensure everything gets closed in the correct order. + * The BOOT code now checks that the version of db.h & libdb are the + same - this seems to be a common problem on Linux. + * MLDBM support added. + * Support for the new join cursor added. + * Builds with Berkeley DB 3.x + * Updated dbinfo for Berkeley DB 3.x file formats. + * Deprecated the TxnMgr class. As with Berkeley DB version 3, + txn_begin etc are now accessed via the environment object. + +0.06 19 December 1998 + * Minor modifications to get the module to build with DB 2.6.x + * Added support for DB 2.6.x's Concurrent Access Method, DB_INIT_CDB. + +0.05 9 November 1998 + * Added a note to README about how to build Berkeley DB 2.x + when using HP-UX. + * Minor modifications to get the module to build with DB 2.5.x + +0.04 19 May 1998 + * Define DEFSV & SAVE_DEFSV if not already defined. This allows + the module to be built with Perl 5.004_04. + +0.03 5 May 1998 + * fixed db_get with DB_SET_RECNO + * fixed c_get with DB_SET_RECNO and DB_GET_RECNO + * implemented BerkeleyDB::Unknown + * implemented BerkeleyDB::Recno, including push, pop etc + modified the txn support. + +0.02 30 October 1997 + * renamed module to BerkeleyDB + * fixed a few bugs & added more tests + +0.01 23 October 1997 + * first alpha release as BerkDB. + diff --git a/db/perl/BerkeleyDB/MANIFEST b/db/perl/BerkeleyDB/MANIFEST new file mode 100644 index 000000000..ed8450f6f --- /dev/null +++ b/db/perl/BerkeleyDB/MANIFEST @@ -0,0 +1,50 @@ +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 +t/util.pm +Todo +typemap +patches/5.004 +patches/5.004_01 +patches/5.004_02 +patches/5.004_03 +patches/5.004_04 +patches/5.004_05 +patches/5.005 +patches/5.005_01 +patches/5.005_02 +patches/5.005_03 +patches/5.6.0 diff --git a/db/perl/BerkeleyDB/Makefile.PL b/db/perl/BerkeleyDB/Makefile.PL new file mode 100644 index 000000000..c99283b20 --- /dev/null +++ b/db/perl/BerkeleyDB/Makefile.PL @@ -0,0 +1,123 @@ +#! perl -w + +# It should not be necessary to edit this file. The configuration for +# BerkeleyDB is controlled from the file config.in + + +BEGIN { die "BerkeleyDB needs Perl 5.004_04 or greater" if $] < 5.004_04 ; } + +use strict ; +use ExtUtils::MakeMaker ; +use Config ; + +# Check for the presence of sfio +if ($Config{'d_sfio'}) { + print <<EOM; + +WARNING: Perl seems to have been built with SFIO support enabled. + Please read the SFIO Notes in the README file. + +EOM +} + +my $LIB_DIR ; +my $INC_DIR ; +my $DB_NAME ; +my $LIBS ; + +ParseCONFIG() ; + +if (defined $DB_NAME) + { $LIBS = $DB_NAME } +else { + if ($^O eq 'MSWin32') + { $LIBS = '-llibdb' } + else + { $LIBS = '-ldb' } +} + +# OS2 is a special case, so check for it now. +my $OS2 = "" ; +$OS2 = "-DOS2" if $^O eq 'os2' ; + +WriteMakefile( + NAME => 'BerkeleyDB', + LIBS => ["-L${LIB_DIR} $LIBS"], + MAN3PODS => ' ', # Pods will be built by installman. + INC => "-I$INC_DIR", + VERSION_FROM => 'BerkeleyDB.pm', + XSPROTOARG => '-noprototypes', + DEFINE => "$OS2", + #'macro' => { INSTALLDIRS => 'perl' }, + 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'}, + ($] >= 5.005 + ? (ABSTRACT_FROM => 'BerkeleyDB.pod', + AUTHOR => 'Paul Marquess <Paul.Marquess@btinternet.com>') + : () + ), + ); + + +sub MY::postamble { + ' +$(NAME).pod: $(NAME).pod.P t/examples.t.T t/examples3.t.T mkpod + perl ./mkpod + +$(NAME).xs: typemap + @$(TOUCH) $(NAME).xs + +Makefile: config.in + + +' ; +} + +sub ParseCONFIG +{ + my ($k, $v) ; + my @badkey = () ; + my %Info = () ; + my @Options = qw( INCLUDE LIB DBNAME ) ; + my %ValidOption = map {$_, 1} @Options ; + my %Parsed = %ValidOption ; + my $CONFIG = 'config.in' ; + + print "Parsing $CONFIG...\n" ; + + # DBNAME is optional, so pretend it has been parsed. + delete $Parsed{'DBNAME'} ; + + open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ; + while (<F>) { + s/^\s*|\s*$//g ; + next if /^\s*$/ or /^\s*#/ ; + s/\s*#\s*$// ; + + ($k, $v) = split(/\s+=\s+/, $_, 2) ; + $k = uc $k ; + if ($ValidOption{$k}) { + delete $Parsed{$k} ; + $Info{$k} = $v ; + } + else { + push(@badkey, $k) ; + } + } + close F ; + + print "Unknown keys in $CONFIG ignored [@badkey]\n" + if @badkey ; + + # check parsed values + my @missing = () ; + die "The following keys are missing from $CONFIG file: [@missing]\n" + if @missing = keys %Parsed ; + + $INC_DIR = $ENV{'BERKELEYDB_INCLUDE'} || $Info{'INCLUDE'} ; + $LIB_DIR = $ENV{'BERKELEYDB_LIB'} || $Info{'LIB'} ; + $DB_NAME = $Info{'DBNAME'} if defined $Info{'DBNAME'} ; + print "Looks Good.\n" ; + +} + +# end of file Makefile.PL diff --git a/db/perl/BerkeleyDB/README b/db/perl/BerkeleyDB/README new file mode 100644 index 000000000..5784a1954 --- /dev/null +++ b/db/perl/BerkeleyDB/README @@ -0,0 +1,464 @@ + BerkeleyDB + + Version 0.16 + + 1st August 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/db/perl/BerkeleyDB/Todo b/db/perl/BerkeleyDB/Todo new file mode 100644 index 000000000..12d53bcf9 --- /dev/null +++ b/db/perl/BerkeleyDB/Todo @@ -0,0 +1,57 @@ + + * Proper documentation. + + * address or document the "close all cursors if you encounter an error" + + * Change the $BerkeleyDB::Error to store the info in the db object, + if possible. + + * $BerkeleyDB::db_version is documented. &db_version isn't. + + * migrate perl code into the .xs file where necessary + + * convert as many of the DB examples files to BerkeleyDB format. + + * add a method to the DB object to allow access to the environment (if there + actually is one). + + +Possibles + + * use '~' magic to store the inner data. + + * for the get stuff zap the value to undef if it doesn't find the + key. This may be more intuitive for those folks who are used with + the $hash{key} interface. + + * Text interface? This can be done as via Recno + + * allow recno to allow base offset for arrays to be either 0 or 1. + + * when duplicate keys are enabled, allow db_put($key, [$val1, $val2,...]) + + +2.x -> 3.x Upgrade +================== + +Environment Verbose +Env->open mode +DB cache size extra parameter +DB->open subdatabases Done +An empty environment causes DB->open to fail +where is __db.001 coming from? db_remove seems to create it. Bug in 3.0.55 +Change db_strerror for 0 to ""? Done +Queue Done +db_stat for Hash & Queue Done +No TxnMgr +DB->remove +ENV->remove +ENV->set_verbose +upgrade + + $env = BerkeleyDB::Env::Create + $env = create BerkeleyDB::Env + $status = $env->open() + + $db = BerkeleyDB::Hash::Create + $status = $db->open() diff --git a/db/perl/BerkeleyDB/config.in b/db/perl/BerkeleyDB/config.in new file mode 100644 index 000000000..1718297d8 --- /dev/null +++ b/db/perl/BerkeleyDB/config.in @@ -0,0 +1,51 @@ +# 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.3.11 + +# 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.3.11 + +# 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/db/perl/BerkeleyDB/dbinfo b/db/perl/BerkeleyDB/dbinfo new file mode 100755 index 000000000..415411aff --- /dev/null +++ b/db/perl/BerkeleyDB/dbinfo @@ -0,0 +1,109 @@ +#!/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/db/perl/BerkeleyDB/hints/irix_6_5.pl b/db/perl/BerkeleyDB/hints/irix_6_5.pl new file mode 100644 index 000000000..b531673e6 --- /dev/null +++ b/db/perl/BerkeleyDB/hints/irix_6_5.pl @@ -0,0 +1 @@ +$self->{LIBS} = [ "@{$self->{LIBS}} -lthread" ]; diff --git a/db/perl/BerkeleyDB/hints/solaris.pl b/db/perl/BerkeleyDB/hints/solaris.pl new file mode 100644 index 000000000..ddd941d63 --- /dev/null +++ b/db/perl/BerkeleyDB/hints/solaris.pl @@ -0,0 +1 @@ +$self->{LIBS} = [ "@{$self->{LIBS}} -lmt" ]; diff --git a/db/perl/BerkeleyDB/mkconsts b/db/perl/BerkeleyDB/mkconsts new file mode 100644 index 000000000..24ef4fca7 --- /dev/null +++ b/db/perl/BerkeleyDB/mkconsts @@ -0,0 +1,211 @@ +#!/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/db/perl/BerkeleyDB/mkpod b/db/perl/BerkeleyDB/mkpod new file mode 100755 index 000000000..44bbf3fbf --- /dev/null +++ b/db/perl/BerkeleyDB/mkpod @@ -0,0 +1,146 @@ +#!/usr/local/bin/perl5 + +# Filename: mkpod +# +# Author: Paul Marquess + +# File types +# +# Macro files end with .M +# Tagged source files end with .T +# Output from the code ends with .O +# Pre-Pod file ends with .P +# +# Tags +# +# ## BEGIN tagname +# ... +# ## END tagname +# +# ## 0 +# ## 1 +# + +# Constants + +$TOKEN = '##' ; +$Verbose = 1 if $ARGV[0] =~ /^-v/i ; + +# Macros files first +foreach $file (glob("*.M")) +{ + open (F, "<$file") or die "Cannot open '$file':$!\n" ; + print " Processing Macro file $file\n" ; + while (<F>) + { + # Skip blank & comment lines + next if /^\s*$/ || /^\s*#/ ; + + # + ($name, $expand) = split (/\t+/, $_, 2) ; + + $expand =~ s/^\s*// ; + $expand =~ s/\s*$// ; + + if ($expand =~ /\[#/ ) + { + } + + $Macros{$name} = $expand ; + } + close F ; +} + +# Suck up all the code files +foreach $file (glob("t/*.T")) +{ + ($newfile = $file) =~ s/\.T$// ; + open (F, "<$file") or die "Cannot open '$file':$!\n" ; + open (N, ">$newfile") or die "Cannot open '$newfile':$!\n" ; + + print " Processing $file -> $newfile\n" ; + + while ($line = <F>) + { + if ($line =~ /^$TOKEN\s*BEGIN\s+(\w+)\s*$/ or + $line =~ m[\s*/\*$TOKEN\s*BEGIN\s+(\w+)\s*$] ) + { + print " Section $1 begins\n" if $Verbose ; + $InSection{$1} ++ ; + $Section{$1} = '' unless $Section{$1} ; + } + elsif ($line =~ /^$TOKEN\s*END\s+(\w+)\s*$/ or + $line =~ m[^\s*/\*$TOKEN\s*END\s+(\w+)\s*$] ) + { + warn "Encountered END without a begin [$line]\n" + unless $InSection{$1} ; + + delete $InSection{$1} ; + print " Section $1 ends\n" if $Verbose ; + } + else + { + print N $line ; + chop $line ; + $line =~ s/\s*$// ; + + # Save the current line in each of the sections + foreach( keys %InSection) + { + if ($line !~ /^\s*$/ ) + #{ $Section{$_} .= " $line" } + { $Section{$_} .= $line } + $Section{$_} .= "\n" ; + } + } + + } + + if (%InSection) + { + # Check for unclosed sections + print "The following Sections are not terminated\n" ; + foreach (sort keys %InSection) + { print "\t$_\n" } + exit 1 ; + } + + close F ; + close N ; +} + +print "\n\nCreating pod file(s)\n\n" if $Verbose ; + +@ppods = glob('*.P') ; +#$ppod = $ARGV[0] ; +#$pod = $ARGV[1] ; + +# Now process the pre-pod file +foreach $ppod (@ppods) +{ + ($pod = $ppod) =~ s/\.P$// ; + open (PPOD, "<$ppod") or die "Cannot open file '$ppod': $!\n" ; + open (POD, ">$pod") or die "Cannot open file '$pod': $!\n" ; + + print " $ppod -> $pod\n" ; + + while ($line = <PPOD>) + { + if ( $line =~ /^\s*$TOKEN\s*(\w+)\s*$/) + { + warn "No code insert '$1' available\n" + unless $Section{$1} ; + + print "Expanding section $1\n" if $Verbose ; + print POD $Section{$1} ; + } + else + { +# $line =~ s/\[#([^\]])]/$Macros{$1}/ge ; + print POD $line ; + } + } + + close PPOD ; + close POD ; +} diff --git a/db/perl/BerkeleyDB/patches/5.004 b/db/perl/BerkeleyDB/patches/5.004 new file mode 100644 index 000000000..143ec95af --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.004 @@ -0,0 +1,44 @@ +diff perl5.004.orig/Configure perl5.004/Configure +190a191 +> perllibs='' +9904a9906,9913 +> : Remove libraries needed only for extensions +> : The appropriate ext/Foo/Makefile.PL will add them back in, if +> : necessary. +> set X `echo " $libs " | +> sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` +> shift +> perllibs="$*" +> +10372a10382 +> perllibs='$perllibs' +diff perl5.004.orig/Makefile.SH perl5.004/Makefile.SH +122c122 +< libs = $libs $cryptlib +--- +> libs = $perllibs $cryptlib +Common subdirectories: perl5.004.orig/Porting and perl5.004/Porting +Common subdirectories: perl5.004.orig/cygwin32 and perl5.004/cygwin32 +Common subdirectories: perl5.004.orig/eg and perl5.004/eg +Common subdirectories: perl5.004.orig/emacs and perl5.004/emacs +Common subdirectories: perl5.004.orig/ext and perl5.004/ext +Common subdirectories: perl5.004.orig/h2pl and perl5.004/h2pl +Common subdirectories: perl5.004.orig/hints and perl5.004/hints +Common subdirectories: perl5.004.orig/lib and perl5.004/lib +diff perl5.004.orig/myconfig perl5.004/myconfig +38c38 +< libs=$libs +--- +> libs=$perllibs +Common subdirectories: perl5.004.orig/os2 and perl5.004/os2 +diff perl5.004.orig/patchlevel.h perl5.004/patchlevel.h +40a41 +> ,"NODB-1.0 - remove -ldb from core perl binary." +Common subdirectories: perl5.004.orig/plan9 and perl5.004/plan9 +Common subdirectories: perl5.004.orig/pod and perl5.004/pod +Common subdirectories: perl5.004.orig/qnx and perl5.004/qnx +Common subdirectories: perl5.004.orig/t and perl5.004/t +Common subdirectories: perl5.004.orig/utils and perl5.004/utils +Common subdirectories: perl5.004.orig/vms and perl5.004/vms +Common subdirectories: perl5.004.orig/win32 and perl5.004/win32 +Common subdirectories: perl5.004.orig/x2p and perl5.004/x2p diff --git a/db/perl/BerkeleyDB/patches/5.004_01 b/db/perl/BerkeleyDB/patches/5.004_01 new file mode 100644 index 000000000..1b05eb4e0 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.004_01 @@ -0,0 +1,217 @@ +diff -rc perl5.004_01.orig/Configure perl5.004_01/Configure +*** perl5.004_01.orig/Configure Wed Jun 11 00:28:03 1997 +--- perl5.004_01/Configure Sun Nov 12 22:12:35 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9907,9912 **** +--- 9908,9921 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10375,10380 **** +--- 10384,10390 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_01.orig/Makefile.SH perl5.004_01/Makefile.SH +*** perl5.004_01.orig/Makefile.SH Thu Jun 12 23:27:56 1997 +--- perl5.004_01/Makefile.SH Sun Nov 12 22:12:35 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_01.orig/lib/ExtUtils/Embed.pm perl5.004_01/lib/ExtUtils/Embed.pm +*** perl5.004_01.orig/lib/ExtUtils/Embed.pm Wed Apr 2 22:12:04 1997 +--- perl5.004_01/lib/ExtUtils/Embed.pm Sun Nov 12 22:12:35 2000 +*************** +*** 170,176 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 170,176 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_01.orig/lib/ExtUtils/Liblist.pm perl5.004_01/lib/ExtUtils/Liblist.pm +*** perl5.004_01.orig/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997 +--- perl5.004_01/lib/ExtUtils/Liblist.pm Sun Nov 12 22:13:27 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm perl5.004_01/lib/ExtUtils/MM_Unix.pm +*** perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997 +--- perl5.004_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:12:35 2000 +*************** +*** 2137,2143 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2137,2143 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_01.orig/myconfig perl5.004_01/myconfig +*** perl5.004_01.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_01/myconfig Sun Nov 12 22:12:35 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_01.orig/patchlevel.h perl5.004_01/patchlevel.h +*** perl5.004_01.orig/patchlevel.h Wed Jun 11 03:06:10 1997 +--- perl5.004_01/patchlevel.h Sun Nov 12 22:12:35 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/patches/5.004_02 b/db/perl/BerkeleyDB/patches/5.004_02 new file mode 100644 index 000000000..238f87379 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.004_02 @@ -0,0 +1,217 @@ +diff -rc perl5.004_02.orig/Configure perl5.004_02/Configure +*** perl5.004_02.orig/Configure Thu Aug 7 15:08:44 1997 +--- perl5.004_02/Configure Sun Nov 12 22:06:24 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_02.orig/Makefile.SH perl5.004_02/Makefile.SH +*** perl5.004_02.orig/Makefile.SH Thu Aug 7 13:10:53 1997 +--- perl5.004_02/Makefile.SH Sun Nov 12 22:06:24 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_02.orig/lib/ExtUtils/Embed.pm perl5.004_02/lib/ExtUtils/Embed.pm +*** perl5.004_02.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_02/lib/ExtUtils/Embed.pm Sun Nov 12 22:06:24 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_02.orig/lib/ExtUtils/Liblist.pm perl5.004_02/lib/ExtUtils/Liblist.pm +*** perl5.004_02.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_02/lib/ExtUtils/Liblist.pm Sun Nov 12 22:06:24 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm perl5.004_02/lib/ExtUtils/MM_Unix.pm +*** perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm Tue Aug 5 14:28:08 1997 +--- perl5.004_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:06:25 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_02.orig/myconfig perl5.004_02/myconfig +*** perl5.004_02.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_02/myconfig Sun Nov 12 22:06:25 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_02.orig/patchlevel.h perl5.004_02/patchlevel.h +*** perl5.004_02.orig/patchlevel.h Fri Aug 1 15:07:34 1997 +--- perl5.004_02/patchlevel.h Sun Nov 12 22:06:25 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/patches/5.004_03 b/db/perl/BerkeleyDB/patches/5.004_03 new file mode 100644 index 000000000..06331eac9 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.004_03 @@ -0,0 +1,223 @@ +diff -rc perl5.004_03.orig/Configure perl5.004_03/Configure +*** perl5.004_03.orig/Configure Wed Aug 13 16:09:46 1997 +--- perl5.004_03/Configure Sun Nov 12 21:56:18 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.004_03: Configure.orig +diff -rc perl5.004_03.orig/Makefile.SH perl5.004_03/Makefile.SH +*** perl5.004_03.orig/Makefile.SH Mon Aug 18 19:24:29 1997 +--- perl5.004_03/Makefile.SH Sun Nov 12 21:56:18 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.004_03: Makefile.SH.orig +diff -rc perl5.004_03.orig/lib/ExtUtils/Embed.pm perl5.004_03/lib/ExtUtils/Embed.pm +*** perl5.004_03.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_03/lib/ExtUtils/Embed.pm Sun Nov 12 21:56:18 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_03.orig/lib/ExtUtils/Liblist.pm perl5.004_03/lib/ExtUtils/Liblist.pm +*** perl5.004_03.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_03/lib/ExtUtils/Liblist.pm Sun Nov 12 21:57:17 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.orig +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.rej +diff -rc perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm perl5.004_03/lib/ExtUtils/MM_Unix.pm +*** perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm Mon Aug 18 19:16:12 1997 +--- perl5.004_03/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:56:19 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.004_03/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.004_03.orig/myconfig perl5.004_03/myconfig +*** perl5.004_03.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_03/myconfig Sun Nov 12 21:56:19 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_03.orig/patchlevel.h perl5.004_03/patchlevel.h +*** perl5.004_03.orig/patchlevel.h Wed Aug 13 11:42:01 1997 +--- perl5.004_03/patchlevel.h Sun Nov 12 21:56:19 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + +Only in perl5.004_03: patchlevel.h.orig diff --git a/db/perl/BerkeleyDB/patches/5.004_04 b/db/perl/BerkeleyDB/patches/5.004_04 new file mode 100644 index 000000000..a227dc700 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.004_04 @@ -0,0 +1,209 @@ +diff -rc perl5.004_04.orig/Configure perl5.004_04/Configure +*** perl5.004_04.orig/Configure Fri Oct 3 18:57:39 1997 +--- perl5.004_04/Configure Sun Nov 12 21:50:51 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9910,9915 **** +--- 9911,9924 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10378,10383 **** +--- 10387,10393 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_04.orig/Makefile.SH perl5.004_04/Makefile.SH +*** perl5.004_04.orig/Makefile.SH Wed Oct 15 10:33:16 1997 +--- perl5.004_04/Makefile.SH Sun Nov 12 21:50:51 2000 +*************** +*** 129,135 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 129,135 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_04.orig/lib/ExtUtils/Embed.pm perl5.004_04/lib/ExtUtils/Embed.pm +*** perl5.004_04.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_04/lib/ExtUtils/Embed.pm Sun Nov 12 21:50:51 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_04.orig/lib/ExtUtils/Liblist.pm perl5.004_04/lib/ExtUtils/Liblist.pm +*** perl5.004_04.orig/lib/ExtUtils/Liblist.pm Tue Sep 9 17:41:32 1997 +--- perl5.004_04/lib/ExtUtils/Liblist.pm Sun Nov 12 21:51:33 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 189,195 **** + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 189,195 ---- + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 539,545 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 539,545 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm perl5.004_04/lib/ExtUtils/MM_Unix.pm +*** perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm Wed Oct 8 14:13:51 1997 +--- perl5.004_04/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:50:51 2000 +*************** +*** 2229,2235 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2229,2235 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_04.orig/myconfig perl5.004_04/myconfig +*** perl5.004_04.orig/myconfig Mon Oct 6 18:26:49 1997 +--- perl5.004_04/myconfig Sun Nov 12 21:50:51 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_04.orig/patchlevel.h perl5.004_04/patchlevel.h +*** perl5.004_04.orig/patchlevel.h Wed Oct 15 10:55:19 1997 +--- perl5.004_04/patchlevel.h Sun Nov 12 21:50:51 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/patches/5.004_05 b/db/perl/BerkeleyDB/patches/5.004_05 new file mode 100644 index 000000000..51c8bf350 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.004_05 @@ -0,0 +1,209 @@ +diff -rc perl5.004_05.orig/Configure perl5.004_05/Configure +*** perl5.004_05.orig/Configure Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Configure Sun Nov 12 21:36:25 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 10164,10169 **** +--- 10165,10178 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10648,10653 **** +--- 10657,10663 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_05.orig/Makefile.SH perl5.004_05/Makefile.SH +*** perl5.004_05.orig/Makefile.SH Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Makefile.SH Sun Nov 12 21:36:25 2000 +*************** +*** 151,157 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 151,157 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_05.orig/lib/ExtUtils/Embed.pm perl5.004_05/lib/ExtUtils/Embed.pm +*** perl5.004_05.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_05/lib/ExtUtils/Embed.pm Sun Nov 12 21:36:25 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_05.orig/lib/ExtUtils/Liblist.pm perl5.004_05/lib/ExtUtils/Liblist.pm +*** perl5.004_05.orig/lib/ExtUtils/Liblist.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/Liblist.pm Sun Nov 12 21:45:31 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 590,596 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 590,596 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm perl5.004_05/lib/ExtUtils/MM_Unix.pm +*** perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:36:25 2000 +*************** +*** 2246,2252 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2246,2252 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_05.orig/myconfig perl5.004_05/myconfig +*** perl5.004_05.orig/myconfig Thu Jan 6 22:05:55 2000 +--- perl5.004_05/myconfig Sun Nov 12 21:43:54 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_05.orig/patchlevel.h perl5.004_05/patchlevel.h +*** perl5.004_05.orig/patchlevel.h Thu Jan 6 22:05:48 2000 +--- perl5.004_05/patchlevel.h Sun Nov 12 21:36:25 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/patches/5.005 b/db/perl/BerkeleyDB/patches/5.005 new file mode 100644 index 000000000..effee3e82 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.005 @@ -0,0 +1,209 @@ +diff -rc perl5.005.orig/Configure perl5.005/Configure +*** perl5.005.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005/Configure Sun Nov 12 21:30:40 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005.orig/Makefile.SH perl5.005/Makefile.SH +*** perl5.005.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005/Makefile.SH Sun Nov 12 21:30:40 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005.orig/lib/ExtUtils/Embed.pm perl5.005/lib/ExtUtils/Embed.pm +*** perl5.005.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005/lib/ExtUtils/Embed.pm Sun Nov 12 21:30:40 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005.orig/lib/ExtUtils/Liblist.pm perl5.005/lib/ExtUtils/Liblist.pm +*** perl5.005.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005/lib/ExtUtils/Liblist.pm Sun Nov 12 21:30:40 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005.orig/lib/ExtUtils/MM_Unix.pm perl5.005/lib/ExtUtils/MM_Unix.pm +*** perl5.005.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:30:41 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005.orig/myconfig perl5.005/myconfig +*** perl5.005.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005/myconfig Sun Nov 12 21:30:41 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005.orig/patchlevel.h perl5.005/patchlevel.h +*** perl5.005.orig/patchlevel.h Wed Jul 22 19:22:01 1998 +--- perl5.005/patchlevel.h Sun Nov 12 21:30:41 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/patches/5.005_01 b/db/perl/BerkeleyDB/patches/5.005_01 new file mode 100644 index 000000000..2a05dd545 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.005_01 @@ -0,0 +1,209 @@ +diff -rc perl5.005_01.orig/Configure perl5.005_01/Configure +*** perl5.005_01.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005_01/Configure Sun Nov 12 20:55:58 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_01.orig/Makefile.SH perl5.005_01/Makefile.SH +*** perl5.005_01.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_01/Makefile.SH Sun Nov 12 20:55:58 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_01.orig/lib/ExtUtils/Embed.pm perl5.005_01/lib/ExtUtils/Embed.pm +*** perl5.005_01.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_01/lib/ExtUtils/Embed.pm Sun Nov 12 20:55:58 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_01.orig/lib/ExtUtils/Liblist.pm perl5.005_01/lib/ExtUtils/Liblist.pm +*** perl5.005_01.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005_01/lib/ExtUtils/Liblist.pm Sun Nov 12 20:55:58 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm perl5.005_01/lib/ExtUtils/MM_Unix.pm +*** perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:55:58 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005_01.orig/myconfig perl5.005_01/myconfig +*** perl5.005_01.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_01/myconfig Sun Nov 12 20:55:58 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_01.orig/patchlevel.h perl5.005_01/patchlevel.h +*** perl5.005_01.orig/patchlevel.h Mon Jan 3 11:07:45 2000 +--- perl5.005_01/patchlevel.h Sun Nov 12 20:55:58 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/patches/5.005_02 b/db/perl/BerkeleyDB/patches/5.005_02 new file mode 100644 index 000000000..5dd57ddc0 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.005_02 @@ -0,0 +1,264 @@ +diff -rc perl5.005_02.orig/Configure perl5.005_02/Configure +*** perl5.005_02.orig/Configure Mon Jan 3 11:12:20 2000 +--- perl5.005_02/Configure Sun Nov 12 20:50:51 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11334,11339 **** +--- 11335,11348 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11859,11864 **** +--- 11868,11874 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.005_02: Configure.orig +diff -rc perl5.005_02.orig/Makefile.SH perl5.005_02/Makefile.SH +*** perl5.005_02.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_02/Makefile.SH Sun Nov 12 20:50:51 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.005_02: Makefile.SH.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/Embed.pm perl5.005_02/lib/ExtUtils/Embed.pm +*** perl5.005_02.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_02/lib/ExtUtils/Embed.pm Sun Nov 12 20:50:51 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_02.orig/lib/ExtUtils/Liblist.pm perl5.005_02/lib/ExtUtils/Liblist.pm +*** perl5.005_02.orig/lib/ExtUtils/Liblist.pm Mon Jan 3 11:12:21 2000 +--- perl5.005_02/lib/ExtUtils/Liblist.pm Sun Nov 12 20:50:51 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 333,339 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 333,339 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 623,629 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 623,629 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +*************** +*** 666,672 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 666,672 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 676,682 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 676,682 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +Only in perl5.005_02/lib/ExtUtils: Liblist.pm.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm perl5.005_02/lib/ExtUtils/MM_Unix.pm +*** perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:50:51 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.005_02/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.005_02.orig/myconfig perl5.005_02/myconfig +*** perl5.005_02.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_02/myconfig Sun Nov 12 20:50:51 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_02.orig/patchlevel.h perl5.005_02/patchlevel.h +*** perl5.005_02.orig/patchlevel.h Mon Jan 3 11:12:19 2000 +--- perl5.005_02/patchlevel.h Sun Nov 12 20:50:51 2000 +*************** +*** 40,45 **** +--- 40,46 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/patches/5.005_03 b/db/perl/BerkeleyDB/patches/5.005_03 new file mode 100644 index 000000000..115f9f5b9 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.005_03 @@ -0,0 +1,250 @@ +diff -rc perl5.005_03.orig/Configure perl5.005_03/Configure +*** perl5.005_03.orig/Configure Sun Mar 28 17:12:57 1999 +--- perl5.005_03/Configure Sun Sep 17 22:19:16 2000 +*************** +*** 208,213 **** +--- 208,214 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11642,11647 **** +--- 11643,11656 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 12183,12188 **** +--- 12192,12198 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_03.orig/Makefile.SH perl5.005_03/Makefile.SH +*** perl5.005_03.orig/Makefile.SH Thu Mar 4 02:35:25 1999 +--- perl5.005_03/Makefile.SH Sun Sep 17 22:21:01 2000 +*************** +*** 58,67 **** + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +--- 58,67 ---- + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $perllibs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $perllibs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +*************** +*** 155,161 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 155,161 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_03.orig/lib/ExtUtils/Embed.pm perl5.005_03/lib/ExtUtils/Embed.pm +*** perl5.005_03.orig/lib/ExtUtils/Embed.pm Wed Jan 6 02:17:50 1999 +--- perl5.005_03/lib/ExtUtils/Embed.pm Sun Sep 17 22:19:16 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_03.orig/lib/ExtUtils/Liblist.pm perl5.005_03/lib/ExtUtils/Liblist.pm +*** perl5.005_03.orig/lib/ExtUtils/Liblist.pm Wed Jan 6 02:17:47 1999 +--- perl5.005_03/lib/ExtUtils/Liblist.pm Sun Sep 17 22:19:16 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 336,342 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 336,342 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 626,632 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 626,632 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 670,676 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 670,676 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 680,686 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 680,686 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -rc perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm perl5.005_03/lib/ExtUtils/MM_Unix.pm +*** perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm Fri Mar 5 00:34:20 1999 +--- perl5.005_03/lib/ExtUtils/MM_Unix.pm Sun Sep 17 22:19:16 2000 +*************** +*** 2284,2290 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2284,2290 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { diff --git a/db/perl/BerkeleyDB/patches/5.6.0 b/db/perl/BerkeleyDB/patches/5.6.0 new file mode 100644 index 000000000..1f9b3b620 --- /dev/null +++ b/db/perl/BerkeleyDB/patches/5.6.0 @@ -0,0 +1,294 @@ +diff -cr perl-5.6.0.orig/Configure perl-5.6.0/Configure +*** perl-5.6.0.orig/Configure Wed Mar 22 20:36:37 2000 +--- perl-5.6.0/Configure Sun Sep 17 23:40:15 2000 +*************** +*** 217,222 **** +--- 217,223 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 14971,14976 **** +--- 14972,14985 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 15640,15645 **** +--- 15649,15655 ---- + path_sep='$path_sep' + perl5='$perl5' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -cr perl-5.6.0.orig/Makefile.SH perl-5.6.0/Makefile.SH +*** perl-5.6.0.orig/Makefile.SH Sat Mar 11 16:05:24 2000 +--- perl-5.6.0/Makefile.SH Sun Sep 17 23:40:15 2000 +*************** +*** 70,76 **** + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $libs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +--- 70,76 ---- + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +*************** +*** 176,182 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 176,182 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +*************** +*** 333,339 **** + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $libs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +--- 333,339 ---- + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $perllibs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +diff -cr perl-5.6.0.orig/lib/ExtUtils/Embed.pm perl-5.6.0/lib/ExtUtils/Embed.pm +*** perl-5.6.0.orig/lib/ExtUtils/Embed.pm Sun Jan 23 12:08:32 2000 +--- perl-5.6.0/lib/ExtUtils/Embed.pm Sun Sep 17 23:40:15 2000 +*************** +*** 193,199 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 193,199 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -cr perl-5.6.0.orig/lib/ExtUtils/Liblist.pm perl-5.6.0/lib/ExtUtils/Liblist.pm +*** perl-5.6.0.orig/lib/ExtUtils/Liblist.pm Wed Mar 22 16:16:31 2000 +--- perl-5.6.0/lib/ExtUtils/Liblist.pm Sun Sep 17 23:40:15 2000 +*************** +*** 17,34 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 17,34 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 198,204 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 198,204 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 338,344 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 338,344 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 624,630 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 624,630 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 668,674 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 668,674 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 678,684 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 678,684 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -cr perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm perl-5.6.0/lib/ExtUtils/MM_Unix.pm +*** perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm Thu Mar 2 17:52:52 2000 +--- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Sun Sep 17 23:40:15 2000 +*************** +*** 2450,2456 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2450,2456 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -cr perl-5.6.0.orig/myconfig.SH perl-5.6.0/myconfig.SH +*** perl-5.6.0.orig/myconfig.SH Sat Feb 26 06:34:49 2000 +--- perl-5.6.0/myconfig.SH Sun Sep 17 23:41:17 2000 +*************** +*** 48,54 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 48,54 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -cr perl-5.6.0.orig/patchlevel.h perl-5.6.0/patchlevel.h +*** perl-5.6.0.orig/patchlevel.h Wed Mar 22 20:23:11 2000 +--- perl-5.6.0/patchlevel.h Sun Sep 17 23:40:15 2000 +*************** +*** 70,75 **** +--- 70,76 ---- + #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/db/perl/BerkeleyDB/t/btree.t b/db/perl/BerkeleyDB/t/btree.t new file mode 100644 index 000000000..c85271d99 --- /dev/null +++ b/db/perl/BerkeleyDB/t/btree.t @@ -0,0 +1,925 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..243\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Btree -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Btree -Txn => "x" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Btree -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to Btree + +{ + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put("some key", "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get("some key", $value) == 0 ; + ok 10, $value eq "some value" ; + ok 11, $db->db_put("key", "value") == 0 ; + ok 12, $db->db_get("key", $value) == 0 ; + ok 13, $value eq "value" ; + ok 14, $db->db_del("some key") == 0 ; + ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ; + ok 16, $db->status() == DB_NOTFOUND ; + ok 17, $db->status() eq $DB_errors{'DB_NOTFOUND'} ; + + ok 18, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 19, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 20, $db->status() eq $DB_errors{'DB_KEYEXIST'} ; + ok 21, $db->status() == DB_KEYEXIST ; + + + # check that the value of the key has not been changed by the + # previous test + ok 22, $db->db_get("key", $value) == 0 ; + ok 23, $value eq "value" ; + + # test DB_GET_BOTH + my ($k, $v) = ("key", "value") ; + ok 24, $db->db_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("key", "fred") ; + ok 25, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("another", "value") ; + ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + +} + +{ + # Check simple env works with a hash. + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + ok 27, my $lexD = new LexDir($home) ; + + ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL, + -Home => $home ; + ok 29, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + ok 30, $db->db_put("some key", "some value") == 0 ; + ok 31, $db->db_get("some key", $value) == 0 ; + ok 32, $value eq "some value" ; + undef $db ; + undef $env ; +} + + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my %hash ; + my ($k, $v) ; + ok 33, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => 2, + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 34, $ret == 0 ; + + # create the cursor + ok 35, my $cursor = $db->db_cursor() ; + + $k = $v = "" ; + my %copy = %data ; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 36, $cursor->status() == DB_NOTFOUND ; + ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'}; + ok 38, keys %copy == 0 ; + ok 39, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 40, $status == DB_NOTFOUND ; + ok 41, $status eq $DB_errors{'DB_NOTFOUND'}; + ok 42, $cursor->status() == $status ; + ok 43, $cursor->status() eq $status ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; + + ($k, $v) = ("green", "house") ; + ok 46, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("green", "door") ; + ok 47, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("black", "house") ; + ok 48, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + +} + +{ + # Tied Hash interface + + my $lex = new LexFile $Dfile ; + my %hash ; + ok 49, tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # check "each" with an empty database + my $count = 0 ; + while (my ($k, $v) = each %hash) { + ++ $count ; + } + ok 50, (tied %hash)->status() == DB_NOTFOUND ; + ok 51, $count == 0 ; + + # Add a k/v pair + my $value ; + $hash{"some key"} = "some value"; + ok 52, (tied %hash)->status() == 0 ; + ok 53, $hash{"some key"} eq "some value"; + ok 54, defined $hash{"some key"} ; + ok 55, (tied %hash)->status() == 0 ; + ok 56, exists $hash{"some key"} ; + ok 57, !defined $hash{"jimmy"} ; + ok 58, (tied %hash)->status() == DB_NOTFOUND ; + ok 59, !exists $hash{"jimmy"} ; + ok 60, (tied %hash)->status() == DB_NOTFOUND ; + + delete $hash{"some key"} ; + ok 61, (tied %hash)->status() == 0 ; + ok 62, ! defined $hash{"some key"} ; + ok 63, (tied %hash)->status() == DB_NOTFOUND ; + ok 64, ! exists $hash{"some key"} ; + ok 65, (tied %hash)->status() == DB_NOTFOUND ; + + $hash{1} = 2 ; + $hash{10} = 20 ; + $hash{1000} = 2000 ; + + my ($keys, $values) = (0,0); + $count = 0 ; + while (my ($k, $v) = each %hash) { + $keys += $k ; + $values += $v ; + ++ $count ; + } + ok 66, $count == 3 ; + ok 67, $keys == 1011 ; + ok 68, $values == 2022 ; + + # now clear the hash + %hash = () ; + ok 69, keys %hash == 0 ; + + untie %hash ; +} + +{ + # override default compare + my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ; + my $value ; + my (%h, %g, %k) ; + my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; + ok 70, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, + -Compare => sub { $_[0] <=> $_[1] }, + -Flags => DB_CREATE ; + + ok 71, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, + -Compare => sub { $_[0] cmp $_[1] }, + -Flags => DB_CREATE ; + + ok 72, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, + -Compare => sub { length $_[0] <=> length $_[1] }, + -Flags => DB_CREATE ; + + my @srt_1 ; + { local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; + } + my @srt_2 = sort { $a cmp $b } @Keys ; + my @srt_3 = sort { length $a <=> length $b } @Keys ; + + foreach (@Keys) { + local $^W = 0 ; + $h{$_} = 1 ; + $g{$_} = 1 ; + $k{$_} = 1 ; + } + + sub ArrayCompare + { + my($a, $b) = @_ ; + + return 0 if @$a != @$b ; + + foreach (1 .. length @$a) + { + return 0 unless $$a[$_] eq $$b[$_] ; + } + + 1 ; + } + + ok 73, ArrayCompare (\@srt_1, [keys %h]); + ok 74, ArrayCompare (\@srt_2, [keys %g]); + ok 75, ArrayCompare (\@srt_3, [keys %k]); + +} + +{ + # override default compare, with duplicates, don't sort values + my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ; + my $value ; + my (%h, %g, %k) ; + my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ; + my @Values = qw( 1 0 3 dd x abc 0 ) ; + ok 76, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, + -Compare => sub { $_[0] <=> $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + ok 77, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, + -Compare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + ok 78, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3, + -Compare => sub { length $_[0] <=> length $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + my @srt_1 ; + { local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; + } + my @srt_2 = sort { $a cmp $b } @Keys ; + my @srt_3 = sort { length $a <=> length $b } @Keys ; + + foreach (@Keys) { + local $^W = 0 ; + my $value = shift @Values ; + $h{$_} = $value ; + $g{$_} = $value ; + $k{$_} = $value ; + } + + sub getValues + { + my $hash = shift ; + my $db = tied %$hash ; + my $cursor = $db->db_cursor() ; + my @values = () ; + my ($k, $v) = (0,0) ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + push @values, $v ; + } + return @values ; + } + + ok 79, ArrayCompare (\@srt_1, [keys %h]); + ok 80, ArrayCompare (\@srt_2, [keys %g]); + ok 81, ArrayCompare (\@srt_3, [keys %k]); + ok 82, ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]); + ok 83, ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]); + ok 84, ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]); + + # test DB_DUP_NEXT + ok 85, my $cur = (tied %g)->db_cursor() ; + my ($k, $v) = (9, "") ; + ok 86, $cur->c_get($k, $v, DB_SET) == 0 ; + ok 87, $k == 9 && $v == 0 ; + ok 88, $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ; + ok 89, $k == 9 && $v eq "x" ; + ok 90, $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ; +} + +{ + # override default compare, with duplicates, sort values + my $lex = new LexFile $Dfile, $Dfile2; + my $value ; + my (%h, %g) ; + my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ; + my @Values = qw( 1 11 3 dd x abc 2 0 ) ; + ok 91, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile, + -Compare => sub { $_[0] <=> $_[1] }, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + ok 92, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2, + -Compare => sub { $_[0] cmp $_[1] }, + -DupCompare => sub { $_[0] <=> $_[1] }, + -Property => DB_DUP, + + + + -Flags => DB_CREATE ; + + my @srt_1 ; + { local $^W = 0 ; + @srt_1 = sort { $a <=> $b } @Keys ; + } + my @srt_2 = sort { $a cmp $b } @Keys ; + + foreach (@Keys) { + local $^W = 0 ; + my $value = shift @Values ; + $h{$_} = $value ; + $g{$_} = $value ; + } + + ok 93, ArrayCompare (\@srt_1, [keys %h]); + ok 94, ArrayCompare (\@srt_2, [keys %g]); + ok 95, ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]); + ok 96, ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]); + +} + +{ + # get_dup etc + my $lex = new LexFile $Dfile; + my %hh ; + + ok 97, my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP, + -Flags => DB_CREATE ; + + $hh{'Wall'} = 'Larry' ; + $hh{'Wall'} = 'Stone' ; # Note the duplicate key + $hh{'Wall'} = 'Brick' ; # Note the duplicate key + $hh{'Smith'} = 'John' ; + $hh{'mouse'} = 'mickey' ; + + # first work in scalar context + ok 98, scalar $YY->get_dup('Unknown') == 0 ; + ok 99, scalar $YY->get_dup('Smith') == 1 ; + ok 100, scalar $YY->get_dup('Wall') == 3 ; + + # now in list context + my @unknown = $YY->get_dup('Unknown') ; + ok 101, "@unknown" eq "" ; + + my @smith = $YY->get_dup('Smith') ; + ok 102, "@smith" eq "John" ; + + { + my @wall = $YY->get_dup('Wall') ; + my %wall ; + @wall{@wall} = @wall ; + ok 103, (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}); + } + + # hash + my %unknown = $YY->get_dup('Unknown', 1) ; + ok 104, keys %unknown == 0 ; + + my %smith = $YY->get_dup('Smith', 1) ; + ok 105, keys %smith == 1 && $smith{'John'} ; + + my %wall = $YY->get_dup('Wall', 1) ; + ok 106, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 + && $wall{'Brick'} == 1 ; + + undef $YY ; + untie %hh ; + +} + +{ + # in-memory file + + my $lex = new LexFile $Dfile ; + my %hash ; + my $fd ; + my $value ; + ok 107, my $db = tie %hash, 'BerkeleyDB::Btree' ; + + ok 108, $db->db_put("some key", "some value") == 0 ; + ok 109, $db->db_get("some key", $value) == 0 ; + ok 110, $value eq "some value" ; + +} + +{ + # partial + # check works via API + + my $lex = new LexFile $Dfile ; + my $value ; + ok 111, my $db = new BerkeleyDB::Btree, -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 112, $ret == 0 ; + + + # do a partial get + my ($pon, $off, $len) = $db->partial_set(0,2) ; + ok 113, ! $pon && $off == 0 && $len == 0 ; + ok 114, $db->db_get("red", $value) == 0 && $value eq "bo" ; + ok 115, $db->db_get("green", $value) == 0 && $value eq "ho" ; + ok 116, $db->db_get("blue", $value) == 0 && $value eq "se" ; + + # do a partial get, off end of data + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 117, $pon ; + ok 118, $off == 0 ; + ok 119, $len == 2 ; + ok 120, $db->db_get("red", $value) == 0 && $value eq "t" ; + ok 121, $db->db_get("green", $value) == 0 && $value eq "se" ; + ok 122, $db->db_get("blue", $value) == 0 && $value eq "" ; + + # switch of partial mode + ($pon, $off, $len) = $db->partial_clear() ; + ok 123, $pon ; + ok 124, $off == 3 ; + ok 125, $len == 2 ; + ok 126, $db->db_get("red", $value) == 0 && $value eq "boat" ; + ok 127, $db->db_get("green", $value) == 0 && $value eq "house" ; + ok 128, $db->db_get("blue", $value) == 0 && $value eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 129, $db->db_put("red", "") == 0 ; + ok 130, $db->db_put("green", "AB") == 0 ; + ok 131, $db->db_put("blue", "XYZ") == 0 ; + ok 132, $db->db_put("new", "KLM") == 0 ; + + ($pon, $off, $len) = $db->partial_clear() ; + ok 133, $pon ; + ok 134, $off == 0 ; + ok 135, $len == 2 ; + ok 136, $db->db_get("red", $value) == 0 && $value eq "at" ; + ok 137, $db->db_get("green", $value) == 0 && $value eq "ABuse" ; + ok 138, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ; + ok 139, $db->db_get("new", $value) == 0 && $value eq "KLM" ; + + # now partial put + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 140, ! $pon ; + ok 141, $off == 0 ; + ok 142, $len == 0 ; + ok 143, $db->db_put("red", "PPP") == 0 ; + ok 144, $db->db_put("green", "Q") == 0 ; + ok 145, $db->db_put("blue", "XYZ") == 0 ; + ok 146, $db->db_put("new", "TU") == 0 ; + + $db->partial_clear() ; + ok 147, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ; + ok 148, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ; + ok 149, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ; + ok 150, $db->db_get("new", $value) == 0 && $value eq "KLMTU" ; +} + +{ + # partial + # check works via tied hash + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + ok 151, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + while (my ($k, $v) = each %data) { + $hash{$k} = $v ; + } + + + # do a partial get + $db->partial_set(0,2) ; + ok 152, $hash{"red"} eq "bo" ; + ok 153, $hash{"green"} eq "ho" ; + ok 154, $hash{"blue"} eq "se" ; + + # do a partial get, off end of data + $db->partial_set(3,2) ; + ok 155, $hash{"red"} eq "t" ; + ok 156, $hash{"green"} eq "se" ; + ok 157, $hash{"blue"} eq "" ; + + # switch of partial mode + $db->partial_clear() ; + ok 158, $hash{"red"} eq "boat" ; + ok 159, $hash{"green"} eq "house" ; + ok 160, $hash{"blue"} eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 161, $hash{"red"} = "" ; + ok 162, $hash{"green"} = "AB" ; + ok 163, $hash{"blue"} = "XYZ" ; + ok 164, $hash{"new"} = "KLM" ; + + $db->partial_clear() ; + ok 165, $hash{"red"} eq "at" ; + ok 166, $hash{"green"} eq "ABuse" ; + ok 167, $hash{"blue"} eq "XYZa" ; + ok 168, $hash{"new"} eq "KLM" ; + + # now partial put + $db->partial_set(3,2) ; + ok 169, $hash{"red"} = "PPP" ; + ok 170, $hash{"green"} = "Q" ; + ok 171, $hash{"blue"} = "XYZ" ; + ok 172, $hash{"new"} = "TU" ; + + $db->partial_clear() ; + ok 173, $hash{"red"} eq "at\0PPP" ; + ok 174, $hash{"green"} eq "ABuQ" ; + ok 175, $hash{"blue"} eq "XYZXYZ" ; + ok 176, $hash{"new"} eq "KLMTU" ; +} + +{ + # transaction + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 177, my $lexD = new LexDir($home) ; + ok 178, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 179, my $txn = $env->txn_begin() ; + ok 180, my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + # 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 ; +} + +{ + # 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/db/perl/BerkeleyDB/t/db-3.0.t b/db/perl/BerkeleyDB/t/db-3.0.t new file mode 100644 index 000000000..971a5e830 --- /dev/null +++ b/db/perl/BerkeleyDB/t/db-3.0.t @@ -0,0 +1,89 @@ +#!./perl -w + +# ID: 1.2, 7/17/97 + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +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"; + + +my $Dfile = "dbhash.tmp"; + +umask(0); + +{ + # set_mutexlocks + + my $home = "./fred" ; + ok 1, my $lexD = new LexDir($home) ; + chdir "./fred" ; + ok 2, my $env = new BerkeleyDB::Env -Flags => DB_CREATE ; + ok 3, $env->set_mutexlocks(0) == 0 ; + chdir ".." ; + undef $env ; +} + +{ + # 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/db/perl/BerkeleyDB/t/db-3.1.t b/db/perl/BerkeleyDB/t/db-3.1.t new file mode 100644 index 000000000..d01681e54 --- /dev/null +++ b/db/perl/BerkeleyDB/t/db-3.1.t @@ -0,0 +1,123 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3.1) { + print "1..0 # Skipping test, this needs Berkeley DB 3.1.x or better\n" ; + exit 0 ; + } +} + +print "1..25\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/db/perl/BerkeleyDB/t/db-3.2.t b/db/perl/BerkeleyDB/t/db-3.2.t new file mode 100644 index 000000000..1f7ad1504 --- /dev/null +++ b/db/perl/BerkeleyDB/t/db-3.2.t @@ -0,0 +1,42 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3.2) { + print "1..0 # Skipping test, this needs Berkeley DB 3.2.x or better\n" ; + exit 0 ; + } +} + +print "1..1\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/db/perl/BerkeleyDB/t/destroy.t b/db/perl/BerkeleyDB/t/destroy.t new file mode 100644 index 000000000..c060bc744 --- /dev/null +++ b/db/perl/BerkeleyDB/t/destroy.t @@ -0,0 +1,101 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..13\n"; + +my $Dfile = "dbhash.tmp"; +my $home = "./fred" ; + +umask(0); + +{ + # let object destroction kill everything + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + ok 1, my $lexD = new LexDir($home) ; + ok 2, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 3, my $txn = $env->txn_begin() ; + ok 4, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + # 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 ; +} + + diff --git a/db/perl/BerkeleyDB/t/env.t b/db/perl/BerkeleyDB/t/env.t new file mode 100644 index 000000000..d6ddc9860 --- /dev/null +++ b/db/perl/BerkeleyDB/t/env.t @@ -0,0 +1,233 @@ +#!./perl -w + +# ID: 1.2, 7/17/97 + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..52\n"; + +my $Dfile = "dbhash.tmp"; + +umask(0); + +{ + # db version stuff + my ($major, $minor, $patch) = (0, 0, 0) ; + + ok 1, my $VER = BerkeleyDB::DB_VERSION_STRING ; + ok 2, my $ver = BerkeleyDB::db_version($major, $minor, $patch) ; + ok 3, $VER eq $ver ; + ok 4, $major > 1 ; + ok 5, defined $minor ; + ok 6, defined $patch ; +} + +{ + # Check for invalid parameters + my $env ; + eval ' $env = new BerkeleyDB::Env( -Stupid => 3) ; ' ; + ok 7, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $env = new BerkeleyDB::Env( -Bad => 2, -Home => "/tmp", -Stupid => 3) ; ' ; + ok 8, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $env = new BerkeleyDB::Env (-Config => {"fred" => " "} ) ; ' ; + ok 9, !$env ; + ok 10, $BerkeleyDB::Error =~ /^illegal name-value pair/ ; +} + +{ + # create a very simple environment + my $home = "./fred" ; + ok 11, my $lexD = new LexDir($home) ; + chdir "./fred" ; + ok 12, my $env = new BerkeleyDB::Env -Flags => DB_CREATE ; + chdir ".." ; + undef $env ; +} + +{ + # create an environment with a Home + my $home = "./fred" ; + ok 13, my $lexD = new LexDir($home) ; + ok 14, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE ; + + undef $env ; +} + +{ + # make new fail. + my $home = "./not_there" ; + rmtree $home ; + ok 15, ! -d $home ; + my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_INIT_LOCK ; + ok 16, ! $env ; + ok 17, $! != 0 ; + + rmtree $home ; +} + +{ + # Config + use Cwd ; + my $cwd = cwd() ; + my $home = "$cwd/fred" ; + my $data_dir = "$home/data_dir" ; + my $log_dir = "$home/log_dir" ; + my $data_file = "data.db" ; + ok 18, my $lexD = new LexDir($home) ; + ok 19, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ; + ok 20, -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ; + my $env = new BerkeleyDB::Env -Home => $home, + -Config => { DB_DATA_DIR => $data_dir, + DB_LOG_DIR => $log_dir + }, + -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 21, $env ; + + ok 22, my $txn = $env->txn_begin() ; + + my %hash ; + ok 23, tie %hash, 'BerkeleyDB::Hash', -Filename => $data_file, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + $hash{"abc"} = 123 ; + $hash{"def"} = 456 ; + + $txn->txn_commit() ; + + untie %hash ; + + undef $txn ; + undef $env ; +} + +{ + # -ErrFile with a filename + my $errfile = "./errfile" ; + my $home = "./fred" ; + ok 24, my $lexD = new LexDir($home) ; + my $lex = new LexFile $errfile ; + ok 25, my $env = new BerkeleyDB::Env( -ErrFile => $errfile, + -Flags => DB_CREATE, + -Home => $home) ; + my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Env => $env, + -Flags => -1; + ok 26, !$db ; + + ok 27, $BerkeleyDB::Error =~ /^illegal flag specified to (db_open|DB->open)/; + ok 28, -e $errfile ; + my $contents = docat($errfile) ; + chomp $contents ; + ok 29, $BerkeleyDB::Error eq $contents ; + + undef $env ; +} + +{ + # -ErrFile with a filehandle + use IO ; + my $home = "./fred" ; + ok 30, my $lexD = new LexDir($home) ; + 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 ; +} + +{ + # -ErrPrefix + use IO ; + my $home = "./fred" ; + ok 37, my $lexD = new LexDir($home) ; + 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 ; +} + +{ + # 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, my $lexD = new LexDir($home); + 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 ; + +} + +# test -Verbose +# test -Flags +# db_value_set diff --git a/db/perl/BerkeleyDB/t/examples.t b/db/perl/BerkeleyDB/t/examples.t new file mode 100644 index 000000000..4cd7b79fc --- /dev/null +++ b/db/perl/BerkeleyDB/t/examples.t @@ -0,0 +1,412 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..7\n"; + +my $FA = 0 ; + +{ + sub try::TIEARRAY { bless [], "try" } + sub try::FETCHSIZE { $FA = 1 } + $FA = 0 ; + my @a ; + tie @a, 'try' ; + my $a = @a ; +} + +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/db/perl/BerkeleyDB/t/examples.t.T b/db/perl/BerkeleyDB/t/examples.t.T new file mode 100644 index 000000000..fe0922318 --- /dev/null +++ b/db/perl/BerkeleyDB/t/examples.t.T @@ -0,0 +1,496 @@ +#!./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/db/perl/BerkeleyDB/t/examples3.t b/db/perl/BerkeleyDB/t/examples3.t new file mode 100644 index 000000000..72b68eb38 --- /dev/null +++ b/db/perl/BerkeleyDB/t/examples3.t @@ -0,0 +1,132 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3) { + print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ; + exit 0 ; + } +} + + +print "1..2\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +my $redirect = "xyzt" ; + + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(1, docat_del($redirect) eq <<'EOM') ; +orange -> orange +yellow -> banana +red -> apple +red -> tomato +green -> banana +green -> apple +EOM + +} + +{ +my $redirect = "xyzt" ; + { + + my $redirectObj = new Redirect $redirect ; + + use strict ; + use BerkeleyDB ; + + my $filename = "fruit" ; + unlink $filename ; + my $db = new BerkeleyDB::Hash + -Filename => $filename, + -Flags => DB_CREATE, + -Property => DB_DUP | DB_DUPSORT + or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; + + # Add a few key/value pairs to the file + $db->db_put("red", "apple") ; + $db->db_put("orange", "orange") ; + $db->db_put("green", "banana") ; + $db->db_put("yellow", "banana") ; + $db->db_put("red", "tomato") ; + $db->db_put("green", "apple") ; + + # print the contents of the file + my ($k, $v) = ("", "") ; + my $cursor = $db->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { print "$k -> $v\n" } + + undef $cursor ; + undef $db ; + unlink $filename ; + } + + #print "[" . docat($redirect) . "]" ; + ok(2, docat_del($redirect) eq <<'EOM') ; +orange -> orange +yellow -> banana +red -> apple +red -> tomato +green -> apple +green -> banana +EOM + +} + + diff --git a/db/perl/BerkeleyDB/t/examples3.t.T b/db/perl/BerkeleyDB/t/examples3.t.T new file mode 100644 index 000000000..573c04903 --- /dev/null +++ b/db/perl/BerkeleyDB/t/examples3.t.T @@ -0,0 +1,217 @@ +#!./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/db/perl/BerkeleyDB/t/filter.t b/db/perl/BerkeleyDB/t/filter.t new file mode 100644 index 000000000..47a7c107a --- /dev/null +++ b/db/perl/BerkeleyDB/t/filter.t @@ -0,0 +1,217 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..46\n"; + +my $Dfile = "dbhash.tmp"; +unlink $Dfile; + +umask(0) ; + + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok 1, $db = tie %h, 'BerkeleyDB::Hash', + -Filename => $Dfile, + -Flags => DB_CREATE; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok 2, checkOutput( "", "fred", "", "joe") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 3, $h{"fred"} eq "joe"; + # fk sk fv sv + ok 4, checkOutput( "", "fred", "joe", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 5, $db->FIRSTKEY() eq "fred" ; + # fk sk fv sv + ok 6, checkOutput( "fred", "", "", "") ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok 7, checkOutput( "", "fred", "", "Jxe") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 8, $h{"Fred"} eq "[Jxe]"; + # fk sk fv sv + ok 9, checkOutput( "", "fred", "[Jxe]", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 10, $db->FIRSTKEY() eq "FRED" ; + # fk sk fv sv + ok 11, checkOutput( "FRED", "", "", "") ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok 12, checkOutput( "", "fred", "", "joe") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 13, $h{"fred"} eq "joe"; + ok 14, checkOutput( "", "fred", "joe", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 15, $db->FIRSTKEY() eq "fred" ; + ok 16, checkOutput( "fred", "", "", "") ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok 17, checkOutput( "", "", "", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 18, $h{"fred"} eq "joe"; + ok 19, checkOutput( "", "", "", "") ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok 20, $db->FIRSTKEY() eq "fred" ; + ok 21, checkOutput( "", "", "", "") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok 22, $db = tie %h, 'BerkeleyDB::Hash', + -Filename => $Dfile, + -Flags => DB_CREATE; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok 23, $result{"store key"} eq "store key - 1: [fred]" ; + ok 24, $result{"store value"} eq "store value - 1: [joe]" ; + ok 25, ! defined $result{"fetch key"} ; + ok 26, ! defined $result{"fetch value"} ; + ok 27, $_ eq "original" ; + + ok 28, $db->FIRSTKEY() eq "fred" ; + ok 29, $result{"store key"} eq "store key - 1: [fred]" ; + ok 30, $result{"store value"} eq "store value - 1: [joe]" ; + ok 31, $result{"fetch key"} eq "fetch key - 1: [fred]" ; + ok 32, ! defined $result{"fetch value"} ; + ok 33, $_ eq "original" ; + + $h{"jim"} = "john" ; + ok 34, $result{"store key"} eq "store key - 2: [fred jim]" ; + ok 35, $result{"store value"} eq "store value - 2: [joe john]" ; + ok 36, $result{"fetch key"} eq "fetch key - 1: [fred]" ; + ok 37, ! defined $result{"fetch value"} ; + ok 38, $_ eq "original" ; + + ok 39, $h{"fred"} eq "joe" ; + ok 40, $result{"store key"} eq "store key - 3: [fred jim fred]" ; + ok 41, $result{"store value"} eq "store value - 2: [joe john]" ; + ok 42, $result{"fetch key"} eq "fetch key - 1: [fred]" ; + ok 43, $result{"fetch value"} eq "fetch value - 1: [joe]" ; + ok 44, $_ eq "original" ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok 45, $db = tie %h, 'BerkeleyDB::Hash', + -Filename => $Dfile, + -Flags => DB_CREATE; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok 46, $@ =~ /^BerkeleyDB Aborting: recursion detected in filter_store_key at/ ; + #print "[$@]\n" ; + + undef $db ; + untie %h; + unlink $Dfile; +} + diff --git a/db/perl/BerkeleyDB/t/hash.t b/db/perl/BerkeleyDB/t/hash.t new file mode 100644 index 000000000..661de1763 --- /dev/null +++ b/db/perl/BerkeleyDB/t/hash.t @@ -0,0 +1,725 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..210\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Hash -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Hash -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $db = new BerkeleyDB::Hash -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Hash -Txn => "fred" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Hash -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to HASH + +{ + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put("some key", "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get("some key", $value) == 0 ; + ok 10, $value eq "some value" ; + ok 11, $db->db_put("key", "value") == 0 ; + ok 12, $db->db_get("key", $value) == 0 ; + ok 13, $value eq "value" ; + ok 14, $db->db_del("some key") == 0 ; + ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ; + ok 16, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 17, $db->status() == DB_NOTFOUND ; + ok 18, $db->status() eq $DB_errors{'DB_NOTFOUND'}; + + ok 19, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 20, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 21, $db->status() eq $DB_errors{'DB_KEYEXIST'}; + ok 22, $db->status() == DB_KEYEXIST ; + + # check that the value of the key has not been changed by the + # previous test + ok 23, $db->db_get("key", $value) == 0 ; + ok 24, $value eq "value" ; + + # test DB_GET_BOTH + my ($k, $v) = ("key", "value") ; + ok 25, $db->db_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("key", "fred") ; + ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("another", "value") ; + ok 27, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + +} + +{ + # Check simple env works with a hash. + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + ok 28, my $lexD = new LexDir($home); + + ok 29, my $env = new BerkeleyDB::Env -Flags => DB_CREATE| DB_INIT_MPOOL, + -Home => $home ; + ok 30, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + ok 31, $db->db_put("some key", "some value") == 0 ; + ok 32, $db->db_get("some key", $value) == 0 ; + ok 33, $value eq "some value" ; + undef $db ; + undef $env ; +} + +{ + # override default hash + my $lex = new LexFile $Dfile ; + my $value ; + $::count = 0 ; + ok 34, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Hash => sub { ++$::count ; length $_[0] }, + -Flags => DB_CREATE ; + + ok 35, $db->db_put("some key", "some value") == 0 ; + ok 36, $db->db_get("some key", $value) == 0 ; + ok 37, $value eq "some value" ; + ok 38, $::count > 0 ; + +} + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my %hash ; + my ($k, $v) ; + ok 39, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => 2, + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 40, $ret == 0 ; + + # create the cursor + ok 41, my $cursor = $db->db_cursor() ; + + $k = $v = "" ; + my %copy = %data ; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 42, $cursor->status() == DB_NOTFOUND ; + ok 43, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 46, $status == DB_NOTFOUND ; + ok 47, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 48, $cursor->status() == $status ; + ok 49, $cursor->status() eq $status ; + ok 50, keys %copy == 0 ; + ok 51, $extras == 0 ; + + ($k, $v) = ("green", "house") ; + ok 52, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ; + + ($k, $v) = ("green", "door") ; + ok 53, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + + ($k, $v) = ("black", "house") ; + ok 54, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ; + +} + +{ + # Tied Hash interface + + my $lex = new LexFile $Dfile ; + my %hash ; + ok 55, tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # check "each" with an empty database + my $count = 0 ; + while (my ($k, $v) = each %hash) { + ++ $count ; + } + ok 56, (tied %hash)->status() == DB_NOTFOUND ; + ok 57, $count == 0 ; + + # Add a k/v pair + my $value ; + $hash{"some key"} = "some value"; + ok 58, (tied %hash)->status() == 0 ; + ok 59, $hash{"some key"} eq "some value"; + ok 60, defined $hash{"some key"} ; + ok 61, (tied %hash)->status() == 0 ; + ok 62, exists $hash{"some key"} ; + ok 63, !defined $hash{"jimmy"} ; + ok 64, (tied %hash)->status() == DB_NOTFOUND ; + ok 65, !exists $hash{"jimmy"} ; + ok 66, (tied %hash)->status() == DB_NOTFOUND ; + + delete $hash{"some key"} ; + ok 67, (tied %hash)->status() == 0 ; + ok 68, ! defined $hash{"some key"} ; + ok 69, (tied %hash)->status() == DB_NOTFOUND ; + ok 70, ! exists $hash{"some key"} ; + ok 71, (tied %hash)->status() == DB_NOTFOUND ; + + $hash{1} = 2 ; + $hash{10} = 20 ; + $hash{1000} = 2000 ; + + my ($keys, $values) = (0,0); + $count = 0 ; + while (my ($k, $v) = each %hash) { + $keys += $k ; + $values += $v ; + ++ $count ; + } + ok 72, $count == 3 ; + ok 73, $keys == 1011 ; + ok 74, $values == 2022 ; + + # now clear the hash + %hash = () ; + ok 75, keys %hash == 0 ; + + untie %hash ; +} + +{ + # in-memory file + + my $lex = new LexFile $Dfile ; + my %hash ; + my $fd ; + my $value ; + ok 76, my $db = tie %hash, 'BerkeleyDB::Hash' ; + + ok 77, $db->db_put("some key", "some value") == 0 ; + ok 78, $db->db_get("some key", $value) == 0 ; + ok 79, $value eq "some value" ; + + undef $db ; + untie %hash ; +} + +{ + # partial + # check works via API + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + ok 80, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + my $ret = 0 ; + while (my ($k, $v) = each %data) { + $ret += $db->db_put($k, $v) ; + } + ok 81, $ret == 0 ; + + + # do a partial get + my($pon, $off, $len) = $db->partial_set(0,2) ; + ok 82, $pon == 0 && $off == 0 && $len == 0 ; + ok 83, ( $db->db_get("red", $value) == 0) && $value eq "bo" ; + ok 84, ( $db->db_get("green", $value) == 0) && $value eq "ho" ; + ok 85, ( $db->db_get("blue", $value) == 0) && $value eq "se" ; + + # do a partial get, off end of data + ($pon, $off, $len) = $db->partial_set(3,2) ; + ok 86, $pon ; + ok 87, $off == 0 ; + ok 88, $len == 2 ; + ok 89, $db->db_get("red", $value) == 0 && $value eq "t" ; + ok 90, $db->db_get("green", $value) == 0 && $value eq "se" ; + ok 91, $db->db_get("blue", $value) == 0 && $value eq "" ; + + # switch of partial mode + ($pon, $off, $len) = $db->partial_clear() ; + ok 92, $pon ; + ok 93, $off == 3 ; + ok 94, $len == 2 ; + ok 95, $db->db_get("red", $value) == 0 && $value eq "boat" ; + ok 96, $db->db_get("green", $value) == 0 && $value eq "house" ; + ok 97, $db->db_get("blue", $value) == 0 && $value eq "sea" ; + + # now partial put + ($pon, $off, $len) = $db->partial_set(0,2) ; + ok 98, ! $pon ; + ok 99, $off == 0 ; + ok 100, $len == 0 ; + ok 101, $db->db_put("red", "") == 0 ; + ok 102, $db->db_put("green", "AB") == 0 ; + ok 103, $db->db_put("blue", "XYZ") == 0 ; + ok 104, $db->db_put("new", "KLM") == 0 ; + + $db->partial_clear() ; + ok 105, $db->db_get("red", $value) == 0 && $value eq "at" ; + ok 106, $db->db_get("green", $value) == 0 && $value eq "ABuse" ; + ok 107, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ; + ok 108, $db->db_get("new", $value) == 0 && $value eq "KLM" ; + + # now partial put + $db->partial_set(3,2) ; + ok 109, $db->db_put("red", "PPP") == 0 ; + ok 110, $db->db_put("green", "Q") == 0 ; + ok 111, $db->db_put("blue", "XYZ") == 0 ; + ok 112, $db->db_put("new", "--") == 0 ; + + ($pon, $off, $len) = $db->partial_clear() ; + ok 113, $pon ; + ok 114, $off == 3 ; + ok 115, $len == 2 ; + ok 116, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ; + ok 117, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ; + ok 118, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ; + ok 119, $db->db_get("new", $value) == 0 && $value eq "KLM--" ; +} + +{ + # partial + # check works via tied hash + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + ok 120, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + + # create some data + my %data = ( + "red" => "boat", + "green" => "house", + "blue" => "sea", + ) ; + + while (my ($k, $v) = each %data) { + $hash{$k} = $v ; + } + + + # do a partial get + $db->partial_set(0,2) ; + ok 121, $hash{"red"} eq "bo" ; + ok 122, $hash{"green"} eq "ho" ; + ok 123, $hash{"blue"} eq "se" ; + + # do a partial get, off end of data + $db->partial_set(3,2) ; + ok 124, $hash{"red"} eq "t" ; + ok 125, $hash{"green"} eq "se" ; + ok 126, $hash{"blue"} eq "" ; + + # switch of partial mode + $db->partial_clear() ; + ok 127, $hash{"red"} eq "boat" ; + ok 128, $hash{"green"} eq "house" ; + ok 129, $hash{"blue"} eq "sea" ; + + # now partial put + $db->partial_set(0,2) ; + ok 130, $hash{"red"} = "" ; + ok 131, $hash{"green"} = "AB" ; + ok 132, $hash{"blue"} = "XYZ" ; + ok 133, $hash{"new"} = "KLM" ; + + $db->partial_clear() ; + ok 134, $hash{"red"} eq "at" ; + ok 135, $hash{"green"} eq "ABuse" ; + ok 136, $hash{"blue"} eq "XYZa" ; + ok 137, $hash{"new"} eq "KLM" ; + + # now partial put + $db->partial_set(3,2) ; + ok 138, $hash{"red"} = "PPP" ; + ok 139, $hash{"green"} = "Q" ; + ok 140, $hash{"blue"} = "XYZ" ; + ok 141, $hash{"new"} = "TU" ; + + $db->partial_clear() ; + ok 142, $hash{"red"} eq "at\0PPP" ; + ok 143, $hash{"green"} eq "ABuQ" ; + ok 144, $hash{"blue"} eq "XYZXYZ" ; + ok 145, $hash{"new"} eq "KLMTU" ; +} + +{ + # transaction + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 146, my $lexD = new LexDir($home); + ok 147, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 148, my $txn = $env->txn_begin() ; + ok 149, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + # 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 ; +} + + +{ + # 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/db/perl/BerkeleyDB/t/join.t b/db/perl/BerkeleyDB/t/join.t new file mode 100644 index 000000000..d63726c79 --- /dev/null +++ b/db/perl/BerkeleyDB/t/join.t @@ -0,0 +1,225 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +if ($BerkeleyDB::db_ver < 2.005002) +{ + print "1..0 # Skip: join needs Berkeley DB 2.5.2 or later\n" ; + exit 0 ; +} + + +print "1..37\n"; + +my $Dfile1 = "dbhash1.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile1, $Dfile2, $Dfile3 ; + +umask(0) ; + +{ + # error cases + my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ; + my %hash1 ; + my $value ; + my $status ; + my $cursor ; + + ok 1, my $db1 = tie %hash1, 'BerkeleyDB::Hash', + -Filename => $Dfile1, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] lt $_[1] }, + -Property => DB_DUP|DB_DUPSORT ; + + # no cursors supplied + eval '$cursor = $db1->db_join() ;' ; + ok 2, $@ =~ /Usage: \$db->BerkeleyDB::Common::db_join\Q([cursors], flags=0)/; + + # empty list + eval '$cursor = $db1->db_join([]) ;' ; + ok 3, $@ =~ /db_join: No cursors in parameter list/; + + # cursor list, isn't a [] + eval '$cursor = $db1->db_join({}) ;' ; + ok 4, $@ =~ /cursors is not an array reference at/ ; + + eval '$cursor = $db1->db_join(\1) ;' ; + ok 5, $@ =~ /cursors is not an array reference at/ ; + +} + +{ + # test a 2-way & 3-way join + + my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ; + my %hash1 ; + my %hash2 ; + my %hash3 ; + my $value ; + my $status ; + + my $home = "./fred" ; + ok 6, my $lexD = new LexDir($home); + ok 7, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN + |DB_INIT_MPOOL; + #|DB_INIT_MPOOL| DB_INIT_LOCK; + ok 8, my $txn = $env->txn_begin() ; + ok 9, my $db1 = tie %hash1, 'BerkeleyDB::Hash', + -Filename => $Dfile1, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Env => $env, + -Txn => $txn ; + ; + + ok 10, my $db2 = tie %hash2, 'BerkeleyDB::Hash', + -Filename => $Dfile2, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Env => $env, + -Txn => $txn ; + + ok 11, my $db3 = tie %hash3, 'BerkeleyDB::Btree', + -Filename => $Dfile3, + -Flags => DB_CREATE, + -DupCompare => sub { $_[0] cmp $_[1] }, + -Property => DB_DUP|DB_DUPSORT, + -Env => $env, + -Txn => $txn ; + + + ok 12, addData($db1, qw( apple Convenience + peach Shopway + pear Farmer + raspberry Shopway + strawberry Shopway + gooseberry Farmer + blueberry Farmer + )); + + ok 13, addData($db2, qw( red apple + red raspberry + red strawberry + yellow peach + yellow pear + green gooseberry + blue blueberry)) ; + + ok 14, addData($db3, qw( expensive apple + reasonable raspberry + expensive strawberry + reasonable peach + reasonable pear + expensive gooseberry + reasonable blueberry)) ; + + ok 15, my $cursor2 = $db2->db_cursor() ; + my $k = "red" ; + my $v = "" ; + ok 16, $cursor2->c_get($k, $v, DB_SET) == 0 ; + + # Two way Join + ok 17, my $cursor1 = $db1->db_join([$cursor2]) ; + + my %expected = qw( apple Convenience + raspberry Shopway + strawberry Shopway + ) ; + + # sequence forwards + while ($cursor1->c_get($k, $v) == 0) { + delete $expected{$k} + if defined $expected{$k} && $expected{$k} eq $v ; + #print "[$k] [$v]\n" ; + } + ok 18, keys %expected == 0 ; + ok 19, $cursor1->status() == DB_NOTFOUND ; + + # Three way Join + ok 20, $cursor2 = $db2->db_cursor() ; + $k = "red" ; + $v = "" ; + ok 21, $cursor2->c_get($k, $v, DB_SET) == 0 ; + + ok 22, my $cursor3 = $db3->db_cursor() ; + $k = "expensive" ; + $v = "" ; + ok 23, $cursor3->c_get($k, $v, DB_SET) == 0 ; + ok 24, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ; + + %expected = qw( apple Convenience + strawberry Shopway + ) ; + + # sequence forwards + while ($cursor1->c_get($k, $v) == 0) { + delete $expected{$k} + if defined $expected{$k} && $expected{$k} eq $v ; + #print "[$k] [$v]\n" ; + } + ok 25, keys %expected == 0 ; + ok 26, $cursor1->status() == DB_NOTFOUND ; + + # test DB_JOIN_ITEM + # ################# + ok 27, $cursor2 = $db2->db_cursor() ; + $k = "red" ; + $v = "" ; + ok 28, $cursor2->c_get($k, $v, DB_SET) == 0 ; + + ok 29, $cursor3 = $db3->db_cursor() ; + $k = "expensive" ; + $v = "" ; + ok 30, $cursor3->c_get($k, $v, DB_SET) == 0 ; + ok 31, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ; + + %expected = qw( apple 1 + strawberry 1 + ) ; + + # sequence forwards + $k = "" ; + $v = "" ; + while ($cursor1->c_get($k, $v, DB_JOIN_ITEM) == 0) { + delete $expected{$k} + if defined $expected{$k} ; + #print "[$k]\n" ; + } + ok 32, keys %expected == 0 ; + ok 33, $cursor1->status() == DB_NOTFOUND ; + + ok 34, $cursor1->c_close() == 0 ; + ok 35, $cursor2->c_close() == 0 ; + ok 36, $cursor3->c_close() == 0 ; + + ok 37, ($status = $txn->txn_commit) == 0; + + undef $txn ; + #undef $cursor1; + #undef $cursor2; + #undef $cursor3; + undef $db1 ; + undef $db2 ; + undef $db3 ; + undef $env ; + untie %hash1 ; + untie %hash2 ; + untie %hash3 ; +} + diff --git a/db/perl/BerkeleyDB/t/mldbm.t b/db/perl/BerkeleyDB/t/mldbm.t new file mode 100644 index 000000000..fe195fe46 --- /dev/null +++ b/db/perl/BerkeleyDB/t/mldbm.t @@ -0,0 +1,159 @@ +#!/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 ; + } +} + +use t::util ; + +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/db/perl/BerkeleyDB/t/queue.t b/db/perl/BerkeleyDB/t/queue.t new file mode 100644 index 000000000..3a0d107d8 --- /dev/null +++ b/db/perl/BerkeleyDB/t/queue.t @@ -0,0 +1,746 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3.3) { + print "1..0 # Skipping test, Queue needs Berkeley DB 3.3.x or better\n" ; + exit 0 ; + } +} + +print "1..197\n"; + +sub fillout +{ + my $var = shift ; + my $length = shift ; + my $pad = shift || " " ; + my $template = $pad x $length ; + substr($template, 0, length($var)) = $var ; + return $template ; +} + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Queue -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) / ; + + eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to Queue + +{ + my $lex = new LexFile $Dfile ; + my $rec_len = 10 ; + my $pad = "x" ; + + ok 6, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -Flags => DB_CREATE, + -Len => $rec_len, + -Pad => $pad; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put(1, "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get(1, $value) == 0 ; + ok 10, $value eq fillout("some value", $rec_len, $pad) ; + ok 11, $db->db_put(2, "value") == 0 ; + ok 12, $db->db_get(2, $value) == 0 ; + ok 13, $value eq fillout("value", $rec_len, $pad) ; + ok 14, $db->db_del(1) == 0 ; + ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ; + ok 16, $db->status() == DB_KEYEMPTY ; + ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ; + + ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ; + ok 19, $db->status() == DB_NOTFOUND ; + ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ; + + ok 21, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ; + ok 24, $db->status() == DB_KEYEXIST ; + + + # check that the value of the key has not been changed by the + # previous test + ok 25, $db->db_get(2, $value) == 0 ; + ok 26, $value eq fillout("value", $rec_len, $pad) ; + + +} + + +{ + # Check simple env works with a array. + # and pad defaults to space + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + my $rec_len = 11 ; + ok 27, my $lexD = new LexDir($home); + + ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL, + -Home => $home ; + ok 29, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE, + -Len => $rec_len; + + # Add a k/v pair + my $value ; + ok 30, $db->db_put(1, "some value") == 0 ; + ok 31, $db->db_get(1, $value) == 0 ; + ok 32, $value eq fillout("some value", $rec_len) ; + undef $db ; + undef $env ; +} + + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my @array ; + my ($k, $v) ; + my $rec_len = 5 ; + ok 33, my $db = new BerkeleyDB::Queue -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Len => $rec_len; + + # create some data + my @data = ( + "red" , + "green" , + "blue" , + ) ; + + my $i ; + my %data ; + my $ret = 0 ; + for ($i = 0 ; $i < @data ; ++$i) { + $ret += $db->db_put($i, $data[$i]) ; + $data{$i} = $data[$i] ; + } + ok 34, $ret == 0 ; + + # create the cursor + ok 35, my $cursor = $db->db_cursor() ; + + $k = 0 ; $v = "" ; + my %copy = %data; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { + if ( fillout($copy{$k}, $rec_len) eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + + ok 36, $cursor->status() == DB_NOTFOUND ; + ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ; + ok 38, keys %copy == 0 ; + ok 39, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( fillout($copy{$k}, $rec_len) eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 40, $status == DB_NOTFOUND ; + ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 42, $cursor->status() == $status ; + ok 43, $cursor->status() eq $status ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; +} + +{ + # Tied Array interface + + # 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" ; + ok 169, my $lexD = new LexDir($home); + my $rec_len = 9 ; + ok 170, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 171, my $txn = $env->txn_begin() ; + ok 172, my $db1 = tie @array, 'BerkeleyDB::Queue', + -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn , + -Len => $rec_len, + -Pad => " " ; + + + # create some data + my @data = ( + "boat", + "house", + "sea", + ) ; + + my $ret = 0 ; + my $i ; + for ($i = 0 ; $i < @data ; ++$i) { + $ret += $db1->db_put($i, $data[$i]) ; + } + ok 173, $ret == 0 ; + + # should be able to see all the records + + ok 174, my $cursor = $db1->db_cursor() ; + my ($k, $v) = (0, "") ; + my $count = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 175, $count == 3 ; + undef $cursor ; + + # now abort the transaction + ok 176, $txn->txn_abort() == 0 ; + + # there shouldn't be any records in the database + $count = 0 ; + # sequence forwards + ok 177, $cursor = $db1->db_cursor() ; + while ($cursor->c_get($k, $v, DB_NEXT) == 0) { + ++ $count ; + } + ok 178, $count == 0 ; + + undef $txn ; + undef $cursor ; + undef $db1 ; + undef $env ; + untie @array ; +} + + +{ + # db_stat + + my $lex = new LexFile $Dfile ; + my $recs = ($BerkeleyDB::db_version >= 3.1 ? "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/db/perl/BerkeleyDB/t/recno.t b/db/perl/BerkeleyDB/t/recno.t new file mode 100644 index 000000000..4da7ae2e0 --- /dev/null +++ b/db/perl/BerkeleyDB/t/recno.t @@ -0,0 +1,877 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..218\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Recno -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Recno -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) / ; + + eval ' $db = new BerkeleyDB::Recno -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Recno -Txn => "x" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Recno -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# Now check the interface to Recno + +{ + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + my $status ; + ok 7, $db->db_put(1, "some value") == 0 ; + ok 8, $db->status() == 0 ; + ok 9, $db->db_get(1, $value) == 0 ; + ok 10, $value eq "some value" ; + ok 11, $db->db_put(2, "value") == 0 ; + ok 12, $db->db_get(2, $value) == 0 ; + ok 13, $value eq "value" ; + ok 14, $db->db_del(1) == 0 ; + ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ; + ok 16, $db->status() == DB_KEYEMPTY ; + ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ; + + ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ; + ok 19, $db->status() == DB_NOTFOUND ; + ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ; + + ok 21, $db->db_sync() == 0 ; + + # Check NOOVERWRITE will make put fail when attempting to overwrite + # an existing record. + + ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ; + ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ; + ok 24, $db->status() == DB_KEYEXIST ; + + + # check that the value of the key has not been changed by the + # previous test + ok 25, $db->db_get(2, $value) == 0 ; + ok 26, $value eq "value" ; + + +} + + +{ + # Check simple env works with a array. + my $lex = new LexFile $Dfile ; + + my $home = "./fred" ; + ok 27, my $lexD = new LexDir($home); + + ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL, + -Home => $home ; + + ok 29, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -Env => $env, + -Flags => DB_CREATE ; + + # Add a k/v pair + my $value ; + ok 30, $db->db_put(1, "some value") == 0 ; + ok 31, $db->db_get(1, $value) == 0 ; + ok 32, $value eq "some value" ; + undef $db ; + undef $env ; +} + + +{ + # cursors + + my $lex = new LexFile $Dfile ; + my @array ; + my ($k, $v) ; + ok 33, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE ; + + # create some data + my @data = ( + "red" , + "green" , + "blue" , + ) ; + + my $i ; + my %data ; + my $ret = 0 ; + for ($i = 0 ; $i < @data ; ++$i) { + $ret += $db->db_put($i, $data[$i]) ; + $data{$i} = $data[$i] ; + } + ok 34, $ret == 0 ; + + # create the cursor + ok 35, my $cursor = $db->db_cursor() ; + + $k = 0 ; $v = "" ; + my %copy = %data; + my $extras = 0 ; + # sequence forwards + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + + ok 36, $cursor->status() == DB_NOTFOUND ; + ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ; + ok 38, keys %copy == 0 ; + ok 39, $extras == 0 ; + + # sequence backwards + %copy = %data ; + $extras = 0 ; + my $status ; + for ( $status = $cursor->c_get($k, $v, DB_LAST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_PREV)) { + if ( $copy{$k} eq $v ) + { delete $copy{$k} } + else + { ++ $extras } + } + ok 40, $status == DB_NOTFOUND ; + ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ; + ok 42, $cursor->status() == $status ; + ok 43, $cursor->status() eq $status ; + ok 44, keys %copy == 0 ; + ok 45, $extras == 0 ; +} + +{ + # Tied Array interface + + # 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" ; + ok 167, my $lexD = new LexDir($home); + ok 168, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 169, my $txn = $env->txn_begin() ; + ok 170, my $db1 = tie @array, 'BerkeleyDB::Recno', + -Filename => $Dfile, + -ArrayBase => 0, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + # 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 ; +} + + +{ + # 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/db/perl/BerkeleyDB/t/strict.t b/db/perl/BerkeleyDB/t/strict.t new file mode 100644 index 000000000..a87d5312e --- /dev/null +++ b/db/perl/BerkeleyDB/t/strict.t @@ -0,0 +1,172 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..44\n"; + +my $Dfile = "dbhash.tmp"; +my $home = "./fred" ; + +umask(0); + +{ + # closing a database & an environment in the correct order. + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + + ok 1, my $lexD = new LexDir($home); + ok 2, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 3, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env; + + ok 4, $db1->db_close() == 0 ; + + eval { $status = $env->db_appexit() ; } ; + ok 5, $status == 0 ; + ok 6, $@ eq "" ; + #print "[$@]\n" ; + +} + +{ + # closing an environment with an open database + my $lex = new LexFile $Dfile ; + my %hash ; + + ok 7, my $lexD = new LexDir($home); + ok 8, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 9, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env; + + eval { $env->db_appexit() ; } ; + ok 10, $@ =~ /BerkeleyDB Aborting: attempted to close an environment with 1 open database/ ; + #print "[$@]\n" ; + + undef $db1 ; + untie %hash ; + undef $env ; +} + +{ + # closing a transaction & a database + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + + ok 11, my $lexD = new LexDir($home); + ok 12, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 13, my $txn = $env->txn_begin() ; + ok 14, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + ok 15, $txn->txn_commit() == 0 ; + eval { $status = $db->db_close() ; } ; + ok 16, $status == 0 ; + ok 17, $@ eq "" ; + eval { $status = $env->db_appexit() ; } ; + ok 18, $status == 0 ; + ok 19, $@ eq "" ; + #print "[$@]\n" ; +} + +{ + # closing a database with an open transaction + my $lex = new LexFile $Dfile ; + my %hash ; + + ok 20, my $lexD = new LexDir($home); + ok 21, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + + ok 22, my $txn = $env->txn_begin() ; + ok 23, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + eval { $db->db_close() ; } ; + ok 24, $@ =~ /BerkeleyDB Aborting: attempted to close a database while a transaction was still open at/ ; + #print "[$@]\n" ; +} + +{ + # closing a cursor & a database + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + ok 25, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + ok 26, my $cursor = $db->db_cursor() ; + ok 27, $cursor->c_close() == 0 ; + eval { $status = $db->db_close() ; } ; + ok 28, $status == 0 ; + ok 29, $@ eq "" ; + #print "[$@]\n" ; +} + +{ + # closing a database with an open cursor + my $lex = new LexFile $Dfile ; + my %hash ; + ok 30, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE ; + ok 31, my $cursor = $db->db_cursor() ; + eval { $db->db_close() ; } ; + ok 32, $@ =~ /\QBerkeleyDB Aborting: attempted to close a database with 1 open cursor(s) at/; + #print "[$@]\n" ; +} + +{ + # closing a transaction & a cursor + my $lex = new LexFile $Dfile ; + my %hash ; + my $status ; + + ok 33, my $lexD = new LexDir($home); + ok 34, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 35, my $txn = $env->txn_begin() ; + ok 36, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + ok 37, my $cursor = $db->db_cursor() ; + eval { $status = $cursor->c_close() ; } ; + ok 38, $status == 0 ; + ok 39, ($status = $txn->txn_commit()) == 0 ; + ok 40, $@ eq "" ; + eval { $status = $db->db_close() ; } ; + ok 41, $status == 0 ; + ok 42, $@ eq "" ; + eval { $status = $env->db_appexit() ; } ; + ok 43, $status == 0 ; + ok 44, $@ eq "" ; + #print "[$@]\n" ; +} + diff --git a/db/perl/BerkeleyDB/t/subdb.t b/db/perl/BerkeleyDB/t/subdb.t new file mode 100644 index 000000000..c48ec6e25 --- /dev/null +++ b/db/perl/BerkeleyDB/t/subdb.t @@ -0,0 +1,242 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +BEGIN +{ + if ($BerkeleyDB::db_version < 3) { + print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ; + exit 0 ; + } +} + +print "1..43\n"; + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $Dfile3 = "dbhash3.tmp"; +unlink $Dfile; + +umask(0) ; + +# Berkeley DB 3.x specific functionality + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' BerkeleyDB::db_remove -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' BerkeleyDB::db_remove -Bad => 2, -Filename => "fred", -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' BerkeleyDB::db_remove -Filename => "a", -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' BerkeleyDB::db_remove -Subname => "a"' ; + ok 4, $@ =~ /^Must specify a filename/ ; + + my $obj = bless [], "main" ; + eval ' BerkeleyDB::db_remove -Filename => "x", -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +{ + # subdatabases + + # opening a subdatabse in an exsiting database that doesn't have + # subdatabases at all should fail + + my $lex = new LexFile $Dfile ; + + ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 7, addData($db, %data) ; + + undef $db ; + + $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" ; + ok 8, ! $db ; + + ok 9, -e $Dfile ; + ok 10, ! BerkeleyDB::db_remove(-Filename => $Dfile) ; +} + +{ + # subdatabases + + # opening a subdatabse in an exsiting database that does have + # subdatabases at all, but not this one + + my $lex = new LexFile $Dfile ; + + ok 11, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" , + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 12, addData($db, %data) ; + + undef $db ; + + $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "joe" ; + + ok 13, !$db ; + +} + +{ + # subdatabases + + my $lex = new LexFile $Dfile ; + + ok 14, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" , + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 15, addData($db, %data) ; + + undef $db ; + + ok 16, $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" ; + + ok 17, my $cursor = $db->db_cursor() ; + my ($k, $v) = ("", "") ; + my $status ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + if ($data{$k} eq $v) { + delete $data{$k} ; + } + } + ok 18, $status == DB_NOTFOUND ; + ok 19, keys %data == 0 ; +} + +{ + # subdatabases + + # opening a database with multiple subdatabases - handle should be a list + # of the subdatabase names + + my $lex = new LexFile $Dfile ; + + ok 20, my $db1 = new BerkeleyDB::Hash -Filename => $Dfile, + -Subname => "fred" , + -Flags => DB_CREATE ; + + ok 21, my $db2 = new BerkeleyDB::Btree -Filename => $Dfile, + -Subname => "joe" , + -Flags => DB_CREATE ; + + # Add a k/v pair + my %data = qw( + red sky + blue sea + black heart + yellow belley + green grass + ) ; + + ok 22, addData($db1, %data) ; + ok 23, addData($db2, %data) ; + + undef $db1 ; + undef $db2 ; + + ok 24, my $db = new BerkeleyDB::Unknown -Filename => $Dfile , + -Flags => DB_RDONLY ; + + #my $type = $db->type() ; print "type $type\n" ; + ok 25, my $cursor = $db->db_cursor() ; + my ($k, $v) = ("", "") ; + my $status ; + my @dbnames = () ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + push @dbnames, $k ; + } + ok 26, $status == DB_NOTFOUND ; + ok 27, join(",", sort @dbnames) eq "fred,joe" ; + undef $db ; + + ok 28, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "harry") != 0; + ok 29, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") == 0 ; + + # should only be one subdatabase + ok 30, $db = new BerkeleyDB::Unknown -Filename => $Dfile , + -Flags => DB_RDONLY ; + + ok 31, $cursor = $db->db_cursor() ; + @dbnames = () ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + push @dbnames, $k ; + } + ok 32, $status == DB_NOTFOUND ; + ok 33, join(",", sort @dbnames) eq "joe" ; + undef $db ; + + # can't delete an already deleted subdatabase + ok 34, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") != 0; + + ok 35, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "joe") == 0 ; + + # should only be one subdatabase + ok 36, $db = new BerkeleyDB::Unknown -Filename => $Dfile , + -Flags => DB_RDONLY ; + + ok 37, $cursor = $db->db_cursor() ; + @dbnames = () ; + while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) { + push @dbnames, $k ; + } + ok 38, $status == DB_NOTFOUND ; + ok 39, @dbnames == 0 ; + undef $db ; + + 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/db/perl/BerkeleyDB/t/txn.t b/db/perl/BerkeleyDB/t/txn.t new file mode 100644 index 000000000..c746c8d9b --- /dev/null +++ b/db/perl/BerkeleyDB/t/txn.t @@ -0,0 +1,306 @@ +#!./perl -w + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..50\n"; + +my $Dfile = "dbhash.tmp"; + +umask(0); + +{ + # error cases + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 1, my $lexD = new LexDir($home); + ok 2, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE| DB_INIT_MPOOL; + eval { $env->txn_begin() ; } ; + ok 3, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ; + + eval { my $txn_mgr = $env->TxnMgr() ; } ; + ok 4, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ; + undef $env ; + +} + +{ + # transaction - abort works + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 5, my $lexD = new LexDir($home); + ok 6, my $env = new BerkeleyDB::Env -Home => $home, + -Flags => DB_CREATE|DB_INIT_TXN| + DB_INIT_MPOOL|DB_INIT_LOCK ; + ok 7, my $txn = $env->txn_begin() ; + ok 8, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile, + -Flags => DB_CREATE , + -Env => $env, + -Txn => $txn ; + + + # 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 ; +} + +{ + # transaction - abort works via txnmgr + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 16, my $lexD = new LexDir($home); + 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 ; +} + +{ + # transaction - commit works + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 28, my $lexD = new LexDir($home); + 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 ; +} + +{ + # transaction - commit works via txnmgr + + my $lex = new LexFile $Dfile ; + my %hash ; + my $value ; + + my $home = "./fred" ; + ok 39, my $lexD = new LexDir($home); + 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 ; +} + diff --git a/db/perl/BerkeleyDB/t/unknown.t b/db/perl/BerkeleyDB/t/unknown.t new file mode 100644 index 000000000..f2630b585 --- /dev/null +++ b/db/perl/BerkeleyDB/t/unknown.t @@ -0,0 +1,176 @@ +#!./perl -w + +# ID: %I%, %G% + +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use BerkeleyDB; +use t::util ; + +print "1..41\n"; + +my $Dfile = "dbhash.tmp"; +unlink $Dfile; + +umask(0) ; + + +# Check for invalid parameters +{ + # Check for invalid parameters + my $db ; + eval ' $db = new BerkeleyDB::Unknown -Stupid => 3 ; ' ; + ok 1, $@ =~ /unknown key value\(s\) Stupid/ ; + + eval ' $db = new BerkeleyDB::Unknown -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; + ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ; + + eval ' $db = new BerkeleyDB::Unknown -Env => 2 ' ; + ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ; + + eval ' $db = new BerkeleyDB::Unknown -Txn => "fred" ' ; + ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; + + my $obj = bless [], "main" ; + eval ' $db = new BerkeleyDB::Unknown -Env => $obj ' ; + ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ; +} + +# check the interface to a rubbish database +{ + # first an empty file + my $lex = new LexFile $Dfile ; + ok 6, writeFile($Dfile, "") ; + + ok 7, ! (new BerkeleyDB::Unknown -Filename => $Dfile); + + # now a non-database file + writeFile($Dfile, "\x2af6") ; + ok 8, ! (new BerkeleyDB::Unknown -Filename => $Dfile); +} + +# check the interface to a Hash database + +{ + my $lex = new LexFile $Dfile ; + + # create a hash database + ok 9, my $db = new BerkeleyDB::Hash -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a few k/v pairs + my $value ; + my $status ; + ok 10, $db->db_put("some key", "some value") == 0 ; + ok 11, $db->db_put("key", "value") == 0 ; + + # close the database + undef $db ; + + # now open it with Unknown + ok 12, $db = new BerkeleyDB::Unknown -Filename => $Dfile; + + ok 13, $db->type() == DB_HASH ; + ok 14, $db->db_get("some key", $value) == 0 ; + ok 15, $value eq "some value" ; + ok 16, $db->db_get("key", $value) == 0 ; + ok 17, $value eq "value" ; + + my @array ; + eval { $db->Tie(\@array)} ; + ok 18, $@ =~ /^Tie needs a reference to a hash/ ; + + my %hash ; + $db->Tie(\%hash) ; + ok 19, $hash{"some key"} eq "some value" ; + +} + +# check the interface to a Btree database + +{ + my $lex = new LexFile $Dfile ; + + # create a hash database + ok 20, my $db = new BerkeleyDB::Btree -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a few k/v pairs + my $value ; + my $status ; + ok 21, $db->db_put("some key", "some value") == 0 ; + ok 22, $db->db_put("key", "value") == 0 ; + + # close the database + undef $db ; + + # now open it with Unknown + # create a hash database + ok 23, $db = new BerkeleyDB::Unknown -Filename => $Dfile; + + ok 24, $db->type() == DB_BTREE ; + ok 25, $db->db_get("some key", $value) == 0 ; + ok 26, $value eq "some value" ; + ok 27, $db->db_get("key", $value) == 0 ; + ok 28, $value eq "value" ; + + + my @array ; + eval { $db->Tie(\@array)} ; + ok 29, $@ =~ /^Tie needs a reference to a hash/ ; + + my %hash ; + $db->Tie(\%hash) ; + ok 30, $hash{"some key"} eq "some value" ; + + +} + +# check the interface to a Recno database + +{ + my $lex = new LexFile $Dfile ; + + # create a recno database + ok 31, my $db = new BerkeleyDB::Recno -Filename => $Dfile, + -Flags => DB_CREATE ; + + # Add a few k/v pairs + my $value ; + my $status ; + ok 32, $db->db_put(0, "some value") == 0 ; + ok 33, $db->db_put(1, "value") == 0 ; + + # close the database + undef $db ; + + # now open it with Unknown + # create a hash database + ok 34, $db = new BerkeleyDB::Unknown -Filename => $Dfile; + + ok 35, $db->type() == DB_RECNO ; + ok 36, $db->db_get(0, $value) == 0 ; + ok 37, $value eq "some value" ; + ok 38, $db->db_get(1, $value) == 0 ; + ok 39, $value eq "value" ; + + + my %hash ; + eval { $db->Tie(\%hash)} ; + ok 40, $@ =~ /^Tie needs a reference to an array/ ; + + my @array ; + $db->Tie(\@array) ; + ok 41, $array[1] eq "value" ; + + +} + +# check i/f to text diff --git a/db/perl/BerkeleyDB/t/util.pm b/db/perl/BerkeleyDB/t/util.pm new file mode 100644 index 000000000..0c7f0deb5 --- /dev/null +++ b/db/perl/BerkeleyDB/t/util.pm @@ -0,0 +1,180 @@ +package util ; + +package main ; + +use strict ; +use BerkeleyDB ; +use File::Path qw(rmtree); +use vars qw(%DB_errors) ; + +%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 } ; + } +} + + +{ + package LexDir ; + + use File::Path qw(rmtree); + + sub new + { + my $self = shift ; + my $dir = shift ; + + rmtree $dir if -e $dir ; + + mkdir $dir, 0777 or return undef ; + + return bless [ $dir ], $self ; + } + + sub DESTROY + { + my $self = shift ; + rmtree $self->[0] ; + } +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + return $result; +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT> || "" ; + close(CAT); + unlink $file ; + return $result; +} + +sub writeFile +{ + my $name = shift ; + open(FH, ">$name") or return 0 ; + print FH @_ ; + close FH ; + return 1 ; +} + +sub touch +{ + my $file = shift ; + open(CAT,">$file") || die "Cannot open $file:$!"; + close(CAT); +} + +sub joiner +{ + my $db = shift ; + my $sep = shift ; + my ($k, $v) = (0, "") ; + my @data = () ; + + my $cursor = $db->db_cursor() or return () ; + for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ; + $status == 0 ; + $status = $cursor->c_get($k, $v, DB_NEXT)) { + push @data, $v ; + } + + (scalar(@data), join($sep, @data)) ; +} + +sub countRecords +{ + my $db = shift ; + my ($k, $v) = (0,0) ; + my ($count) = 0 ; + my ($cursor) = $db->db_cursor() ; + #for ($status = $cursor->c_get($k, $v, DB_FIRST) ; +# $status == 0 ; +# $status = $cursor->c_get($k, $v, DB_NEXT) ) + while ($cursor->c_get($k, $v, DB_NEXT) == 0) + { ++ $count } + + return $count ; +} + +sub addData +{ + my $db = shift ; + my @data = @_ ; + die "addData odd data\n" if @data % 2 != 0 ; + my ($k, $v) ; + my $ret = 0 ; + while (@data) { + $k = shift @data ; + $v = shift @data ; + $ret += $db->db_put($k, $v) ; + } + + return ($ret == 0) ; +} + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + + +1; diff --git a/db/perl/BerkeleyDB/typemap b/db/perl/BerkeleyDB/typemap new file mode 100644 index 000000000..9feefdc47 --- /dev/null +++ b/db/perl/BerkeleyDB/typemap @@ -0,0 +1,275 @@ +# typemap for Perl 5 interface to Berkeley DB version 2 & 3 +# +# SCCS: %I%, %G% +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# +#################################### DB SECTION +# +# + +void * T_PV +u_int T_U_INT +u_int32_t T_U_INT +const char * T_PV_NULL +PV_or_NULL T_PV_NULL +IO_or_NULL T_IO_NULL + +AV * T_AV + +BerkeleyDB T_PTROBJ +BerkeleyDB::Common T_PTROBJ_AV +BerkeleyDB::Hash T_PTROBJ_AV +BerkeleyDB::Btree T_PTROBJ_AV +BerkeleyDB::Recno T_PTROBJ_AV +BerkeleyDB::Queue T_PTROBJ_AV +BerkeleyDB::Cursor T_PTROBJ_AV +BerkeleyDB::TxnMgr T_PTROBJ_AV +BerkeleyDB::Txn T_PTROBJ_AV +BerkeleyDB::Log T_PTROBJ_AV +BerkeleyDB::Lock T_PTROBJ_AV +BerkeleyDB::Env T_PTROBJ_AV + +BerkeleyDB::Raw T_RAW +BerkeleyDB::Common::Raw T_RAW +BerkeleyDB::Hash::Raw T_RAW +BerkeleyDB::Btree::Raw T_RAW +BerkeleyDB::Recno::Raw T_RAW +BerkeleyDB::Queue::Raw T_RAW +BerkeleyDB::Cursor::Raw T_RAW +BerkeleyDB::TxnMgr::Raw T_RAW +BerkeleyDB::Txn::Raw T_RAW +BerkeleyDB::Log::Raw T_RAW +BerkeleyDB::Lock::Raw T_RAW +BerkeleyDB::Env::Raw T_RAW + +BerkeleyDB::Env::Inner T_INNER +BerkeleyDB::Common::Inner T_INNER +BerkeleyDB::Txn::Inner T_INNER +BerkeleyDB::TxnMgr::Inner T_INNER +# BerkeleyDB__Env T_PTR +DBT T_dbtdatum +DBT_OPT T_dbtdatum_opt +DBT_B T_dbtdatum_btree +DBTKEY T_dbtkeydatum +DBTKEY_B T_dbtkeydatum_btree +DBTYPE T_U_INT +DualType T_DUAL +BerkeleyDB_type * T_IV +BerkeleyDB_ENV_type * T_IV +BerkeleyDB_TxnMgr_type * T_IV +BerkeleyDB_Txn_type * T_IV +BerkeleyDB__Cursor_type * T_IV +DB * T_IV + +INPUT + +T_AV + if (SvROK($arg) && SvTYPE(SvRV($arg)) == SVt_PVAV) + /* if (sv_isa($arg, \"${ntype}\")) */ + $var = (AV*)SvRV($arg); + else + croak(\"$var is not an array reference\") + +T_RAW + $var = INT2PTR($type,SvIV($arg) + +T_U_INT + $var = SvUV($arg) + +T_SV_REF_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV *)GetInternalObject($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_HV_REF_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + HV * hv = (HV *)GetInternalObject($arg); + SV ** svp = hv_fetch(hv, \"db\", 2, FALSE); + IV tmp = SvIV(*svp); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_HV_REF + if (sv_derived_from($arg, \"${ntype}\")) { + HV * hv = (HV *)GetInternalObject($arg); + SV ** svp = hv_fetch(hv, \"db\", 2, FALSE); + IV tmp = SvIV(*svp); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + + +T_P_REF + if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + + +T_INNER + { + HV * hv = (HV *)SvRV($arg); + SV ** svp = hv_fetch(hv, \"db\", 2, FALSE); + IV tmp = SvIV(*svp); + $var = INT2PTR($type, tmp); + } + +T_PV_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else { + $var = ($type)SvPV($arg,PL_na) ; + if (PL_na == 0) + $var = NULL ; + } + +T_IO_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else + $var = IoOFP(sv_2io($arg)) + +T_PTROBJ_NULL + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_PTROBJ_SELF + if ($arg == &PL_sv_undef) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_PTROBJ_AV + if ($arg == &PL_sv_undef || $arg == NULL) + $var = NULL ; + else if (sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV(getInnerObject($arg)) ; + $var = INT2PTR($type, tmp); + } + else + croak(\"$var is not of type ${ntype}\") + +T_dbtkeydatum + 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, PTR2IV($var)); + +T_SV_REF_NULL + sv_setiv($arg, PTR2IV($var)); + +T_HV_REF_NULL + sv_setiv($arg, PTR2IV($var)); + +T_HV_REF + sv_setiv($arg, PTR2IV($var)); + +T_P_REF + sv_setiv($arg, PTR2IV($var)); + +T_DUAL + setDUALerrno($arg, $var) ; + +T_U_INT + sv_setuv($arg, (UV)$var); + +T_PV_NULL + sv_setpv((SV*)$arg, $var); + +T_dbtkeydatum_btree + OutputKey_B($arg, $var) +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) +T_dbtdatum_opt + OutputValue($arg, $var) +T_dbtdatum_btree + OutputValue_B($arg, $var) + +T_PTROBJ_NULL + sv_setref_pv($arg, \"${ntype}\", (void*)$var); + +T_PTROBJ_SELF + sv_setref_pv($arg, self, (void*)$var); |