summaryrefslogtreecommitdiff
path: root/storage/bdb/perl/BerkeleyDB/t
diff options
context:
space:
mode:
Diffstat (limited to 'storage/bdb/perl/BerkeleyDB/t')
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/btree.t931
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/destroy.t105
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/env.t217
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/examples.t401
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/examples.t.T415
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/examples3.t132
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/examples3.t.T136
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/filter.t217
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/hash.t728
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/join.t225
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/mldbm.t161
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/queue.t763
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/recno.t913
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/strict.t174
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/subdb.t243
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/txn.t320
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/unknown.t176
-rw-r--r--storage/bdb/perl/BerkeleyDB/t/util.pm220
18 files changed, 6477 insertions, 0 deletions
diff --git a/storage/bdb/perl/BerkeleyDB/t/btree.t b/storage/bdb/perl/BerkeleyDB/t/btree.t
new file mode 100644
index 00000000000..fd6ed8f1268
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/btree.t
@@ -0,0 +1,931 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..244\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Btree -Stupid => 3 ; ' ;
+ ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ;
+
+ eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ;
+ ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Btree -Txn => "x" ' ;
+ ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Btree -Env => $obj ' ;
+ ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to Btree
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ ok 6, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ ok 7, $db->db_put("some key", "some value") == 0 ;
+ ok 8, $db->status() == 0 ;
+ ok 9, $db->db_get("some key", $value) == 0 ;
+ ok 10, $value eq "some value" ;
+ ok 11, $db->db_put("key", "value") == 0 ;
+ ok 12, $db->db_get("key", $value) == 0 ;
+ ok 13, $value eq "value" ;
+ ok 14, $db->db_del("some key") == 0 ;
+ ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ;
+ ok 16, $db->status() == DB_NOTFOUND ;
+ ok 17, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
+
+ ok 18, $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok 19, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok 20, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
+ ok 21, $db->status() == DB_KEYEXIST ;
+
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok 22, $db->db_get("key", $value) == 0 ;
+ ok 23, $value eq "value" ;
+
+ # test DB_GET_BOTH
+ my ($k, $v) = ("key", "value") ;
+ ok 24, $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("key", "fred") ;
+ ok 25, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("another", "value") ;
+ ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+
+}
+
+{
+ # Check simple env works with a hash.
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok 27, my $lexD = new LexDir($home) ;
+
+ ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
+ -Home => $home ;
+ ok 29, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ ok 30, $db->db_put("some key", "some value") == 0 ;
+ ok 31, $db->db_get("some key", $value) == 0 ;
+ ok 32, $value eq "some value" ;
+ undef $db ;
+ undef $env ;
+}
+
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok 33, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok 34, $ret == 0 ;
+
+ # create the cursor
+ ok 35, my $cursor = $db->db_cursor() ;
+
+ $k = $v = "" ;
+ my %copy = %data ;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok 36, $cursor->status() == DB_NOTFOUND ;
+ ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'};
+ ok 38, keys %copy == 0 ;
+ ok 39, $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok 40, $status == DB_NOTFOUND ;
+ ok 41, $status eq $DB_errors{'DB_NOTFOUND'};
+ ok 42, $cursor->status() == $status ;
+ ok 43, $cursor->status() eq $status ;
+ ok 44, keys %copy == 0 ;
+ ok 45, $extras == 0 ;
+
+ ($k, $v) = ("green", "house") ;
+ ok 46, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("green", "door") ;
+ ok 47, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("black", "house") ;
+ ok 48, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+}
+
+{
+ # Tied Hash interface
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok 49, tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # check "each" with an empty database
+ my $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ ++ $count ;
+ }
+ ok 50, (tied %hash)->status() == DB_NOTFOUND ;
+ ok 51, $count == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $hash{"some key"} = "some value";
+ ok 52, (tied %hash)->status() == 0 ;
+ ok 53, $hash{"some key"} eq "some value";
+ ok 54, defined $hash{"some key"} ;
+ ok 55, (tied %hash)->status() == 0 ;
+ ok 56, exists $hash{"some key"} ;
+ ok 57, !defined $hash{"jimmy"} ;
+ ok 58, (tied %hash)->status() == DB_NOTFOUND ;
+ ok 59, !exists $hash{"jimmy"} ;
+ ok 60, (tied %hash)->status() == DB_NOTFOUND ;
+
+ delete $hash{"some key"} ;
+ ok 61, (tied %hash)->status() == 0 ;
+ ok 62, ! defined $hash{"some key"} ;
+ ok 63, (tied %hash)->status() == DB_NOTFOUND ;
+ ok 64, ! exists $hash{"some key"} ;
+ ok 65, (tied %hash)->status() == DB_NOTFOUND ;
+
+ $hash{1} = 2 ;
+ $hash{10} = 20 ;
+ $hash{1000} = 2000 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok 66, $count == 3 ;
+ ok 67, $keys == 1011 ;
+ ok 68, $values == 2022 ;
+
+ # now clear the hash
+ %hash = () ;
+ ok 69, keys %hash == 0 ;
+
+ untie %hash ;
+}
+
+{
+ # override default compare
+ my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
+ my $value ;
+ my (%h, %g, %k) ;
+ my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
+ ok 70, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -Compare => sub { $_[0] <=> $_[1] },
+ -Flags => DB_CREATE ;
+
+ ok 71, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
+ -Compare => sub { $_[0] cmp $_[1] },
+ -Flags => DB_CREATE ;
+
+ ok 72, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
+ -Compare => sub { length $_[0] <=> length $_[1] },
+ -Flags => DB_CREATE ;
+
+ my @srt_1 ;
+ { local $^W = 0 ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+ }
+ my @srt_2 = sort { $a cmp $b } @Keys ;
+ my @srt_3 = sort { length $a <=> length $b } @Keys ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ $h{$_} = 1 ;
+ $g{$_} = 1 ;
+ $k{$_} = 1 ;
+ }
+
+ sub ArrayCompare
+ {
+ my($a, $b) = @_ ;
+
+ return 0 if @$a != @$b ;
+
+ foreach (1 .. length @$a)
+ {
+ return 0 unless $$a[$_] eq $$b[$_] ;
+ }
+
+ 1 ;
+ }
+
+ ok 73, ArrayCompare (\@srt_1, [keys %h]);
+ ok 74, ArrayCompare (\@srt_2, [keys %g]);
+ ok 75, ArrayCompare (\@srt_3, [keys %k]);
+
+}
+
+{
+ # override default compare, with duplicates, don't sort values
+ my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
+ my $value ;
+ my (%h, %g, %k) ;
+ my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ;
+ my @Values = qw( 1 0 3 dd x abc 0 ) ;
+ ok 76, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -Compare => sub { $_[0] <=> $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ ok 77, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
+ -Compare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ ok 78, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
+ -Compare => sub { length $_[0] <=> length $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ my @srt_1 ;
+ { local $^W = 0 ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+ }
+ my @srt_2 = sort { $a cmp $b } @Keys ;
+ my @srt_3 = sort { length $a <=> length $b } @Keys ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ my $value = shift @Values ;
+ $h{$_} = $value ;
+ $g{$_} = $value ;
+ $k{$_} = $value ;
+ }
+
+ sub getValues
+ {
+ my $hash = shift ;
+ my $db = tied %$hash ;
+ my $cursor = $db->db_cursor() ;
+ my @values = () ;
+ my ($k, $v) = (0,0) ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ push @values, $v ;
+ }
+ return @values ;
+ }
+
+ ok 79, ArrayCompare (\@srt_1, [keys %h]);
+ ok 80, ArrayCompare (\@srt_2, [keys %g]);
+ ok 81, ArrayCompare (\@srt_3, [keys %k]);
+ ok 82, ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]);
+ ok 83, ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]);
+ ok 84, ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]);
+
+ # test DB_DUP_NEXT
+ ok 85, my $cur = (tied %g)->db_cursor() ;
+ my ($k, $v) = (9, "") ;
+ ok 86, $cur->c_get($k, $v, DB_SET) == 0 ;
+ ok 87, $k == 9 && $v == 0 ;
+ ok 88, $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok 89, $k == 9 && $v eq "x" ;
+ ok 90, $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
+}
+
+{
+ # override default compare, with duplicates, sort values
+ my $lex = new LexFile $Dfile, $Dfile2;
+ my $value ;
+ my (%h, %g) ;
+ my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
+ my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
+ ok 91, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -Compare => sub { $_[0] <=> $_[1] },
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ ok 92, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
+ -Compare => sub { $_[0] cmp $_[1] },
+ -DupCompare => sub { $_[0] <=> $_[1] },
+ -Property => DB_DUP,
+
+
+
+ -Flags => DB_CREATE ;
+
+ my @srt_1 ;
+ { local $^W = 0 ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+ }
+ my @srt_2 = sort { $a cmp $b } @Keys ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ my $value = shift @Values ;
+ $h{$_} = $value ;
+ $g{$_} = $value ;
+ }
+
+ ok 93, ArrayCompare (\@srt_1, [keys %h]);
+ ok 94, ArrayCompare (\@srt_2, [keys %g]);
+ ok 95, ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]);
+ ok 96, ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]);
+
+}
+
+{
+ # get_dup etc
+ my $lex = new LexFile $Dfile;
+ my %hh ;
+
+ ok 97, my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hh{'Wall'} = 'Larry' ;
+ $hh{'Wall'} = 'Stone' ; # Note the duplicate key
+ $hh{'Wall'} = 'Brick' ; # Note the duplicate key
+ $hh{'Smith'} = 'John' ;
+ $hh{'mouse'} = 'mickey' ;
+
+ # first work in scalar context
+ ok 98, scalar $YY->get_dup('Unknown') == 0 ;
+ ok 99, scalar $YY->get_dup('Smith') == 1 ;
+ ok 100, scalar $YY->get_dup('Wall') == 3 ;
+
+ # now in list context
+ my @unknown = $YY->get_dup('Unknown') ;
+ ok 101, "@unknown" eq "" ;
+
+ my @smith = $YY->get_dup('Smith') ;
+ ok 102, "@smith" eq "John" ;
+
+ {
+ my @wall = $YY->get_dup('Wall') ;
+ my %wall ;
+ @wall{@wall} = @wall ;
+ ok 103, (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'});
+ }
+
+ # hash
+ my %unknown = $YY->get_dup('Unknown', 1) ;
+ ok 104, keys %unknown == 0 ;
+
+ my %smith = $YY->get_dup('Smith', 1) ;
+ ok 105, keys %smith == 1 && $smith{'John'} ;
+
+ my %wall = $YY->get_dup('Wall', 1) ;
+ ok 106, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 1 ;
+
+ undef $YY ;
+ untie %hh ;
+
+}
+
+{
+ # in-memory file
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $fd ;
+ my $value ;
+ ok 107, my $db = tie %hash, 'BerkeleyDB::Btree' ;
+
+ ok 108, $db->db_put("some key", "some value") == 0 ;
+ ok 109, $db->db_get("some key", $value) == 0 ;
+ ok 110, $value eq "some value" ;
+
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ ok 111, my $db = new BerkeleyDB::Btree, -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok 112, $ret == 0 ;
+
+
+ # do a partial get
+ my ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok 113, ! $pon && $off == 0 && $len == 0 ;
+ ok 114, $db->db_get("red", $value) == 0 && $value eq "bo" ;
+ ok 115, $db->db_get("green", $value) == 0 && $value eq "ho" ;
+ ok 116, $db->db_get("blue", $value) == 0 && $value eq "se" ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok 117, $pon ;
+ ok 118, $off == 0 ;
+ ok 119, $len == 2 ;
+ ok 120, $db->db_get("red", $value) == 0 && $value eq "t" ;
+ ok 121, $db->db_get("green", $value) == 0 && $value eq "se" ;
+ ok 122, $db->db_get("blue", $value) == 0 && $value eq "" ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 123, $pon ;
+ ok 124, $off == 3 ;
+ ok 125, $len == 2 ;
+ ok 126, $db->db_get("red", $value) == 0 && $value eq "boat" ;
+ ok 127, $db->db_get("green", $value) == 0 && $value eq "house" ;
+ ok 128, $db->db_get("blue", $value) == 0 && $value eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok 129, $db->db_put("red", "") == 0 ;
+ ok 130, $db->db_put("green", "AB") == 0 ;
+ ok 131, $db->db_put("blue", "XYZ") == 0 ;
+ ok 132, $db->db_put("new", "KLM") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 133, $pon ;
+ ok 134, $off == 0 ;
+ ok 135, $len == 2 ;
+ ok 136, $db->db_get("red", $value) == 0 && $value eq "at" ;
+ ok 137, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
+ ok 138, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
+ ok 139, $db->db_get("new", $value) == 0 && $value eq "KLM" ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok 140, ! $pon ;
+ ok 141, $off == 0 ;
+ ok 142, $len == 0 ;
+ ok 143, $db->db_put("red", "PPP") == 0 ;
+ ok 144, $db->db_put("green", "Q") == 0 ;
+ ok 145, $db->db_put("blue", "XYZ") == 0 ;
+ ok 146, $db->db_put("new", "TU") == 0 ;
+
+ $db->partial_clear() ;
+ ok 147, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
+ ok 148, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
+ ok 149, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
+ ok 150, $db->db_get("new", $value) == 0 && $value eq "KLMTU" ;
+}
+
+{
+ # partial
+ # check works via tied hash
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+ ok 151, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ while (my ($k, $v) = each %data) {
+ $hash{$k} = $v ;
+ }
+
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok 152, $hash{"red"} eq "bo" ;
+ ok 153, $hash{"green"} eq "ho" ;
+ ok 154, $hash{"blue"} eq "se" ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok 155, $hash{"red"} eq "t" ;
+ ok 156, $hash{"green"} eq "se" ;
+ ok 157, $hash{"blue"} eq "" ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok 158, $hash{"red"} eq "boat" ;
+ ok 159, $hash{"green"} eq "house" ;
+ ok 160, $hash{"blue"} eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok 161, $hash{"red"} = "" ;
+ ok 162, $hash{"green"} = "AB" ;
+ ok 163, $hash{"blue"} = "XYZ" ;
+ ok 164, $hash{"new"} = "KLM" ;
+
+ $db->partial_clear() ;
+ ok 165, $hash{"red"} eq "at" ;
+ ok 166, $hash{"green"} eq "ABuse" ;
+ ok 167, $hash{"blue"} eq "XYZa" ;
+ ok 168, $hash{"new"} eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok 169, $hash{"red"} = "PPP" ;
+ ok 170, $hash{"green"} = "Q" ;
+ ok 171, $hash{"blue"} = "XYZ" ;
+ ok 172, $hash{"new"} = "TU" ;
+
+ $db->partial_clear() ;
+ ok 173, $hash{"red"} eq "at\0PPP" ;
+ ok 174, $hash{"green"} eq "ABuQ" ;
+ ok 175, $hash{"blue"} eq "XYZXYZ" ;
+ ok 176, $hash{"new"} eq "KLMTU" ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 177, my $lexD = new LexDir($home) ;
+ ok 178, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 179, my $txn = $env->txn_begin() ;
+ ok 180, my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok 181, (my $Z = $txn->txn_commit()) == 0 ;
+ ok 182, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok 183, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 184, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 185, $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ #ok 151, $txn->txn_abort() == 0 ;
+ ok 186, ($Z = $txn->txn_abort()) == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok 187, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 188, $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # DB_DUP
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok 189, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hash{'Wall'} = 'Larry' ;
+ $hash{'Wall'} = 'Stone' ;
+ $hash{'Smith'} = 'John' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'mouse'} = 'mickey' ;
+
+ ok 190, keys %hash == 6 ;
+
+ # create a cursor
+ ok 191, my $cursor = $db->db_cursor() ;
+
+ my $key = "Wall" ;
+ my $value ;
+ ok 192, $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok 193, $key eq "Wall" && $value eq "Larry" ;
+ ok 194, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 195, $key eq "Wall" && $value eq "Stone" ;
+ ok 196, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 197, $key eq "Wall" && $value eq "Brick" ;
+ ok 198, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 199, $key eq "Wall" && $value eq "Brick" ;
+
+ #my $ref = $db->db_stat() ;
+ #ok 200, ($ref->{bt_flags} | DB_DUP) == DB_DUP ;
+#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
+
+ undef $db ;
+ undef $cursor ;
+ untie %hash ;
+
+}
+
+{
+ # db_stat
+
+ my $lex = new LexFile $Dfile ;
+ my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
+ my %hash ;
+ my ($k, $v) ;
+ ok 200, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Minkey =>3 ,
+ -Pagesize => 2 **12
+ ;
+
+ my $ref = $db->db_stat() ;
+ ok 201, $ref->{$recs} == 0;
+ ok 202, $ref->{'bt_minkey'} == 3;
+ ok 203, $ref->{'bt_pagesize'} == 2 ** 12;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok 204, $ret == 0 ;
+
+ $ref = $db->db_stat() ;
+ ok 205, $ref->{$recs} == 3;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use BerkeleyDB;
+ @ISA=qw(BerkeleyDB::Btree);
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok 206, $@ eq "" ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB", -Filename => "dbbtree.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 );
+ ' ;
+
+ main::ok 207, $@ eq "" && $X ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok 208, $@ eq "" ;
+ main::ok 209, $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
+ main::ok 210, $@ eq "" ;
+ main::ok 211, $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ main::ok 212, $@ eq "" ;
+ main::ok 213, $ret == 1 ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok 214, $@ eq "" ;
+ main::ok 215, $ret eq "[[10]]" ;
+
+ undef $X;
+ untie %h;
+ unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
+{
+ # DB_RECNUM, DB_SET_RECNO & DB_GET_RECNO
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) = ("", "");
+ ok 216, my $db = new BerkeleyDB::Btree
+ -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Property => DB_RECNUM ;
+
+
+ # create some data
+ my @data = (
+ "A zero",
+ "B one",
+ "C two",
+ "D three",
+ "E four"
+ ) ;
+
+ my $ix = 0 ;
+ my $ret = 0 ;
+ foreach (@data) {
+ $ret += $db->db_put($_, $ix) ;
+ ++ $ix ;
+ }
+ ok 217, $ret == 0 ;
+
+ # db_get & DB_SET_RECNO
+ $k = 1 ;
+ ok 218, $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok 219, $k eq "B one" && $v == 1 ;
+
+ $k = 3 ;
+ ok 220, $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok 221, $k eq "D three" && $v == 3 ;
+
+ $k = 4 ;
+ ok 222, $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok 223, $k eq "E four" && $v == 4 ;
+
+ $k = 0 ;
+ ok 224, $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok 225, $k eq "A zero" && $v == 0 ;
+
+ # cursor & DB_SET_RECNO
+
+ # create the cursor
+ ok 226, my $cursor = $db->db_cursor() ;
+
+ $k = 2 ;
+ ok 227, $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok 228, $k eq "C two" && $v == 2 ;
+
+ $k = 0 ;
+ ok 229, $cursor->c_get($k, $v, DB_SET_RECNO) == 0;
+ ok 230, $k eq "A zero" && $v == 0 ;
+
+ $k = 3 ;
+ ok 231, $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok 232, $k eq "D three" && $v == 3 ;
+
+ # cursor & DB_GET_RECNO
+ ok 233, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
+ ok 234, $k eq "A zero" && $v == 0 ;
+ ok 235, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
+ ok 236, $v == 0 ;
+
+ ok 237, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok 238, $k eq "B one" && $v == 1 ;
+ ok 239, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
+ ok 240, $v == 1 ;
+
+ ok 241, $cursor->c_get($k, $v, DB_LAST) == 0 ;
+ ok 242, $k eq "E four" && $v == 4 ;
+ ok 243, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
+ ok 244, $v == 4 ;
+
+}
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/destroy.t b/storage/bdb/perl/BerkeleyDB/t/destroy.t
new file mode 100644
index 00000000000..7457d36c583
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/destroy.t
@@ -0,0 +1,105 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..15\n";
+
+my $Dfile = "dbhash.tmp";
+my $home = "./fred" ;
+
+umask(0);
+
+{
+ # let object destruction kill everything
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ ok 1, my $lexD = new LexDir($home) ;
+ ok 2, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 3, my $txn = $env->txn_begin() ;
+ ok 4, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok 5, $txn->txn_commit() == 0 ;
+ ok 6, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok 7, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 8, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 9, $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok 10, $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok 11, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 12, $count == 0 ;
+
+ #undef $txn ;
+ #undef $cursor ;
+ #undef $db1 ;
+ #undef $env ;
+ #untie %hash ;
+
+}
+
+{
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $cursor ;
+ my ($k, $v) = ("", "") ;
+ ok 13, my $db1 = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+ my $count = 0 ;
+ # sequence forwards
+ ok 14, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 15, $count == 0 ;
+}
+
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/env.t b/storage/bdb/perl/BerkeleyDB/t/env.t
new file mode 100644
index 00000000000..3905abfae43
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/env.t
@@ -0,0 +1,217 @@
+#!./perl -w
+
+# ID: 1.2, 7/17/97
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..47\n";
+
+my $Dfile = "dbhash.tmp";
+
+umask(0);
+
+{
+ # db version stuff
+ my ($major, $minor, $patch) = (0, 0, 0) ;
+
+ ok 1, my $VER = BerkeleyDB::DB_VERSION_STRING ;
+ ok 2, my $ver = BerkeleyDB::db_version($major, $minor, $patch) ;
+ ok 3, $VER eq $ver ;
+ ok 4, $major > 1 ;
+ ok 5, defined $minor ;
+ ok 6, defined $patch ;
+}
+
+{
+ # Check for invalid parameters
+ my $env ;
+ eval ' $env = new BerkeleyDB::Env( -Stupid => 3) ; ' ;
+ ok 7, $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $env = new BerkeleyDB::Env( -Bad => 2, -Home => "/tmp", -Stupid => 3) ; ' ;
+ ok 8, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ;
+
+ eval ' $env = new BerkeleyDB::Env (-Config => {"fred" => " "} ) ; ' ;
+ ok 9, !$env ;
+ ok 10, $BerkeleyDB::Error =~ /^illegal name-value pair/ ;
+}
+
+{
+ # create a very simple environment
+ my $home = "./fred" ;
+ ok 11, my $lexD = new LexDir($home) ;
+ chdir "./fred" ;
+ ok 12, my $env = new BerkeleyDB::Env -Flags => DB_CREATE ;
+ chdir ".." ;
+ undef $env ;
+}
+
+{
+ # create an environment with a Home
+ my $home = "./fred" ;
+ ok 13, my $lexD = new LexDir($home) ;
+ ok 14, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE ;
+
+ undef $env ;
+}
+
+{
+ # make new fail.
+ my $home = "./not_there" ;
+ rmtree $home ;
+ ok 15, ! -d $home ;
+ my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_INIT_LOCK ;
+ ok 16, ! $env ;
+ ok 17, $! != 0 || $^E != 0 ;
+
+ rmtree $home ;
+}
+
+{
+ # Config
+ use Cwd ;
+ my $cwd = cwd() ;
+ my $home = "$cwd/fred" ;
+ my $data_dir = "$home/data_dir" ;
+ my $log_dir = "$home/log_dir" ;
+ my $data_file = "data.db" ;
+ ok 18, my $lexD = new LexDir($home) ;
+ ok 19, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
+ ok 20, -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
+ my $env = new BerkeleyDB::Env -Home => $home,
+ -Config => { DB_DATA_DIR => $data_dir,
+ DB_LOG_DIR => $log_dir
+ },
+ -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 21, $env ;
+
+ ok 22, my $txn = $env->txn_begin() ;
+
+ my %hash ;
+ ok 23, tie %hash, 'BerkeleyDB::Hash', -Filename => $data_file,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ $hash{"abc"} = 123 ;
+ $hash{"def"} = 456 ;
+
+ $txn->txn_commit() ;
+
+ untie %hash ;
+
+ undef $txn ;
+ undef $env ;
+}
+
+{
+ # -ErrFile with a filename
+ my $errfile = "./errfile" ;
+ my $home = "./fred" ;
+ ok 24, my $lexD = new LexDir($home) ;
+ my $lex = new LexFile $errfile ;
+ ok 25, my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
+ -Flags => DB_CREATE,
+ -Home => $home) ;
+ my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => -1;
+ ok 26, !$db ;
+
+ ok 27, $BerkeleyDB::Error =~ /^illegal flag specified to (db_open|DB->open)/;
+ ok 28, -e $errfile ;
+ my $contents = docat($errfile) ;
+ chomp $contents ;
+ ok 29, $BerkeleyDB::Error eq $contents ;
+
+ undef $env ;
+}
+
+{
+ # -ErrFile with a filehandle/reference -- should fail
+ my $home = "./fred" ;
+ ok 30, my $lexD = new LexDir($home) ;
+ eval { my $env = new BerkeleyDB::Env( -ErrFile => [],
+ -Flags => DB_CREATE,
+ -Home => $home) ; };
+ ok 31, $@ =~ /ErrFile parameter must be a file name/;
+}
+
+{
+ # -ErrPrefix
+ use IO ;
+ my $home = "./fred" ;
+ ok 32, my $lexD = new LexDir($home) ;
+ my $errfile = "./errfile" ;
+ my $lex = new LexFile $errfile ;
+ ok 33, my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
+ -ErrPrefix => "PREFIX",
+ -Flags => DB_CREATE,
+ -Home => $home) ;
+ my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => -1;
+ ok 34, !$db ;
+
+ ok 35, $BerkeleyDB::Error =~ /^PREFIX: illegal flag specified to (db_open|DB->open)/;
+ ok 36, -e $errfile ;
+ my $contents = docat($errfile) ;
+ chomp $contents ;
+ ok 37, $BerkeleyDB::Error eq $contents ;
+
+ # change the prefix on the fly
+ my $old = $env->errPrefix("NEW ONE") ;
+ ok 38, $old eq "PREFIX" ;
+
+ $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => -1;
+ ok 39, !$db ;
+ ok 40, $BerkeleyDB::Error =~ /^NEW ONE: illegal flag specified to (db_open|DB->open)/;
+ $contents = docat($errfile) ;
+ chomp $contents ;
+ ok 41, $contents =~ /$BerkeleyDB::Error$/ ;
+ undef $env ;
+}
+
+{
+ # test db_appexit
+ use Cwd ;
+ my $cwd = cwd() ;
+ my $home = "$cwd/fred" ;
+ my $data_dir = "$home/data_dir" ;
+ my $log_dir = "$home/log_dir" ;
+ my $data_file = "data.db" ;
+ ok 42, my $lexD = new LexDir($home);
+ ok 43, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
+ ok 44, -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
+ my $env = new BerkeleyDB::Env -Home => $home,
+ -Config => { DB_DATA_DIR => $data_dir,
+ DB_LOG_DIR => $log_dir
+ },
+ -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 45, $env ;
+
+ ok 46, my $txn_mgr = $env->TxnMgr() ;
+
+ ok 47, $env->db_appexit() == 0 ;
+
+}
+
+# test -Verbose
+# test -Flags
+# db_value_set
diff --git a/storage/bdb/perl/BerkeleyDB/t/examples.t b/storage/bdb/perl/BerkeleyDB/t/examples.t
new file mode 100644
index 00000000000..69b7f8ff8c5
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/examples.t
@@ -0,0 +1,401 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util;
+
+print "1..7\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $x = $BerkeleyDB::Error;
+my $redirect = "xyzt" ;
+ {
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+ use vars qw( %h $k $v ) ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(1, docat_del($redirect) eq <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("apple", "red") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("banana", "yellow") ;
+ $db->db_put("tomato", "red") ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
+
+ # Delete a key/value pair.
+ $db->db_del("apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(2, docat_del($redirect) eq <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(3, docat_del($redirect) eq <<'EOM') ;
+Smith
+Wall
+mouse
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Compare => sub { lc $_[0] cmp lc $_[1] }
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(4, docat_del($redirect) eq <<'EOM') ;
+mouse
+Smith
+Wall
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+ my $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+ $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(5, docat_del($redirect) eq <<"EOM") ;
+abc\x00 -> def\x00
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+ $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot Open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ my $val = pack("i", 123) ;
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(6, docat_del($redirect) eq <<"EOM") ;
+$val -> def
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ if ($FA) {
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ untie @h ;
+ unlink $filename ;
+ } else {
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ my $db = tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ $db->push("green", "black") ;
+
+ my $elements = $db->length() ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = $db->pop ;
+ print "popped $last\n" ;
+
+ $db->unshift("white") ;
+ my $first = $db->shift ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ undef $db ;
+ untie @h ;
+ unlink $filename ;
+ }
+
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(7, docat_del($redirect) eq <<"EOM") ;
+The array contains 5 entries
+popped black
+shifted white
+Element 1 Exists with value blue
+EOM
+
+}
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/examples.t.T b/storage/bdb/perl/BerkeleyDB/t/examples.t.T
new file mode 100644
index 00000000000..fe9bdf76b06
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/examples.t.T
@@ -0,0 +1,415 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util;
+
+print "1..7\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $x = $BerkeleyDB::Error;
+my $redirect = "xyzt" ;
+ {
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN simpleHash
+ use strict ;
+ use BerkeleyDB ;
+ use vars qw( %h $k $v ) ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+## END simpleHash
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(1, docat_del($redirect) eq <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN simpleHash2
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("apple", "red") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("banana", "yellow") ;
+ $db->db_put("tomato", "red") ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
+
+ # Delete a key/value pair.
+ $db->db_del("apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+## END simpleHash2
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(2, docat_del($redirect) eq <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN btreeSimple
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+## END btreeSimple
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(3, docat_del($redirect) eq <<'EOM') ;
+Smith
+Wall
+mouse
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN btreeSortOrder
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Compare => sub { lc $_[0] cmp lc $_[1] }
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+## END btreeSortOrder
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(4, docat_del($redirect) eq <<'EOM') ;
+mouse
+Smith
+Wall
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN nullFilter
+ use strict ;
+ use BerkeleyDB ;
+
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+ my $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+## END nullFilter
+ $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(5, docat_del($redirect) eq <<"EOM") ;
+abc\x00 -> def\x00
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN intFilter
+ use strict ;
+ use BerkeleyDB ;
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+## END intFilter
+ $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot Open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ my $val = pack("i", 123) ;
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(6, docat_del($redirect) eq <<"EOM") ;
+$val -> def
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ if ($FA) {
+## BEGIN simpleRecno
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ untie @h ;
+## END simpleRecno
+ unlink $filename ;
+ } else {
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ my $db = tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ $db->push("green", "black") ;
+
+ my $elements = $db->length() ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = $db->pop ;
+ print "popped $last\n" ;
+
+ $db->unshift("white") ;
+ my $first = $db->shift ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ undef $db ;
+ untie @h ;
+ unlink $filename ;
+ }
+
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ ok(7, docat_del($redirect) eq <<"EOM") ;
+The array contains 5 entries
+popped black
+shifted white
+Element 1 Exists with value blue
+EOM
+
+}
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/examples3.t b/storage/bdb/perl/BerkeleyDB/t/examples3.t
new file mode 100644
index 00000000000..22e94b770e1
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/examples3.t
@@ -0,0 +1,132 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util;
+
+BEGIN
+{
+ if ($BerkeleyDB::db_version < 3) {
+ print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ;
+ exit 0 ;
+ }
+}
+
+
+print "1..2\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(1, docat_del($redirect) eq <<'EOM') ;
+orange -> orange
+yellow -> banana
+red -> apple
+red -> tomato
+green -> banana
+green -> apple
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP | DB_DUPSORT
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(2, docat_del($redirect) eq <<'EOM') ;
+orange -> orange
+yellow -> banana
+red -> apple
+red -> tomato
+green -> apple
+green -> banana
+EOM
+
+}
+
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/examples3.t.T b/storage/bdb/perl/BerkeleyDB/t/examples3.t.T
new file mode 100644
index 00000000000..5eeaa14d00c
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/examples3.t.T
@@ -0,0 +1,136 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util;
+
+BEGIN
+{
+ if ($BerkeleyDB::db_version < 3) {
+ print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ;
+ exit 0 ;
+ }
+}
+
+
+print "1..2\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN dupHash
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+## END dupHash
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(1, docat_del($redirect) eq <<'EOM') ;
+orange -> orange
+yellow -> banana
+red -> apple
+red -> tomato
+green -> banana
+green -> apple
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN dupSortHash
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP | DB_DUPSORT
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+## END dupSortHash
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ ok(2, docat_del($redirect) eq <<'EOM') ;
+orange -> orange
+yellow -> banana
+red -> apple
+red -> tomato
+green -> apple
+green -> banana
+EOM
+
+}
+
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/filter.t b/storage/bdb/perl/BerkeleyDB/t/filter.t
new file mode 100644
index 00000000000..47a7c107acf
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/filter.t
@@ -0,0 +1,217 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..46\n";
+
+my $Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok 1, $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok 2, checkOutput( "", "fred", "", "joe") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 3, $h{"fred"} eq "joe";
+ # fk sk fv sv
+ ok 4, checkOutput( "", "fred", "joe", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 5, $db->FIRSTKEY() eq "fred" ;
+ # fk sk fv sv
+ ok 6, checkOutput( "fred", "", "", "") ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok 7, checkOutput( "", "fred", "", "Jxe") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 8, $h{"Fred"} eq "[Jxe]";
+ # fk sk fv sv
+ ok 9, checkOutput( "", "fred", "[Jxe]", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 10, $db->FIRSTKEY() eq "FRED" ;
+ # fk sk fv sv
+ ok 11, checkOutput( "FRED", "", "", "") ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok 12, checkOutput( "", "fred", "", "joe") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 13, $h{"fred"} eq "joe";
+ ok 14, checkOutput( "", "fred", "joe", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 15, $db->FIRSTKEY() eq "fred" ;
+ ok 16, checkOutput( "fred", "", "", "") ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok 17, checkOutput( "", "", "", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 18, $h{"fred"} eq "joe";
+ ok 19, checkOutput( "", "", "", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok 20, $db->FIRSTKEY() eq "fred" ;
+ ok 21, checkOutput( "", "", "", "") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok 22, $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok 23, $result{"store key"} eq "store key - 1: [fred]" ;
+ ok 24, $result{"store value"} eq "store value - 1: [joe]" ;
+ ok 25, ! defined $result{"fetch key"} ;
+ ok 26, ! defined $result{"fetch value"} ;
+ ok 27, $_ eq "original" ;
+
+ ok 28, $db->FIRSTKEY() eq "fred" ;
+ ok 29, $result{"store key"} eq "store key - 1: [fred]" ;
+ ok 30, $result{"store value"} eq "store value - 1: [joe]" ;
+ ok 31, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
+ ok 32, ! defined $result{"fetch value"} ;
+ ok 33, $_ eq "original" ;
+
+ $h{"jim"} = "john" ;
+ ok 34, $result{"store key"} eq "store key - 2: [fred jim]" ;
+ ok 35, $result{"store value"} eq "store value - 2: [joe john]" ;
+ ok 36, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
+ ok 37, ! defined $result{"fetch value"} ;
+ ok 38, $_ eq "original" ;
+
+ ok 39, $h{"fred"} eq "joe" ;
+ ok 40, $result{"store key"} eq "store key - 3: [fred jim fred]" ;
+ ok 41, $result{"store value"} eq "store value - 2: [joe john]" ;
+ ok 42, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
+ ok 43, $result{"fetch value"} eq "fetch value - 1: [joe]" ;
+ ok 44, $_ eq "original" ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok 45, $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok 46, $@ =~ /^BerkeleyDB Aborting: recursion detected in filter_store_key at/ ;
+ #print "[$@]\n" ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/hash.t b/storage/bdb/perl/BerkeleyDB/t/hash.t
new file mode 100644
index 00000000000..0e683851c3d
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/hash.t
@@ -0,0 +1,728 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..212\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Hash -Stupid => 3 ; ' ;
+ ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Hash -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ;
+
+ eval ' $db = new BerkeleyDB::Hash -Env => 2 ' ;
+ ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Hash -Txn => "fred" ' ;
+ ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Hash -Env => $obj ' ;
+ ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to HASH
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ ok 7, $db->db_put("some key", "some value") == 0 ;
+ ok 8, $db->status() == 0 ;
+ ok 9, $db->db_get("some key", $value) == 0 ;
+ ok 10, $value eq "some value" ;
+ ok 11, $db->db_put("key", "value") == 0 ;
+ ok 12, $db->db_get("key", $value) == 0 ;
+ ok 13, $value eq "value" ;
+ ok 14, $db->db_del("some key") == 0 ;
+ ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ;
+ ok 16, $status eq $DB_errors{'DB_NOTFOUND'} ;
+ ok 17, $db->status() == DB_NOTFOUND ;
+ ok 18, $db->status() eq $DB_errors{'DB_NOTFOUND'};
+
+ ok 19, $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok 20, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok 21, $db->status() eq $DB_errors{'DB_KEYEXIST'};
+ ok 22, $db->status() == DB_KEYEXIST ;
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok 23, $db->db_get("key", $value) == 0 ;
+ ok 24, $value eq "value" ;
+
+ # test DB_GET_BOTH
+ my ($k, $v) = ("key", "value") ;
+ ok 25, $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("key", "fred") ;
+ ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("another", "value") ;
+ ok 27, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+
+}
+
+{
+ # Check simple env works with a hash.
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok 28, my $lexD = new LexDir($home);
+
+ ok 29, my $env = new BerkeleyDB::Env -Flags => DB_CREATE| DB_INIT_MPOOL,
+ -Home => $home ;
+ ok 30, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ ok 31, $db->db_put("some key", "some value") == 0 ;
+ ok 32, $db->db_get("some key", $value) == 0 ;
+ ok 33, $value eq "some value" ;
+ undef $db ;
+ undef $env ;
+}
+
+{
+ # override default hash
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ $::count = 0 ;
+ ok 34, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Hash => sub { ++$::count ; length $_[0] },
+ -Flags => DB_CREATE ;
+
+ ok 35, $db->db_put("some key", "some value") == 0 ;
+ ok 36, $db->db_get("some key", $value) == 0 ;
+ ok 37, $value eq "some value" ;
+ ok 38, $::count > 0 ;
+
+}
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok 39, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok 40, $ret == 0 ;
+
+ # create the cursor
+ ok 41, my $cursor = $db->db_cursor() ;
+
+ $k = $v = "" ;
+ my %copy = %data ;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok 42, $cursor->status() == DB_NOTFOUND ;
+ ok 43, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
+ ok 44, keys %copy == 0 ;
+ ok 45, $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok 46, $status == DB_NOTFOUND ;
+ ok 47, $status eq $DB_errors{'DB_NOTFOUND'} ;
+ ok 48, $cursor->status() == $status ;
+ ok 49, $cursor->status() eq $status ;
+ ok 50, keys %copy == 0 ;
+ ok 51, $extras == 0 ;
+
+ ($k, $v) = ("green", "house") ;
+ ok 52, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("green", "door") ;
+ ok 53, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("black", "house") ;
+ ok 54, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+}
+
+{
+ # Tied Hash interface
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok 55, tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # check "each" with an empty database
+ my $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ ++ $count ;
+ }
+ ok 56, (tied %hash)->status() == DB_NOTFOUND ;
+ ok 57, $count == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $hash{"some key"} = "some value";
+ ok 58, (tied %hash)->status() == 0 ;
+ ok 59, $hash{"some key"} eq "some value";
+ ok 60, defined $hash{"some key"} ;
+ ok 61, (tied %hash)->status() == 0 ;
+ ok 62, exists $hash{"some key"} ;
+ ok 63, !defined $hash{"jimmy"} ;
+ ok 64, (tied %hash)->status() == DB_NOTFOUND ;
+ ok 65, !exists $hash{"jimmy"} ;
+ ok 66, (tied %hash)->status() == DB_NOTFOUND ;
+
+ delete $hash{"some key"} ;
+ ok 67, (tied %hash)->status() == 0 ;
+ ok 68, ! defined $hash{"some key"} ;
+ ok 69, (tied %hash)->status() == DB_NOTFOUND ;
+ ok 70, ! exists $hash{"some key"} ;
+ ok 71, (tied %hash)->status() == DB_NOTFOUND ;
+
+ $hash{1} = 2 ;
+ $hash{10} = 20 ;
+ $hash{1000} = 2000 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok 72, $count == 3 ;
+ ok 73, $keys == 1011 ;
+ ok 74, $values == 2022 ;
+
+ # now clear the hash
+ %hash = () ;
+ ok 75, keys %hash == 0 ;
+
+ untie %hash ;
+}
+
+{
+ # in-memory file
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $fd ;
+ my $value ;
+ ok 76, my $db = tie %hash, 'BerkeleyDB::Hash' ;
+
+ ok 77, $db->db_put("some key", "some value") == 0 ;
+ ok 78, $db->db_get("some key", $value) == 0 ;
+ ok 79, $value eq "some value" ;
+
+ undef $db ;
+ untie %hash ;
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+ ok 80, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok 81, $ret == 0 ;
+
+
+ # do a partial get
+ my($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok 82, $pon == 0 && $off == 0 && $len == 0 ;
+ ok 83, ( $db->db_get("red", $value) == 0) && $value eq "bo" ;
+ ok 84, ( $db->db_get("green", $value) == 0) && $value eq "ho" ;
+ ok 85, ( $db->db_get("blue", $value) == 0) && $value eq "se" ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok 86, $pon ;
+ ok 87, $off == 0 ;
+ ok 88, $len == 2 ;
+ ok 89, $db->db_get("red", $value) == 0 && $value eq "t" ;
+ ok 90, $db->db_get("green", $value) == 0 && $value eq "se" ;
+ ok 91, $db->db_get("blue", $value) == 0 && $value eq "" ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 92, $pon ;
+ ok 93, $off == 3 ;
+ ok 94, $len == 2 ;
+ ok 95, $db->db_get("red", $value) == 0 && $value eq "boat" ;
+ ok 96, $db->db_get("green", $value) == 0 && $value eq "house" ;
+ ok 97, $db->db_get("blue", $value) == 0 && $value eq "sea" ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok 98, ! $pon ;
+ ok 99, $off == 0 ;
+ ok 100, $len == 0 ;
+ ok 101, $db->db_put("red", "") == 0 ;
+ ok 102, $db->db_put("green", "AB") == 0 ;
+ ok 103, $db->db_put("blue", "XYZ") == 0 ;
+ ok 104, $db->db_put("new", "KLM") == 0 ;
+
+ $db->partial_clear() ;
+ ok 105, $db->db_get("red", $value) == 0 && $value eq "at" ;
+ ok 106, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
+ ok 107, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
+ ok 108, $db->db_get("new", $value) == 0 && $value eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok 109, $db->db_put("red", "PPP") == 0 ;
+ ok 110, $db->db_put("green", "Q") == 0 ;
+ ok 111, $db->db_put("blue", "XYZ") == 0 ;
+ ok 112, $db->db_put("new", "--") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 113, $pon ;
+ ok 114, $off == 3 ;
+ ok 115, $len == 2 ;
+ ok 116, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
+ ok 117, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
+ ok 118, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
+ ok 119, $db->db_get("new", $value) == 0 && $value eq "KLM--" ;
+}
+
+{
+ # partial
+ # check works via tied hash
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+ ok 120, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ while (my ($k, $v) = each %data) {
+ $hash{$k} = $v ;
+ }
+
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok 121, $hash{"red"} eq "bo" ;
+ ok 122, $hash{"green"} eq "ho" ;
+ ok 123, $hash{"blue"} eq "se" ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok 124, $hash{"red"} eq "t" ;
+ ok 125, $hash{"green"} eq "se" ;
+ ok 126, $hash{"blue"} eq "" ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok 127, $hash{"red"} eq "boat" ;
+ ok 128, $hash{"green"} eq "house" ;
+ ok 129, $hash{"blue"} eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok 130, $hash{"red"} = "" ;
+ ok 131, $hash{"green"} = "AB" ;
+ ok 132, $hash{"blue"} = "XYZ" ;
+ ok 133, $hash{"new"} = "KLM" ;
+
+ $db->partial_clear() ;
+ ok 134, $hash{"red"} eq "at" ;
+ ok 135, $hash{"green"} eq "ABuse" ;
+ ok 136, $hash{"blue"} eq "XYZa" ;
+ ok 137, $hash{"new"} eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok 138, $hash{"red"} = "PPP" ;
+ ok 139, $hash{"green"} = "Q" ;
+ ok 140, $hash{"blue"} = "XYZ" ;
+ ok 141, $hash{"new"} = "TU" ;
+
+ $db->partial_clear() ;
+ ok 142, $hash{"red"} eq "at\0PPP" ;
+ ok 143, $hash{"green"} eq "ABuQ" ;
+ ok 144, $hash{"blue"} eq "XYZXYZ" ;
+ ok 145, $hash{"new"} eq "KLMTU" ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 146, my $lexD = new LexDir($home);
+ ok 147, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 148, my $txn = $env->txn_begin() ;
+ ok 149, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok 150, $txn->txn_commit() == 0 ;
+ ok 151, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok 152, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 153, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 154, $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok 155, $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok 156, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 157, $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+
+{
+ # DB_DUP
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok 158, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hash{'Wall'} = 'Larry' ;
+ $hash{'Wall'} = 'Stone' ;
+ $hash{'Smith'} = 'John' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'mouse'} = 'mickey' ;
+
+ ok 159, keys %hash == 6 ;
+
+ # create a cursor
+ ok 160, my $cursor = $db->db_cursor() ;
+
+ my $key = "Wall" ;
+ my $value ;
+ ok 161, $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok 162, $key eq "Wall" && $value eq "Larry" ;
+ ok 163, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 164, $key eq "Wall" && $value eq "Stone" ;
+ ok 165, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 166, $key eq "Wall" && $value eq "Brick" ;
+ ok 167, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 168, $key eq "Wall" && $value eq "Brick" ;
+
+ #my $ref = $db->db_stat() ;
+ #ok 143, $ref->{bt_flags} | DB_DUP ;
+
+ # test DB_DUP_NEXT
+ my ($k, $v) = ("Wall", "") ;
+ ok 169, $cursor->c_get($k, $v, DB_SET) == 0 ;
+ ok 170, $k eq "Wall" && $v eq "Larry" ;
+ ok 171, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok 172, $k eq "Wall" && $v eq "Stone" ;
+ ok 173, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok 174, $k eq "Wall" && $v eq "Brick" ;
+ ok 175, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok 176, $k eq "Wall" && $v eq "Brick" ;
+ ok 177, $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
+
+
+ undef $db ;
+ undef $cursor ;
+ untie %hash ;
+
+}
+
+{
+ # DB_DUP & DupCompare
+ my $lex = new LexFile $Dfile, $Dfile2;
+ my ($key, $value) ;
+ my (%h, %g) ;
+ my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
+ my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
+
+ ok 178, tie %h, "BerkeleyDB::Hash", -Filename => $Dfile,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Flags => DB_CREATE ;
+
+ ok 179, tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2,
+ -DupCompare => sub { $_[0] <=> $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Flags => DB_CREATE ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ my $value = shift @Values ;
+ $h{$_} = $value ;
+ $g{$_} = $value ;
+ }
+
+ ok 180, my $cursor = (tied %h)->db_cursor() ;
+ $key = 9 ; $value = "";
+ ok 181, $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok 182, $key == 9 && $value eq 11 ;
+ ok 183, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 184, $key == 9 && $value == 2 ;
+ ok 185, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 186, $key == 9 && $value eq "x" ;
+
+ $cursor = (tied %g)->db_cursor() ;
+ $key = 9 ;
+ ok 187, $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok 188, $key == 9 && $value eq "x" ;
+ ok 189, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 190, $key == 9 && $value == 2 ;
+ ok 191, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok 192, $key == 9 && $value == 11 ;
+
+
+}
+
+{
+ # get_dup etc
+ my $lex = new LexFile $Dfile;
+ my %hh ;
+
+ ok 193, my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hh{'Wall'} = 'Larry' ;
+ $hh{'Wall'} = 'Stone' ; # Note the duplicate key
+ $hh{'Wall'} = 'Brick' ; # Note the duplicate key
+ $hh{'Smith'} = 'John' ;
+ $hh{'mouse'} = 'mickey' ;
+
+ # first work in scalar context
+ ok 194, scalar $YY->get_dup('Unknown') == 0 ;
+ ok 195, scalar $YY->get_dup('Smith') == 1 ;
+ ok 196, scalar $YY->get_dup('Wall') == 3 ;
+
+ # now in list context
+ my @unknown = $YY->get_dup('Unknown') ;
+ ok 197, "@unknown" eq "" ;
+
+ my @smith = $YY->get_dup('Smith') ;
+ ok 198, "@smith" eq "John" ;
+
+ {
+ my @wall = $YY->get_dup('Wall') ;
+ my %wall ;
+ @wall{@wall} = @wall ;
+ ok 199, (@wall == 3 && $wall{'Larry'}
+ && $wall{'Stone'} && $wall{'Brick'});
+ }
+
+ # hash
+ my %unknown = $YY->get_dup('Unknown', 1) ;
+ ok 200, keys %unknown == 0 ;
+
+ my %smith = $YY->get_dup('Smith', 1) ;
+ ok 201, keys %smith == 1 && $smith{'John'} ;
+
+ my %wall = $YY->get_dup('Wall', 1) ;
+ ok 202, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 1 ;
+
+ undef $YY ;
+ untie %hh ;
+
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use BerkeleyDB;
+ @ISA=qw(BerkeleyDB::Hash);
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok 203, $@ eq "" ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB", -Filename => "dbhash.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 );
+ ' ;
+
+ main::ok 204, $@ eq "" ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok 205, $@ eq "" ;
+ main::ok 206, $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
+ main::ok 207, $@ eq "" ;
+ main::ok 208, $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ main::ok 209, $@ eq "" ;
+ main::ok 210, $ret == 1 ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok 211, $@ eq "" ;
+ main::ok 212, $ret eq "[[10]]" ;
+
+ unlink "SubDB.pm", "dbhash.tmp" ;
+
+}
diff --git a/storage/bdb/perl/BerkeleyDB/t/join.t b/storage/bdb/perl/BerkeleyDB/t/join.t
new file mode 100644
index 00000000000..ed9b6a269cb
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/join.t
@@ -0,0 +1,225 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+if ($BerkeleyDB::db_ver < 2.005002)
+{
+ print "1..0 # Skip: join needs Berkeley DB 2.5.2 or later\n" ;
+ exit 0 ;
+}
+
+
+print "1..37\n";
+
+my $Dfile1 = "dbhash1.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile1, $Dfile2, $Dfile3 ;
+
+umask(0) ;
+
+{
+ # error cases
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash1 ;
+ my $value ;
+ my $status ;
+ my $cursor ;
+
+ ok 1, my $db1 = tie %hash1, 'BerkeleyDB::Hash',
+ -Filename => $Dfile1,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] lt $_[1] },
+ -Property => DB_DUP|DB_DUPSORT ;
+
+ # no cursors supplied
+ eval '$cursor = $db1->db_join() ;' ;
+ ok 2, $@ =~ /Usage: \$db->BerkeleyDB::Common::db_join\Q([cursors], flags=0)/;
+
+ # empty list
+ eval '$cursor = $db1->db_join([]) ;' ;
+ ok 3, $@ =~ /db_join: No cursors in parameter list/;
+
+ # cursor list, isn't a []
+ eval '$cursor = $db1->db_join({}) ;' ;
+ ok 4, $@ =~ /cursors is not an array reference at/ ;
+
+ eval '$cursor = $db1->db_join(\1) ;' ;
+ ok 5, $@ =~ /cursors is not an array reference at/ ;
+
+}
+
+{
+ # test a 2-way & 3-way join
+
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash1 ;
+ my %hash2 ;
+ my %hash3 ;
+ my $value ;
+ my $status ;
+
+ my $home = "./fred" ;
+ ok 6, my $lexD = new LexDir($home);
+ ok 7, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN
+ |DB_INIT_MPOOL;
+ #|DB_INIT_MPOOL| DB_INIT_LOCK;
+ ok 8, my $txn = $env->txn_begin() ;
+ ok 9, my $db1 = tie %hash1, 'BerkeleyDB::Hash',
+ -Filename => $Dfile1,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Env => $env,
+ -Txn => $txn ;
+ ;
+
+ ok 10, my $db2 = tie %hash2, 'BerkeleyDB::Hash',
+ -Filename => $Dfile2,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok 11, my $db3 = tie %hash3, 'BerkeleyDB::Btree',
+ -Filename => $Dfile3,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok 12, addData($db1, qw( apple Convenience
+ peach Shopway
+ pear Farmer
+ raspberry Shopway
+ strawberry Shopway
+ gooseberry Farmer
+ blueberry Farmer
+ ));
+
+ ok 13, addData($db2, qw( red apple
+ red raspberry
+ red strawberry
+ yellow peach
+ yellow pear
+ green gooseberry
+ blue blueberry)) ;
+
+ ok 14, addData($db3, qw( expensive apple
+ reasonable raspberry
+ expensive strawberry
+ reasonable peach
+ reasonable pear
+ expensive gooseberry
+ reasonable blueberry)) ;
+
+ ok 15, my $cursor2 = $db2->db_cursor() ;
+ my $k = "red" ;
+ my $v = "" ;
+ ok 16, $cursor2->c_get($k, $v, DB_SET) == 0 ;
+
+ # Two way Join
+ ok 17, my $cursor1 = $db1->db_join([$cursor2]) ;
+
+ my %expected = qw( apple Convenience
+ raspberry Shopway
+ strawberry Shopway
+ ) ;
+
+ # sequence forwards
+ while ($cursor1->c_get($k, $v) == 0) {
+ delete $expected{$k}
+ if defined $expected{$k} && $expected{$k} eq $v ;
+ #print "[$k] [$v]\n" ;
+ }
+ ok 18, keys %expected == 0 ;
+ ok 19, $cursor1->status() == DB_NOTFOUND ;
+
+ # Three way Join
+ ok 20, $cursor2 = $db2->db_cursor() ;
+ $k = "red" ;
+ $v = "" ;
+ ok 21, $cursor2->c_get($k, $v, DB_SET) == 0 ;
+
+ ok 22, my $cursor3 = $db3->db_cursor() ;
+ $k = "expensive" ;
+ $v = "" ;
+ ok 23, $cursor3->c_get($k, $v, DB_SET) == 0 ;
+ ok 24, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
+
+ %expected = qw( apple Convenience
+ strawberry Shopway
+ ) ;
+
+ # sequence forwards
+ while ($cursor1->c_get($k, $v) == 0) {
+ delete $expected{$k}
+ if defined $expected{$k} && $expected{$k} eq $v ;
+ #print "[$k] [$v]\n" ;
+ }
+ ok 25, keys %expected == 0 ;
+ ok 26, $cursor1->status() == DB_NOTFOUND ;
+
+ # test DB_JOIN_ITEM
+ # #################
+ ok 27, $cursor2 = $db2->db_cursor() ;
+ $k = "red" ;
+ $v = "" ;
+ ok 28, $cursor2->c_get($k, $v, DB_SET) == 0 ;
+
+ ok 29, $cursor3 = $db3->db_cursor() ;
+ $k = "expensive" ;
+ $v = "" ;
+ ok 30, $cursor3->c_get($k, $v, DB_SET) == 0 ;
+ ok 31, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
+
+ %expected = qw( apple 1
+ strawberry 1
+ ) ;
+
+ # sequence forwards
+ $k = "" ;
+ $v = "" ;
+ while ($cursor1->c_get($k, $v, DB_JOIN_ITEM) == 0) {
+ delete $expected{$k}
+ if defined $expected{$k} ;
+ #print "[$k]\n" ;
+ }
+ ok 32, keys %expected == 0 ;
+ ok 33, $cursor1->status() == DB_NOTFOUND ;
+
+ ok 34, $cursor1->c_close() == 0 ;
+ ok 35, $cursor2->c_close() == 0 ;
+ ok 36, $cursor3->c_close() == 0 ;
+
+ ok 37, ($status = $txn->txn_commit) == 0;
+
+ undef $txn ;
+ #undef $cursor1;
+ #undef $cursor2;
+ #undef $cursor3;
+ undef $db1 ;
+ undef $db2 ;
+ undef $db3 ;
+ undef $env ;
+ untie %hash1 ;
+ untie %hash2 ;
+ untie %hash3 ;
+}
+print "# at the end\n";
diff --git a/storage/bdb/perl/BerkeleyDB/t/mldbm.t b/storage/bdb/perl/BerkeleyDB/t/mldbm.t
new file mode 100644
index 00000000000..d35f7e15895
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/mldbm.t
@@ -0,0 +1,161 @@
+#!/usr/bin/perl -w
+
+use strict ;
+
+BEGIN
+{
+ if ($] < 5.005) {
+ print "1..0 # This is Perl $], skipping test\n" ;
+ exit 0 ;
+ }
+
+ eval { require Data::Dumper ; };
+ if ($@) {
+ print "1..0 # Data::Dumper is not installed on this system.\n";
+ exit 0 ;
+ }
+ if ($Data::Dumper::VERSION < 2.08) {
+ print "1..0 # Data::Dumper 2.08 or better required (found $Data::Dumper::VERSION).\n";
+ exit 0 ;
+ }
+ eval { require MLDBM ; };
+ if ($@) {
+ print "1..0 # MLDBM is not installed on this system.\n";
+ exit 0 ;
+ }
+}
+
+use t::util ;
+
+print "1..12\n";
+
+{
+ package BTREE ;
+
+ use BerkeleyDB ;
+ use MLDBM qw(BerkeleyDB::Btree) ;
+ use Data::Dumper;
+
+ my $filename = "";
+ my $lex = new LexFile $filename;
+
+ $MLDBM::UseDB = "BerkeleyDB::Btree" ;
+ my %o ;
+ my $db = tie %o, 'MLDBM', -Filename => $filename,
+ -Flags => DB_CREATE
+ or die $!;
+ ::ok 1, $db ;
+ ::ok 2, $db->type() == DB_BTREE ;
+
+ my $c = [\'c'];
+ my $b = {};
+ my $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+ @o{qw(a b c)} = ($a, $b, $c);
+ $o{d} = "{once upon a time}";
+ $o{e} = 1024;
+ $o{f} = 1024.1024;
+ my $first = Data::Dumper->new([@o{qw(a b c)}], [qw(a b c)])->Quotekeys(0)->Dump;
+ my $second = <<'EOT';
+$a = [
+ 1,
+ {
+ a => $a,
+ b => $a->[1],
+ c => [
+ \'c'
+ ]
+ },
+ $a->[1]{c}
+ ];
+$b = {
+ a => [
+ 1,
+ $b,
+ [
+ \'c'
+ ]
+ ],
+ b => $b,
+ c => $b->{a}[2]
+ };
+$c = [
+ \'c'
+ ];
+EOT
+
+ ::ok 3, $first eq $second ;
+ ::ok 4, $o{d} eq "{once upon a time}" ;
+ ::ok 5, $o{e} == 1024 ;
+ ::ok 6, $o{f} eq 1024.1024 ;
+
+}
+
+{
+
+ package HASH ;
+
+ use BerkeleyDB ;
+ use MLDBM qw(BerkeleyDB::Hash) ;
+ use Data::Dumper;
+
+ my $filename = "";
+ my $lex = new LexFile $filename;
+
+ unlink $filename ;
+ $MLDBM::UseDB = "BerkeleyDB::Hash" ;
+ my %o ;
+ my $db = tie %o, 'MLDBM', -Filename => $filename,
+ -Flags => DB_CREATE
+ or die $!;
+ ::ok 7, $db ;
+ ::ok 8, $db->type() == DB_HASH ;
+
+
+ my $c = [\'c'];
+ my $b = {};
+ my $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+ @o{qw(a b c)} = ($a, $b, $c);
+ $o{d} = "{once upon a time}";
+ $o{e} = 1024;
+ $o{f} = 1024.1024;
+ my $first = Data::Dumper->new([@o{qw(a b c)}], [qw(a b c)])->Quotekeys(0)->Dump;
+ my $second = <<'EOT';
+$a = [
+ 1,
+ {
+ a => $a,
+ b => $a->[1],
+ c => [
+ \'c'
+ ]
+ },
+ $a->[1]{c}
+ ];
+$b = {
+ a => [
+ 1,
+ $b,
+ [
+ \'c'
+ ]
+ ],
+ b => $b,
+ c => $b->{a}[2]
+ };
+$c = [
+ \'c'
+ ];
+EOT
+
+ ::ok 9, $first eq $second ;
+ ::ok 10, $o{d} eq "{once upon a time}" ;
+ ::ok 11, $o{e} == 1024 ;
+ ::ok 12, $o{f} eq 1024.1024 ;
+
+}
diff --git a/storage/bdb/perl/BerkeleyDB/t/queue.t b/storage/bdb/perl/BerkeleyDB/t/queue.t
new file mode 100644
index 00000000000..86add129ca4
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/queue.t
@@ -0,0 +1,763 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+BEGIN
+{
+ if ($BerkeleyDB::db_version < 3.3) {
+ print "1..0 # Skipping test, Queue needs Berkeley DB 3.3.x or better\n" ;
+ exit 0 ;
+ }
+}
+
+print "1..201\n";
+
+sub fillout
+{
+ my $var = shift ;
+ my $length = shift ;
+ my $pad = shift || " " ;
+ my $template = $pad x $length ;
+ substr($template, 0, length($var)) = $var ;
+ return $template ;
+}
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Queue -Stupid => 3 ; ' ;
+ ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok 2, $@ =~ /unknown key value\(s\) / ;
+
+ eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ;
+ ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ;
+ ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ;
+ ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to Queue
+
+{
+ my $lex = new LexFile $Dfile ;
+ my $rec_len = 10 ;
+ my $pad = "x" ;
+
+ ok 6, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Len => $rec_len,
+ -Pad => $pad;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ ok 7, $db->db_put(1, "some value") == 0 ;
+ ok 8, $db->status() == 0 ;
+ ok 9, $db->db_get(1, $value) == 0 ;
+ ok 10, $value eq fillout("some value", $rec_len, $pad) ;
+ ok 11, $db->db_put(2, "value") == 0 ;
+ ok 12, $db->db_get(2, $value) == 0 ;
+ ok 13, $value eq fillout("value", $rec_len, $pad) ;
+ ok 14, $db->db_del(1) == 0 ;
+ ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
+ ok 16, $db->status() == DB_KEYEMPTY ;
+ ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
+
+ ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ;
+ ok 19, $db->status() == DB_NOTFOUND ;
+ ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
+
+ ok 21, $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
+ ok 24, $db->status() == DB_KEYEXIST ;
+
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok 25, $db->db_get(2, $value) == 0 ;
+ ok 26, $value eq fillout("value", $rec_len, $pad) ;
+
+
+}
+
+
+{
+ # Check simple env works with a array.
+ # and pad defaults to space
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ my $rec_len = 11 ;
+ ok 27, my $lexD = new LexDir($home);
+
+ ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
+ -Home => $home ;
+ ok 29, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE,
+ -Len => $rec_len;
+
+ # Add a k/v pair
+ my $value ;
+ ok 30, $db->db_put(1, "some value") == 0 ;
+ ok 31, $db->db_get(1, $value) == 0 ;
+ ok 32, $value eq fillout("some value", $rec_len) ;
+ undef $db ;
+ undef $env ;
+}
+
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my ($k, $v) ;
+ my $rec_len = 5 ;
+ ok 33, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len;
+
+ # create some data
+ my @data = (
+ "red" ,
+ "green" ,
+ "blue" ,
+ ) ;
+
+ my $i ;
+ my %data ;
+ my $ret = 0 ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db->db_put($i, $data[$i]) ;
+ $data{$i} = $data[$i] ;
+ }
+ ok 34, $ret == 0 ;
+
+ # create the cursor
+ ok 35, my $cursor = $db->db_cursor() ;
+
+ $k = 0 ; $v = "" ;
+ my %copy = %data;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ {
+ if ( fillout($copy{$k}, $rec_len) eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+
+ ok 36, $cursor->status() == DB_NOTFOUND ;
+ ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
+ ok 38, keys %copy == 0 ;
+ ok 39, $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( fillout($copy{$k}, $rec_len) eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok 40, $status == DB_NOTFOUND ;
+ ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
+ ok 42, $cursor->status() == $status ;
+ ok 43, $cursor->status() eq $status ;
+ ok 44, keys %copy == 0 ;
+ ok 45, $extras == 0 ;
+}
+
+{
+ # Tied Array interface
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ my $rec_len = 10 ;
+ ok 46, $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len;
+
+ ok 47, my $cursor = (tied @array)->db_cursor() ;
+ # check the database is empty
+ my $count = 0 ;
+ my ($k, $v) = (0,"") ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 48, $cursor->status() == DB_NOTFOUND ;
+ ok 49, $count == 0 ;
+
+ ok 50, @array == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $array[1] = "some value";
+ ok 51, (tied @array)->status() == 0 ;
+ ok 52, $array[1] eq fillout("some value", $rec_len);
+ ok 53, defined $array[1];
+ ok 54, (tied @array)->status() == 0 ;
+ ok 55, !defined $array[3];
+ ok 56, (tied @array)->status() == DB_NOTFOUND ;
+
+ ok 57, (tied @array)->db_del(1) == 0 ;
+ ok 58, (tied @array)->status() == 0 ;
+ ok 59, ! defined $array[1];
+ ok 60, (tied @array)->status() == DB_KEYEMPTY ;
+
+ $array[1] = 2 ;
+ $array[10] = 20 ;
+ $array[1000] = 2000 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok 61, $count == 3 ;
+ ok 62, $keys == 1011 ;
+ ok 63, $values == 2022 ;
+
+ # unshift isn't allowed
+# eval {
+# $FA ? unshift @array, "red", "green", "blue"
+# : $db->unshift("red", "green", "blue" ) ;
+# } ;
+# ok 64, $@ =~ /^unshift is unsupported with Queue databases/ ;
+ $array[0] = "red" ;
+ $array[1] = "green" ;
+ $array[2] = "blue" ;
+ $array[4] = 2 ;
+ ok 64, $array[0] eq fillout("red", $rec_len) ;
+ ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
+ ok 66, $k == 0 ;
+ ok 67, $v eq fillout("red", $rec_len) ;
+ ok 68, $array[1] eq fillout("green", $rec_len) ;
+ ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok 70, $k == 1 ;
+ ok 71, $v eq fillout("green", $rec_len) ;
+ ok 72, $array[2] eq fillout("blue", $rec_len) ;
+ ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok 74, $k == 2 ;
+ ok 75, $v eq fillout("blue", $rec_len) ;
+ ok 76, $array[4] == 2 ;
+ ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok 78, $k == 4 ;
+ ok 79, $v == 2 ;
+
+ # shift
+ ok 80, ($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len) ;
+ ok 81, ($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len) ;
+ ok 82, ($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len) ;
+ ok 83, ($FA ? shift @array : $db->shift()) == 2 ;
+
+ # push
+ $FA ? push @array, "the", "end"
+ : $db->push("the", "end") ;
+ ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
+ ok 85, $k == 1002 ;
+ ok 86, $v eq fillout("end", $rec_len) ;
+ ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok 88, $k == 1001 ;
+ ok 89, $v eq fillout("the", $rec_len) ;
+ ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok 91, $k == 1000 ;
+ ok 92, $v == 2000 ;
+
+ # pop
+ ok 93, ( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len) ;
+ ok 94, ( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len) ;
+ ok 95, ( $FA ? pop @array : $db->pop ) == 2000 ;
+
+ # now clear the array
+ $FA ? @array = ()
+ : $db->clear() ;
+ ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
+
+ undef $cursor ;
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # in-memory file
+
+ my @array ;
+ my $fd ;
+ my $value ;
+ my $rec_len = 15 ;
+ ok 97, my $db = tie @array, 'BerkeleyDB::Queue',
+ -Len => $rec_len;
+
+ ok 98, $db->db_put(1, "some value") == 0 ;
+ ok 99, $db->db_get(1, $value) == 0 ;
+ ok 100, $value eq fillout("some value", $rec_len) ;
+
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ my $rec_len = 8 ;
+ ok 101, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ my $r = $db->db_put($i, $data[$i]) ;
+ $ret += $r ;
+ }
+ ok 102, $ret == 0 ;
+
+ # do a partial get
+ my ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok 103, ! $pon && $off == 0 && $len == 0 ;
+ ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
+ ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
+ ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok 107, $pon ;
+ ok 108, $off == 0 ;
+ ok 109, $len == 2 ;
+ ok 110, $db->db_get(1, $value) == 0 && $value eq fillout("t", 2) ;
+ ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
+ ok 112, $db->db_get(3, $value) == 0 && $value eq " " ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 113, $pon ;
+ ok 114, $off == 3 ;
+ ok 115, $len == 2 ;
+ ok 116, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
+ ok 117, $db->db_get(2, $value) == 0 && $value eq fillout("house", $rec_len) ;
+ ok 118, $db->db_get(3, $value) == 0 && $value eq fillout("sea", $rec_len) ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok 119, $db->db_put(1, "") != 0 ;
+ ok 120, $db->db_put(2, "AB") == 0 ;
+ ok 121, $db->db_put(3, "XY") == 0 ;
+ ok 122, $db->db_put(4, "KLM") != 0 ;
+ ok 123, $db->db_put(4, "KL") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 124, $pon ;
+ ok 125, $off == 0 ;
+ ok 126, $len == 2 ;
+ ok 127, $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
+ ok 128, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse", $rec_len) ;
+ ok 129, $db->db_get(3, $value) == 0 && $value eq fillout("XYa", $rec_len) ;
+ ok 130, $db->db_get(4, $value) == 0 && $value eq fillout("KL", $rec_len) ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok 131, ! $pon ;
+ ok 132, $off == 0 ;
+ ok 133, $len == 0 ;
+ ok 134, $db->db_put(1, "PP") == 0 ;
+ ok 135, $db->db_put(2, "Q") != 0 ;
+ ok 136, $db->db_put(3, "XY") == 0 ;
+ ok 137, $db->db_put(4, "TU") == 0 ;
+
+ $db->partial_clear() ;
+ ok 138, $db->db_get(1, $value) == 0 && $value eq fillout("boaPP", $rec_len) ;
+ ok 139, $db->db_get(2, $value) == 0 && $value eq fillout("ABuse",$rec_len) ;
+ ok 140, $db->db_get(3, $value) == 0 && $value eq fillout("XYaXY", $rec_len) ;
+ ok 141, $db->db_get(4, $value) == 0 && $value eq fillout("KL TU", $rec_len) ;
+}
+
+{
+ # partial
+ # check works via tied array
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+ my $rec_len = 8 ;
+ ok 142, my $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $i ;
+ my $status = 0 ;
+ for ($i = 1 ; $i < @data ; ++$i) {
+ $array[$i] = $data[$i] ;
+ $status += $db->status() ;
+ }
+
+ ok 143, $status == 0 ;
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok 144, $array[1] eq fillout("bo", 2) ;
+ ok 145, $array[2] eq fillout("ho", 2) ;
+ ok 146, $array[3] eq fillout("se", 2) ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok 147, $array[1] eq fillout("t", 2) ;
+ ok 148, $array[2] eq fillout("se", 2) ;
+ ok 149, $array[3] eq fillout("", 2) ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok 150, $array[1] eq fillout("boat", $rec_len) ;
+ ok 151, $array[2] eq fillout("house", $rec_len) ;
+ ok 152, $array[3] eq fillout("sea", $rec_len) ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ $array[1] = "" ;
+ ok 153, $db->status() != 0 ;
+ $array[2] = "AB" ;
+ ok 154, $db->status() == 0 ;
+ $array[3] = "XY" ;
+ ok 155, $db->status() == 0 ;
+ $array[4] = "KL" ;
+ ok 156, $db->status() == 0 ;
+
+ $db->partial_clear() ;
+ ok 157, $array[1] eq fillout("boat", $rec_len) ;
+ ok 158, $array[2] eq fillout("ABuse", $rec_len) ;
+ ok 159, $array[3] eq fillout("XYa", $rec_len) ;
+ ok 160, $array[4] eq fillout("KL", $rec_len) ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ $array[1] = "PP" ;
+ ok 161, $db->status() == 0 ;
+ $array[2] = "Q" ;
+ ok 162, $db->status() != 0 ;
+ $array[3] = "XY" ;
+ ok 163, $db->status() == 0 ;
+ $array[4] = "TU" ;
+ ok 164, $db->status() == 0 ;
+
+ $db->partial_clear() ;
+ ok 165, $array[1] eq fillout("boaPP", $rec_len) ;
+ ok 166, $array[2] eq fillout("ABuse", $rec_len) ;
+ ok 167, $array[3] eq fillout("XYaXY", $rec_len) ;
+ ok 168, $array[4] eq fillout("KL TU", $rec_len) ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 169, my $lexD = new LexDir($home);
+ my $rec_len = 9 ;
+ ok 170, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 171, my $txn = $env->txn_begin() ;
+ ok 172, my $db1 = tie @array, 'BerkeleyDB::Queue',
+ -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+
+ ok 173, $txn->txn_commit() == 0 ;
+ ok 174, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my @data = (
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db1->db_put($i, $data[$i]) ;
+ }
+ ok 175, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 176, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = (0, "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 177, $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok 178, $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok 179, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 180, $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie @array ;
+}
+
+
+{
+ # db_stat
+
+ my $lex = new LexFile $Dfile ;
+ my $recs = ($BerkeleyDB::db_version >= 3.1 ? "qs_ndata" : "qs_nrecs") ;
+ my @array ;
+ my ($k, $v) ;
+ my $rec_len = 7 ;
+ ok 181, my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Pagesize => 4 * 1024,
+ -Len => $rec_len,
+ -Pad => " "
+ ;
+
+ my $ref = $db->db_stat() ;
+ ok 182, $ref->{$recs} == 0;
+ ok 183, $ref->{'qs_pagesize'} == 4 * 1024;
+
+ # create some data
+ my @data = (
+ 2,
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = $db->ArrayOffset ; @data ; ++$i) {
+ $ret += $db->db_put($i, shift @data) ;
+ }
+ ok 184, $ret == 0 ;
+
+ $ref = $db->db_stat() ;
+ ok 185, $ref->{$recs} == 3;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use BerkeleyDB;
+ @ISA=qw(BerkeleyDB::Queue);
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok 186, $@ eq "" ;
+ my @h ;
+ my $X ;
+ my $rec_len = 34 ;
+ eval '
+ $X = tie(@h, "SubDB", -Filename => "dbqueue.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 ,
+ -Len => $rec_len,
+ -Pad => " "
+ );
+ ' ;
+
+ main::ok 187, $@ eq "" ;
+
+ my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
+ main::ok 188, $@ eq "" ;
+ main::ok 189, $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
+ main::ok 190, $@ eq "" ;
+ main::ok 191, $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ main::ok 192, $@ eq "" ;
+ main::ok 193, $ret == 1 ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ main::ok 194, $@ eq "" ;
+ main::ok 195, $ret eq "[[10]]" ;
+
+ undef $X ;
+ untie @h ;
+ unlink "SubDB.pm", "dbqueue.tmp" ;
+
+}
+
+{
+ # DB_APPEND
+
+ my $lex = new LexFile $Dfile;
+ my @array ;
+ my $value ;
+ my $rec_len = 21 ;
+ ok 196, my $db = tie @array, 'BerkeleyDB::Queue',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+ # create a few records
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+
+ my $k = 0 ;
+ ok 197, $db->db_put($k, "fred", DB_APPEND) == 0 ;
+ ok 198, $k == 4 ;
+ ok 199, $array[4] eq fillout("fred", $rec_len) ;
+
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # 23 Sept 2001 -- push into an empty array
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ my $rec_len = 21 ;
+ ok 200, $db = tie @array, 'BerkeleyDB::Queue',
+ -Flags => DB_CREATE ,
+ -ArrayBase => 0,
+ -Len => $rec_len,
+ -Pad => " " ,
+ -Filename => $Dfile ;
+ $FA ? push @array, "first"
+ : $db->push("first") ;
+
+ ok 201, ($FA ? pop @array : $db->pop()) eq fillout("first", $rec_len) ;
+
+ undef $db;
+ untie @array ;
+
+}
+
+__END__
+
+
+# TODO
+#
+# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records
diff --git a/storage/bdb/perl/BerkeleyDB/t/recno.t b/storage/bdb/perl/BerkeleyDB/t/recno.t
new file mode 100644
index 00000000000..64b1803f736
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/recno.t
@@ -0,0 +1,913 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..226\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Recno -Stupid => 3 ; ' ;
+ ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Recno -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok 2, $@ =~ /unknown key value\(s\) / ;
+
+ eval ' $db = new BerkeleyDB::Recno -Env => 2 ' ;
+ ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Recno -Txn => "x" ' ;
+ ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Recno -Env => $obj ' ;
+ ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to Recno
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ ok 6, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ ok 7, $db->db_put(1, "some value") == 0 ;
+ ok 8, $db->status() == 0 ;
+ ok 9, $db->db_get(1, $value) == 0 ;
+ ok 10, $value eq "some value" ;
+ ok 11, $db->db_put(2, "value") == 0 ;
+ ok 12, $db->db_get(2, $value) == 0 ;
+ ok 13, $value eq "value" ;
+ ok 14, $db->db_del(1) == 0 ;
+ ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
+ ok 16, $db->status() == DB_KEYEMPTY ;
+ ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
+
+ ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ;
+ ok 19, $db->status() == DB_NOTFOUND ;
+ ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
+
+ ok 21, $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
+ ok 24, $db->status() == DB_KEYEXIST ;
+
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok 25, $db->db_get(2, $value) == 0 ;
+ ok 26, $value eq "value" ;
+
+
+}
+
+
+{
+ # Check simple env works with a array.
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok 27, my $lexD = new LexDir($home);
+
+ ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
+ -Home => $home ;
+
+ ok 29, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ ok 30, $db->db_put(1, "some value") == 0 ;
+ ok 31, $db->db_get(1, $value) == 0 ;
+ ok 32, $value eq "some value" ;
+ undef $db ;
+ undef $env ;
+}
+
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my ($k, $v) ;
+ ok 33, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my @data = (
+ "red" ,
+ "green" ,
+ "blue" ,
+ ) ;
+
+ my $i ;
+ my %data ;
+ my $ret = 0 ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db->db_put($i, $data[$i]) ;
+ $data{$i} = $data[$i] ;
+ }
+ ok 34, $ret == 0 ;
+
+ # create the cursor
+ ok 35, my $cursor = $db->db_cursor() ;
+
+ $k = 0 ; $v = "" ;
+ my %copy = %data;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+
+ ok 36, $cursor->status() == DB_NOTFOUND ;
+ ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
+ ok 38, keys %copy == 0 ;
+ ok 39, $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok 40, $status == DB_NOTFOUND ;
+ ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
+ ok 42, $cursor->status() == $status ;
+ ok 43, $cursor->status() eq $status ;
+ ok 44, keys %copy == 0 ;
+ ok 45, $extras == 0 ;
+}
+
+{
+ # Tied Array interface
+
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ ok 46, $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -Property => DB_RENUMBER,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ;
+
+ ok 47, my $cursor = (tied @array)->db_cursor() ;
+ # check the database is empty
+ my $count = 0 ;
+ my ($k, $v) = (0,"") ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 48, $cursor->status() == DB_NOTFOUND ;
+ ok 49, $count == 0 ;
+
+ ok 50, @array == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $array[1] = "some value";
+ ok 51, (tied @array)->status() == 0 ;
+ ok 52, $array[1] eq "some value";
+ ok 53, defined $array[1];
+ ok 54, (tied @array)->status() == 0 ;
+ ok 55, !defined $array[3];
+ ok 56, (tied @array)->status() == DB_NOTFOUND ;
+
+ ok 57, (tied @array)->db_del(1) == 0 ;
+ ok 58, (tied @array)->status() == 0 ;
+ ok 59, ! defined $array[1];
+ ok 60, (tied @array)->status() == DB_NOTFOUND ;
+
+ $array[1] = 2 ;
+ $array[10] = 20 ;
+ $array[1000] = 2000 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok 61, $count == 3 ;
+ ok 62, $keys == 1011 ;
+ ok 63, $values == 2022 ;
+
+ # unshift
+ $FA ? unshift @array, "red", "green", "blue"
+ : $db->unshift("red", "green", "blue" ) ;
+ ok 64, $array[1] eq "red" ;
+ ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
+ ok 66, $k == 1 ;
+ ok 67, $v eq "red" ;
+ ok 68, $array[2] eq "green" ;
+ ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok 70, $k == 2 ;
+ ok 71, $v eq "green" ;
+ ok 72, $array[3] eq "blue" ;
+ ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok 74, $k == 3 ;
+ ok 75, $v eq "blue" ;
+ ok 76, $array[4] == 2 ;
+ ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok 78, $k == 4 ;
+ ok 79, $v == 2 ;
+
+ # shift
+ ok 80, ($FA ? shift @array : $db->shift()) eq "red" ;
+ ok 81, ($FA ? shift @array : $db->shift()) eq "green" ;
+ ok 82, ($FA ? shift @array : $db->shift()) eq "blue" ;
+ ok 83, ($FA ? shift @array : $db->shift()) == 2 ;
+
+ # push
+ $FA ? push @array, "the", "end"
+ : $db->push("the", "end") ;
+ ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
+ ok 85, $k == 1001 ;
+ ok 86, $v eq "end" ;
+ ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok 88, $k == 1000 ;
+ ok 89, $v eq "the" ;
+ ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok 91, $k == 999 ;
+ ok 92, $v == 2000 ;
+
+ # pop
+ ok 93, ( $FA ? pop @array : $db->pop ) eq "end" ;
+ ok 94, ( $FA ? pop @array : $db->pop ) eq "the" ;
+ ok 95, ( $FA ? pop @array : $db->pop ) == 2000 ;
+
+ # now clear the array
+ $FA ? @array = ()
+ : $db->clear() ;
+ ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
+
+ undef $cursor ;
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # in-memory file
+
+ my @array ;
+ my $fd ;
+ my $value ;
+ ok 97, my $db = tie @array, 'BerkeleyDB::Recno' ;
+
+ ok 98, $db->db_put(1, "some value") == 0 ;
+ ok 99, $db->db_get(1, $value) == 0 ;
+ ok 100, $value eq "some value" ;
+
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ ok 101, my $db = new BerkeleyDB::Recno, -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 1 ; $i < @data ; ++$i) {
+ $ret += $db->db_put($i, $data[$i]) ;
+ }
+ ok 102, $ret == 0 ;
+
+
+ # do a partial get
+ my ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok 103, ! $pon && $off == 0 && $len == 0 ;
+ ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
+ ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
+ ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok 107, $pon ;
+ ok 108, $off == 0 ;
+ ok 109, $len == 2 ;
+ ok 110, $db->db_get(1, $value) == 0 && $value eq "t" ;
+ ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
+ ok 112, $db->db_get(3, $value) == 0 && $value eq "" ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 113, $pon ;
+ ok 114, $off == 3 ;
+ ok 115, $len == 2 ;
+ ok 116, $db->db_get(1, $value) == 0 && $value eq "boat" ;
+ ok 117, $db->db_get(2, $value) == 0 && $value eq "house" ;
+ ok 118, $db->db_get(3, $value) == 0 && $value eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok 119, $db->db_put(1, "") == 0 ;
+ ok 120, $db->db_put(2, "AB") == 0 ;
+ ok 121, $db->db_put(3, "XYZ") == 0 ;
+ ok 122, $db->db_put(4, "KLM") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok 123, $pon ;
+ ok 124, $off == 0 ;
+ ok 125, $len == 2 ;
+ ok 126, $db->db_get(1, $value) == 0 && $value eq "at" ;
+ ok 127, $db->db_get(2, $value) == 0 && $value eq "ABuse" ;
+ ok 128, $db->db_get(3, $value) == 0 && $value eq "XYZa" ;
+ ok 129, $db->db_get(4, $value) == 0 && $value eq "KLM" ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok 130, ! $pon ;
+ ok 131, $off == 0 ;
+ ok 132, $len == 0 ;
+ ok 133, $db->db_put(1, "PPP") == 0 ;
+ ok 134, $db->db_put(2, "Q") == 0 ;
+ ok 135, $db->db_put(3, "XYZ") == 0 ;
+ ok 136, $db->db_put(4, "TU") == 0 ;
+
+ $db->partial_clear() ;
+ ok 137, $db->db_get(1, $value) == 0 && $value eq "at\0PPP" ;
+ ok 138, $db->db_get(2, $value) == 0 && $value eq "ABuQ" ;
+ ok 139, $db->db_get(3, $value) == 0 && $value eq "XYZXYZ" ;
+ ok 140, $db->db_get(4, $value) == 0 && $value eq "KLMTU" ;
+}
+
+{
+ # partial
+ # check works via tied array
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+ ok 141, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $i ;
+ for ($i = 1 ; $i < @data ; ++$i) {
+ $array[$i] = $data[$i] ;
+ }
+
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok 142, $array[1] eq "bo" ;
+ ok 143, $array[2] eq "ho" ;
+ ok 144, $array[3] eq "se" ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok 145, $array[1] eq "t" ;
+ ok 146, $array[2] eq "se" ;
+ ok 147, $array[3] eq "" ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok 148, $array[1] eq "boat" ;
+ ok 149, $array[2] eq "house" ;
+ ok 150, $array[3] eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok 151, $array[1] = "" ;
+ ok 152, $array[2] = "AB" ;
+ ok 153, $array[3] = "XYZ" ;
+ ok 154, $array[4] = "KLM" ;
+
+ $db->partial_clear() ;
+ ok 155, $array[1] eq "at" ;
+ ok 156, $array[2] eq "ABuse" ;
+ ok 157, $array[3] eq "XYZa" ;
+ ok 158, $array[4] eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok 159, $array[1] = "PPP" ;
+ ok 160, $array[2] = "Q" ;
+ ok 161, $array[3] = "XYZ" ;
+ ok 162, $array[4] = "TU" ;
+
+ $db->partial_clear() ;
+ ok 163, $array[1] eq "at\0PPP" ;
+ ok 164, $array[2] eq "ABuQ" ;
+ ok 165, $array[3] eq "XYZXYZ" ;
+ ok 166, $array[4] eq "KLMTU" ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 167, my $lexD = new LexDir($home);
+ ok 168, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 169, my $txn = $env->txn_begin() ;
+ ok 170, my $db1 = tie @array, 'BerkeleyDB::Recno',
+ -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok 171, $txn->txn_commit() == 0 ;
+ ok 172, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my @data = (
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db1->db_put($i, $data[$i]) ;
+ }
+ ok 173, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 174, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = (0, "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 175, $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok 176, $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok 177, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 178, $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie @array ;
+}
+
+
+{
+ # db_stat
+
+ my $lex = new LexFile $Dfile ;
+ my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
+ my @array ;
+ my ($k, $v) ;
+ ok 179, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Pagesize => 4 * 1024,
+ ;
+
+ my $ref = $db->db_stat() ;
+ ok 180, $ref->{$recs} == 0;
+ ok 181, $ref->{'bt_pagesize'} == 4 * 1024;
+
+ # create some data
+ my @data = (
+ 2,
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = $db->ArrayOffset ; @data ; ++$i) {
+ $ret += $db->db_put($i, shift @data) ;
+ }
+ ok 182, $ret == 0 ;
+
+ $ref = $db->db_stat() ;
+ ok 183, $ref->{$recs} == 3;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use BerkeleyDB;
+ @ISA=qw(BerkeleyDB::Recno);
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok 184, $@ eq "" ;
+ my @h ;
+ my $X ;
+ eval '
+ $X = tie(@h, "SubDB", -Filename => "dbrecno.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 );
+ ' ;
+
+ main::ok 185, $@ eq "" ;
+
+ my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
+ main::ok 186, $@ eq "" ;
+ main::ok 187, $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
+ main::ok 188, $@ eq "" ;
+ main::ok 189, $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ main::ok 190, $@ eq "" ;
+ main::ok 191, $ret == 1 ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ main::ok 192, $@ eq "" ;
+ main::ok 193, $ret eq "[[10]]" ;
+
+ undef $X;
+ untie @h;
+ unlink "SubDB.pm", "dbrecno.tmp" ;
+
+}
+
+{
+ # variable length records, DB_DELIMETER -- defaults to \n
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 194, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 195, $x eq "abc\ndef\n\nghi\n" ;
+}
+
+{
+ # variable length records, change DB_DELIMETER
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 196, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Source => $Dfile2 ,
+ -Delim => "-";
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 197, $x eq "abc-def--ghi-";
+}
+
+{
+ # fixed length records, default DB_PAD
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 198, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => 5,
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 199, $x eq "abc def ghi " ;
+}
+
+{
+ # fixed length records, change Pad
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 200, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => 5,
+ -Pad => "-",
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 201, $x eq "abc--def-------ghi--" ;
+}
+
+{
+ # DB_RENUMBER
+
+ my $lex = new LexFile $Dfile;
+ my @array ;
+ my $value ;
+ ok 202, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -Property => DB_RENUMBER,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ;
+ # create a few records
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+
+ ok 203, my ($length, $joined) = joiner($db, "|") ;
+ ok 204, $length == 3 ;
+ ok 205, $joined eq "abc|def|ghi";
+
+ ok 206, $db->db_del(1) == 0 ;
+ ok 207, ($length, $joined) = joiner($db, "|") ;
+ ok 208, $length == 2 ;
+ ok 209, $joined eq "abc|ghi";
+
+ undef $db ;
+ untie @array ;
+
+}
+
+{
+ # DB_APPEND
+
+ my $lex = new LexFile $Dfile;
+ my @array ;
+ my $value ;
+ ok 210, my $db = tie @array, 'BerkeleyDB::Recno',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create a few records
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+
+ my $k = 0 ;
+ ok 211, $db->db_put($k, "fred", DB_APPEND) == 0 ;
+ ok 212, $k == 4 ;
+
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # in-memory Btree with an associated text file
+
+ my $lex = new LexFile $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 213, tie @array, 'BerkeleyDB::Recno', -Source => $Dfile2 ,
+ -ArrayBase => 0,
+ -Property => DB_RENUMBER,
+ -Flags => DB_CREATE ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 214, $x eq "abc\ndef\n\nghi\n" ;
+}
+
+{
+ # in-memory, variable length records, change DB_DELIMETER
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 215, tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Source => $Dfile2 ,
+ -Property => DB_RENUMBER,
+ -Delim => "-";
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 216, $x eq "abc-def--ghi-";
+}
+
+{
+ # in-memory, fixed length records, default DB_PAD
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 217, tie @array, 'BerkeleyDB::Recno', -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Len => 5,
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 218, $x eq "abc def ghi " ;
+}
+
+{
+ # in-memory, fixed length records, change Pad
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok 219, tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Len => 5,
+ -Pad => "-",
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok 220, $x eq "abc--def-------ghi--" ;
+}
+
+{
+ # 23 Sept 2001 -- push into an empty array
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ ok 221, $db = tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Filename => $Dfile ;
+ $FA ? push @array, "first"
+ : $db->push("first") ;
+
+ ok 222, $array[0] eq "first" ;
+ ok 223, $FA ? pop @array : $db->pop() eq "first" ;
+
+ undef $db;
+ untie @array ;
+
+}
+
+{
+ # 23 Sept 2001 -- unshift into an empty array
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ ok 224, $db = tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Filename => $Dfile ;
+ $FA ? unshift @array, "first"
+ : $db->unshift("first") ;
+
+ ok 225, $array[0] eq "first" ;
+ ok 226, ($FA ? shift @array : $db->shift()) eq "first" ;
+
+ undef $db;
+ untie @array ;
+
+}
+__END__
+
+
+# TODO
+#
+# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records
diff --git a/storage/bdb/perl/BerkeleyDB/t/strict.t b/storage/bdb/perl/BerkeleyDB/t/strict.t
new file mode 100644
index 00000000000..ab41d44cb41
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/strict.t
@@ -0,0 +1,174 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..44\n";
+
+my $Dfile = "dbhash.tmp";
+my $home = "./fred" ;
+
+umask(0);
+
+{
+ # closing a database & an environment in the correct order.
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+
+ ok 1, my $lexD = new LexDir($home);
+ ok 2, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok 3, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env;
+
+ ok 4, $db1->db_close() == 0 ;
+
+ eval { $status = $env->db_appexit() ; } ;
+ ok 5, $status == 0 ;
+ ok 6, $@ eq "" ;
+ #print "[$@]\n" ;
+
+}
+
+{
+ # closing an environment with an open database
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+
+ ok 7, my $lexD = new LexDir($home);
+ ok 8, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok 9, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env;
+
+ eval { $env->db_appexit() ; } ;
+ ok 10, $@ =~ /BerkeleyDB Aborting: attempted to close an environment with 1 open database/ ;
+ #print "[$@]\n" ;
+
+ undef $db1 ;
+ untie %hash ;
+ undef $env ;
+}
+
+{
+ # closing a transaction & a database
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+
+ ok 11, my $lexD = new LexDir($home);
+ ok 12, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok 13, my $txn = $env->txn_begin() ;
+ ok 14, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok 15, $txn->txn_commit() == 0 ;
+ eval { $status = $db->db_close() ; } ;
+ ok 16, $status == 0 ;
+ ok 17, $@ eq "" ;
+ #print "[$@]\n" ;
+ eval { $status = $env->db_appexit() ; } ;
+ ok 18, $status == 0 ;
+ ok 19, $@ eq "" ;
+ #print "[$@]\n" ;
+}
+
+{
+ # closing a database with an open transaction
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+
+ ok 20, my $lexD = new LexDir($home);
+ ok 21, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok 22, my $txn = $env->txn_begin() ;
+ ok 23, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ eval { $db->db_close() ; } ;
+ ok 24, $@ =~ /BerkeleyDB Aborting: attempted to close a database while a transaction was still open at/ ;
+ #print "[$@]\n" ;
+}
+
+{
+ # closing a cursor & a database
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+ ok 25, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+ ok 26, my $cursor = $db->db_cursor() ;
+ ok 27, $cursor->c_close() == 0 ;
+ eval { $status = $db->db_close() ; } ;
+ ok 28, $status == 0 ;
+ ok 29, $@ eq "" ;
+ #print "[$@]\n" ;
+}
+
+{
+ # closing a database with an open cursor
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok 30, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+ ok 31, my $cursor = $db->db_cursor() ;
+ eval { $db->db_close() ; } ;
+ ok 32, $@ =~ /\QBerkeleyDB Aborting: attempted to close a database with 1 open cursor(s) at/;
+ #print "[$@]\n" ;
+}
+
+{
+ # closing a transaction & a cursor
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+
+ ok 33, my $lexD = new LexDir($home);
+ ok 34, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 35, my $txn = $env->txn_begin() ;
+ ok 36, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+ ok 37, my $cursor = $db->db_cursor() ;
+ eval { $status = $cursor->c_close() ; } ;
+ ok 38, $status == 0 ;
+ ok 39, ($status = $txn->txn_commit()) == 0 ;
+ ok 40, $@ eq "" ;
+ eval { $status = $db->db_close() ; } ;
+ ok 41, $status == 0 ;
+ ok 42, $@ eq "" ;
+ #print "[$@]\n" ;
+ eval { $status = $env->db_appexit() ; } ;
+ ok 43, $status == 0 ;
+ ok 44, $@ eq "" ;
+ #print "[$@]\n" ;
+}
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/subdb.t b/storage/bdb/perl/BerkeleyDB/t/subdb.t
new file mode 100644
index 00000000000..23016d6463f
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/subdb.t
@@ -0,0 +1,243 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+BEGIN
+{
+ if ($BerkeleyDB::db_version < 3) {
+ print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ;
+ exit 0 ;
+ }
+}
+
+print "1..43\n";
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+# Berkeley DB 3.x specific functionality
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' BerkeleyDB::db_remove -Stupid => 3 ; ' ;
+ ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' BerkeleyDB::db_remove -Bad => 2, -Filename => "fred", -Stupid => 3; ' ;
+ ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ;
+
+ eval ' BerkeleyDB::db_remove -Filename => "a", -Env => 2 ' ;
+ ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' BerkeleyDB::db_remove -Subname => "a"' ;
+ ok 4, $@ =~ /^Must specify a filename/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' BerkeleyDB::db_remove -Filename => "x", -Env => $obj ' ;
+ ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+{
+ # subdatabases
+
+ # opening a subdatabse in an exsiting database that doesn't have
+ # subdatabases at all should fail
+
+ my $lex = new LexFile $Dfile ;
+
+ ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok 7, addData($db, %data) ;
+
+ undef $db ;
+
+ $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ;
+ ok 8, ! $db ;
+
+ ok 9, -e $Dfile ;
+ ok 10, ! BerkeleyDB::db_remove(-Filename => $Dfile) ;
+}
+
+{
+ # subdatabases
+
+ # opening a subdatabse in an exsiting database that does have
+ # subdatabases at all, but not this one
+
+ my $lex = new LexFile $Dfile ;
+
+ ok 11, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok 12, addData($db, %data) ;
+
+ undef $db ;
+
+ $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "joe" ;
+
+ ok 13, !$db ;
+
+}
+
+{
+ # subdatabases
+
+ my $lex = new LexFile $Dfile ;
+
+ ok 14, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok 15, addData($db, %data) ;
+
+ undef $db ;
+
+ ok 16, $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ;
+
+ ok 17, my $cursor = $db->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $status ;
+ while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) {
+ if ($data{$k} eq $v) {
+ delete $data{$k} ;
+ }
+ }
+ ok 18, $status == DB_NOTFOUND ;
+ ok 19, keys %data == 0 ;
+}
+
+{
+ # subdatabases
+
+ # opening a database with multiple subdatabases - handle should be a list
+ # of the subdatabase names
+
+ my $lex = new LexFile $Dfile ;
+
+ ok 20, my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+
+ ok 21, my $db2 = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Subname => "joe" ,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok 22, addData($db1, %data) ;
+ ok 23, addData($db2, %data) ;
+
+ undef $db1 ;
+ undef $db2 ;
+
+ ok 24, my $db = new BerkeleyDB::Unknown -Filename => $Dfile ,
+ -Flags => DB_RDONLY ;
+
+ #my $type = $db->type() ; print "type $type\n" ;
+ ok 25, my $cursor = $db->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $status ;
+ my @dbnames = () ;
+ while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) {
+ push @dbnames, $k ;
+ }
+ ok 26, $status == DB_NOTFOUND ;
+ ok 27, join(",", sort @dbnames) eq "fred,joe" ;
+ undef $db ;
+
+ ok 28, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "harry") != 0;
+ ok 29, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") == 0 ;
+
+ # should only be one subdatabase
+ ok 30, $db = new BerkeleyDB::Unknown -Filename => $Dfile ,
+ -Flags => DB_RDONLY ;
+
+ ok 31, $cursor = $db->db_cursor() ;
+ @dbnames = () ;
+ while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) {
+ push @dbnames, $k ;
+ }
+ ok 32, $status == DB_NOTFOUND ;
+ ok 33, join(",", sort @dbnames) eq "joe" ;
+ undef $db ;
+
+ # can't delete an already deleted subdatabase
+ ok 34, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") != 0;
+
+ ok 35, BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "joe") == 0 ;
+
+ # should only be one subdatabase
+ ok 36, $db = new BerkeleyDB::Unknown -Filename => $Dfile ,
+ -Flags => DB_RDONLY ;
+
+ ok 37, $cursor = $db->db_cursor() ;
+ @dbnames = () ;
+ while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) {
+ push @dbnames, $k ;
+ }
+ ok 38, $status == DB_NOTFOUND ;
+ ok 39, @dbnames == 0 ;
+ undef $db ;
+ undef $cursor ;
+
+ ok 40, -e $Dfile ;
+ ok 41, BerkeleyDB::db_remove(-Filename => $Dfile) == 0 ;
+ ok 42, ! -e $Dfile ;
+ ok 43, BerkeleyDB::db_remove(-Filename => $Dfile) != 0 ;
+}
+
+# db_remove with env
diff --git a/storage/bdb/perl/BerkeleyDB/t/txn.t b/storage/bdb/perl/BerkeleyDB/t/txn.t
new file mode 100644
index 00000000000..ba6b636cdc8
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/txn.t
@@ -0,0 +1,320 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..58\n";
+
+my $Dfile = "dbhash.tmp";
+
+umask(0);
+
+{
+ # error cases
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 1, my $lexD = new LexDir($home);
+ ok 2, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE| DB_INIT_MPOOL;
+ eval { $env->txn_begin() ; } ;
+ ok 3, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
+
+ eval { my $txn_mgr = $env->TxnMgr() ; } ;
+ ok 4, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
+ undef $env ;
+
+}
+
+{
+ # transaction - abort works
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 5, my $lexD = new LexDir($home);
+ ok 6, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 7, my $txn = $env->txn_begin() ;
+ ok 8, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok 9, $txn->txn_commit() == 0 ;
+ ok 10, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok 11, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 12, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 13, $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok 14, $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok 15, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 16, $count == 0 ;
+
+ my $stat = $env->txn_stat() ;
+ ok 17, $stat->{'st_naborts'} == 1 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # transaction - abort works via txnmgr
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 18, my $lexD = new LexDir($home);
+ ok 19, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 20, my $txn_mgr = $env->TxnMgr() ;
+ ok 21, my $txn = $txn_mgr->txn_begin() ;
+ ok 22, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok 23, $txn->txn_commit() == 0 ;
+ ok 24, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok 25, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 26, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 27, $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok 28, $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok 29, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 30, $count == 0 ;
+
+ my $stat = $txn_mgr->txn_stat() ;
+ ok 31, $stat->{'st_naborts'} == 1 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $txn_mgr ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # transaction - commit works
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 32, my $lexD = new LexDir($home);
+ ok 33, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 34, my $txn = $env->txn_begin() ;
+ ok 35, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok 36, $txn->txn_commit() == 0 ;
+ ok 37, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok 38, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 39, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 40, $count == 3 ;
+ undef $cursor ;
+
+ # now commit the transaction
+ ok 41, $txn->txn_commit() == 0 ;
+
+ $count = 0 ;
+ # sequence forwards
+ ok 42, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 43, $count == 3 ;
+
+ my $stat = $env->txn_stat() ;
+ ok 44, $stat->{'st_naborts'} == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # transaction - commit works via txnmgr
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok 45, my $lexD = new LexDir($home);
+ ok 46, my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok 47, my $txn_mgr = $env->TxnMgr() ;
+ ok 48, my $txn = $txn_mgr->txn_begin() ;
+ ok 49, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok 50, $txn->txn_commit() == 0 ;
+ ok 51, $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok 52, $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok 53, my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 54, $count == 3 ;
+ undef $cursor ;
+
+ # now commit the transaction
+ ok 55, $txn->txn_commit() == 0 ;
+
+ $count = 0 ;
+ # sequence forwards
+ ok 56, $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok 57, $count == 3 ;
+
+ my $stat = $txn_mgr->txn_stat() ;
+ ok 58, $stat->{'st_naborts'} == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $txn_mgr ;
+ undef $env ;
+ untie %hash ;
+}
+
diff --git a/storage/bdb/perl/BerkeleyDB/t/unknown.t b/storage/bdb/perl/BerkeleyDB/t/unknown.t
new file mode 100644
index 00000000000..f2630b585c0
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/unknown.t
@@ -0,0 +1,176 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use BerkeleyDB;
+use t::util ;
+
+print "1..41\n";
+
+my $Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Unknown -Stupid => 3 ; ' ;
+ ok 1, $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Unknown -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok 2, $@ =~ /unknown key value\(s\) (Bad |Stupid ){2}/ ;
+
+ eval ' $db = new BerkeleyDB::Unknown -Env => 2 ' ;
+ ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Unknown -Txn => "fred" ' ;
+ ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Unknown -Env => $obj ' ;
+ ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# check the interface to a rubbish database
+{
+ # first an empty file
+ my $lex = new LexFile $Dfile ;
+ ok 6, writeFile($Dfile, "") ;
+
+ ok 7, ! (new BerkeleyDB::Unknown -Filename => $Dfile);
+
+ # now a non-database file
+ writeFile($Dfile, "\x2af6") ;
+ ok 8, ! (new BerkeleyDB::Unknown -Filename => $Dfile);
+}
+
+# check the interface to a Hash database
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ # create a hash database
+ ok 9, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a few k/v pairs
+ my $value ;
+ my $status ;
+ ok 10, $db->db_put("some key", "some value") == 0 ;
+ ok 11, $db->db_put("key", "value") == 0 ;
+
+ # close the database
+ undef $db ;
+
+ # now open it with Unknown
+ ok 12, $db = new BerkeleyDB::Unknown -Filename => $Dfile;
+
+ ok 13, $db->type() == DB_HASH ;
+ ok 14, $db->db_get("some key", $value) == 0 ;
+ ok 15, $value eq "some value" ;
+ ok 16, $db->db_get("key", $value) == 0 ;
+ ok 17, $value eq "value" ;
+
+ my @array ;
+ eval { $db->Tie(\@array)} ;
+ ok 18, $@ =~ /^Tie needs a reference to a hash/ ;
+
+ my %hash ;
+ $db->Tie(\%hash) ;
+ ok 19, $hash{"some key"} eq "some value" ;
+
+}
+
+# check the interface to a Btree database
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ # create a hash database
+ ok 20, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a few k/v pairs
+ my $value ;
+ my $status ;
+ ok 21, $db->db_put("some key", "some value") == 0 ;
+ ok 22, $db->db_put("key", "value") == 0 ;
+
+ # close the database
+ undef $db ;
+
+ # now open it with Unknown
+ # create a hash database
+ ok 23, $db = new BerkeleyDB::Unknown -Filename => $Dfile;
+
+ ok 24, $db->type() == DB_BTREE ;
+ ok 25, $db->db_get("some key", $value) == 0 ;
+ ok 26, $value eq "some value" ;
+ ok 27, $db->db_get("key", $value) == 0 ;
+ ok 28, $value eq "value" ;
+
+
+ my @array ;
+ eval { $db->Tie(\@array)} ;
+ ok 29, $@ =~ /^Tie needs a reference to a hash/ ;
+
+ my %hash ;
+ $db->Tie(\%hash) ;
+ ok 30, $hash{"some key"} eq "some value" ;
+
+
+}
+
+# check the interface to a Recno database
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ # create a recno database
+ ok 31, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a few k/v pairs
+ my $value ;
+ my $status ;
+ ok 32, $db->db_put(0, "some value") == 0 ;
+ ok 33, $db->db_put(1, "value") == 0 ;
+
+ # close the database
+ undef $db ;
+
+ # now open it with Unknown
+ # create a hash database
+ ok 34, $db = new BerkeleyDB::Unknown -Filename => $Dfile;
+
+ ok 35, $db->type() == DB_RECNO ;
+ ok 36, $db->db_get(0, $value) == 0 ;
+ ok 37, $value eq "some value" ;
+ ok 38, $db->db_get(1, $value) == 0 ;
+ ok 39, $value eq "value" ;
+
+
+ my %hash ;
+ eval { $db->Tie(\%hash)} ;
+ ok 40, $@ =~ /^Tie needs a reference to an array/ ;
+
+ my @array ;
+ $db->Tie(\@array) ;
+ ok 41, $array[1] eq "value" ;
+
+
+}
+
+# check i/f to text
diff --git a/storage/bdb/perl/BerkeleyDB/t/util.pm b/storage/bdb/perl/BerkeleyDB/t/util.pm
new file mode 100644
index 00000000000..1a1449751eb
--- /dev/null
+++ b/storage/bdb/perl/BerkeleyDB/t/util.pm
@@ -0,0 +1,220 @@
+package util ;
+
+package main ;
+
+use strict ;
+use BerkeleyDB ;
+use File::Path qw(rmtree);
+use vars qw(%DB_errors $FA) ;
+
+$| = 1;
+
+%DB_errors = (
+ 'DB_INCOMPLETE' => "DB_INCOMPLETE: Sync was unable to complete",
+ 'DB_KEYEMPTY' => "DB_KEYEMPTY: Non-existent key/data pair",
+ 'DB_KEYEXIST' => "DB_KEYEXIST: Key/data pair already exists",
+ 'DB_LOCK_DEADLOCK' => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
+ 'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
+ 'DB_NOTFOUND' => "DB_NOTFOUND: No matching key/data pair found",
+ 'DB_OLD_VERSION' => "DB_OLDVERSION: Database requires a version upgrade",
+ 'DB_RUNRECOVERY' => "DB_RUNRECOVERY: Fatal error, run database recovery",
+) ;
+
+# full tied array support started in Perl 5.004_57
+# just double check.
+$FA = 0 ;
+{
+ sub try::TIEARRAY { bless [], "try" }
+ sub try::FETCHSIZE { $FA = 1 }
+ my @a ;
+ tie @a, 'try' ;
+ my $a = @a ;
+}
+
+{
+ package LexFile ;
+
+ use vars qw( $basename @files ) ;
+ $basename = "db0000" ;
+
+ sub new
+ {
+ my $self = shift ;
+ #my @files = () ;
+ foreach (@_)
+ {
+ $_ = $basename ;
+ unlink $basename ;
+ push @files, $basename ;
+ ++ $basename ;
+ }
+ bless [ @files ], $self ;
+ }
+
+ sub DESTROY
+ {
+ my $self = shift ;
+ #unlink @{ $self } ;
+ }
+
+ END
+ {
+ foreach (@files) { unlink $_ }
+ }
+}
+
+
+{
+ package LexDir ;
+
+ use File::Path qw(rmtree);
+
+ use vars qw( $basename %dirs ) ;
+
+ sub new
+ {
+ my $self = shift ;
+ my $dir = shift ;
+
+ rmtree $dir if -e $dir ;
+
+ mkdir $dir, 0777 or return undef ;
+
+ return bless [ $dir ], $self ;
+ }
+
+ sub DESTROY
+ {
+ my $self = shift ;
+ my $dir = $self->[0];
+ #rmtree $dir;
+ $dirs{$dir} ++ ;
+ }
+
+ END
+ {
+ foreach (keys %dirs) {
+ rmtree $_ if -d $_ ;
+ }
+ }
+
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ return $result;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT> || "" ;
+ close(CAT);
+ unlink $file ;
+ return $result;
+}
+
+sub writeFile
+{
+ my $name = shift ;
+ open(FH, ">$name") or return 0 ;
+ print FH @_ ;
+ close FH ;
+ return 1 ;
+}
+
+sub touch
+{
+ my $file = shift ;
+ open(CAT,">$file") || die "Cannot open $file:$!";
+ close(CAT);
+}
+
+sub joiner
+{
+ my $db = shift ;
+ my $sep = shift ;
+ my ($k, $v) = (0, "") ;
+ my @data = () ;
+
+ my $cursor = $db->db_cursor() or return () ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ push @data, $v ;
+ }
+
+ (scalar(@data), join($sep, @data)) ;
+}
+
+sub countRecords
+{
+ my $db = shift ;
+ my ($k, $v) = (0,0) ;
+ my ($count) = 0 ;
+ my ($cursor) = $db->db_cursor() ;
+ #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
+# $status == 0 ;
+# $status = $cursor->c_get($k, $v, DB_NEXT) )
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { ++ $count }
+
+ return $count ;
+}
+
+sub addData
+{
+ my $db = shift ;
+ my @data = @_ ;
+ die "addData odd data\n" if @data % 2 != 0 ;
+ my ($k, $v) ;
+ my $ret = 0 ;
+ while (@data) {
+ $k = shift @data ;
+ $v = shift @data ;
+ $ret += $db->db_put($k, $v) ;
+ }
+
+ return ($ret == 0) ;
+}
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+
+1;
View Lorry Controller Status