Imported from /home/lorry/working-area/delta_berkeleydb/db-6.1.23.tar.gz.HEADdb-6.1.23master

5 files changed, 805 insertions, 40 deletions

diff --git a/lang/perl/BerkeleyDB/t/blob.t b/lang/perl/BerkeleyDB/t/blob.t
new file mode 100644
index 00000000..6931418a
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/blob.t
@@ -0,0 +1,166 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't';
+use BerkeleyDB; 
+use util ;
+use Test::More;
+
+plan(skip_all => "this needs Berkeley DB 6.x.x or better\n" )
+    if $BerkeleyDB::db_version < 6;
+
+plan tests => 84;
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+sub isBlob
+{
+    my $cursor = shift ;
+    my $key = shift;
+
+    my $v = '';
+    $cursor->partial_set(0,0) ;
+    $cursor->c_get($key, $v, DB_SET) ;
+    $cursor->partial_clear() ;
+    return defined $cursor->db_stream(DB_STREAM_WRITE);
+}
+
+for my $TYPE ( qw(BerkeleyDB::Hash BerkeleyDB::Btree ))
+{
+    #diag "Test $TYPE";
+    my $lex = new LexFile $Dfile ;
+    my $home = "./fred" ;
+    my $lexd = new LexDir $home ;
+    my $threshold = 1234 ;
+
+    ok my $env = new BerkeleyDB::Env 
+                        Flags => DB_CREATE|DB_INIT_MPOOL,
+                        #@StdErrFile, 
+                        BlobDir => $home,
+                        Home => $home ;
+
+    ok my $db = new $TYPE Filename => $Dfile, 
+				    Env      => $env,
+                    BlobThreshold => $threshold,
+				    Flags    => DB_CREATE ;
+
+    isa_ok $db, $TYPE ;
+
+    ok $env->get_blob_threshold(my $t1) == 0 ;
+    is $t1, 0," env threshold is 0" ;
+
+    ok $env->get_blob_dir(my $dir1) == 0 ;
+    is $dir1, $home," env threshold is 0" ;
+
+    ok $db->get_blob_threshold(my $t2) == 0 ;
+    is $t2, $threshold," db threshold is $threshold" ;
+
+    ok $db->get_blob_dir(my $dir2) == 0 ;
+    is $dir2, $home, " env threshold is 0" ;
+
+    my $smallData = "a234";
+    my $bigData = "x" x ($threshold+1) ;
+    ok $db->db_put("1", $bigData) == 0  ;
+    ok $db->db_put("2", $smallData) == 0  ;
+
+    my $v2 ;
+    ok $db->db_get("1", $v2) == 0 ;
+    is $v2, $bigData;
+
+    my $v1 ;
+    ok $db->db_get("2", $v1) == 0 ;
+    is $v1, $smallData;
+
+    ok my $cursor = $db->db_cursor() ;
+
+    ok isBlob($cursor, "1");
+    ok !isBlob($cursor, "2");
+
+    my $k = "1";
+    my $v = '';
+    $cursor->partial_set(0,0) ;
+    ok $cursor->c_get($k, $v, DB_SET) == 0, "set cursor"
+        or diag "Status is [" . $cursor->status() . "]";
+    $cursor->partial_clear() ;
+    is $k, "1";
+    ok my $dbstream = $cursor->db_stream(DB_STREAM_WRITE)
+        or diag "Status is [" . $cursor->status() . "]";
+    isa_ok $dbstream, 'BerkeleyDB::DbStream';
+    ok $dbstream->size(my $s) == 0 , "size";
+    is $s, length $bigData, "length ok";
+    my $new ;
+    ok $dbstream->read($new, 0, length $bigData) == 0 , "read"
+        or diag "Status is [" . $cursor->status() . "]";
+    is $new, $bigData;
+    my $newData = "hello world" ;
+    ok $dbstream->write($newData) == 0 , "write";
+
+    substr($bigData, 0, length($newData)) = $newData;
+    
+    my $new1;
+    ok $dbstream->read($new, 0, 5) == 0 , "read";
+    is $new, "hello";
+
+    ok $dbstream->close() == 0 , "close";
+
+    $k = "1";
+    my $stream = $cursor->c_get_db_stream($k, DB_SET, DB_STREAM_WRITE) ;
+    isa_ok $stream, 'BerkeleyDB::DbStream';
+    is $k, "1";
+    ok $stream->size($s) == 0 , "size";
+    is $s, length $bigData, "length ok";
+    $new = 'abc';
+    ok $stream->read($new, 0, 5) == 0 , "read";
+    is $new, "hello";
+    ok $stream->close() == 0 , "close";
+
+
+    ok my $cursor1 = $db->db_cursor() ;
+    my $d1 ;
+    my $d2 ;
+    while (1)
+    {
+        my $k = '';
+        my $v = '';
+        $cursor->partial_set(0,0) ;
+        my $status = $cursor1->c_get($k, $v, DB_NEXT) ;
+        $cursor->partial_clear();
+
+        last if $status != 0 ;
+
+        my $stream = $cursor1->db_stream(DB_STREAM_WRITE);
+
+        if (defined $stream)
+        {
+            $stream->size(my $s) ;
+            my $d = '';
+            my $delta = 1024;
+            my $off = 0;
+            while ($s)
+            {
+                $delta = $s if $s - $delta < 0 ;
+
+                $stream->read($d, $off, $delta);
+                $off += $delta ;
+                $s -= $delta ;
+                $d1 .= $d ;
+            }
+
+        }
+        else
+        {
+            $cursor1->c_get($k, $d2, DB_CURRENT) ;
+        }
+    }
+
+    is $d1, $bigData;
+    is $d2, $smallData;
+
+}
+
diff --git a/lang/perl/BerkeleyDB/t/btree.t b/lang/perl/BerkeleyDB/t/btree.t
index 44667a56..adef0c45 100644
--- a/lang/perl/BerkeleyDB/t/btree.t
+++ b/lang/perl/BerkeleyDB/t/btree.t
@@ -280,24 +280,9 @@ umask(0) ;
         $k{$_} = 1 ;
     }
 
-    sub ArrayCompare
-    {
-        my($a, $b) = @_ ;
-    
-        return 0 if @$a != @$b ;
-    
-        foreach (1 .. length @$a)
-        {
-            return 0 unless $$a[$_] eq $$b[$_] ;
-        }
-
-        1 ;
-    }
-
-    ok ArrayCompare (\@srt_1, [keys %h]);
-    ok ArrayCompare (\@srt_2, [keys %g]);
-    ok ArrayCompare (\@srt_3, [keys %k]);
-
+    is_deeply [keys %h], \@srt_1 ;
+    is_deeply [keys %g], \@srt_2 ;
+    is_deeply [keys %k], \@srt_3 ;
 }
 
 {
@@ -331,7 +316,7 @@ umask(0) ;
 
     foreach (@Keys) {
         local $^W = 0 ;
-	my $value = shift @Values ;
+        my $value = shift @Values ;
         $h{$_} = $value ; 
         $g{$_} = $value ;
         $k{$_} = $value ;
@@ -339,23 +324,25 @@ umask(0) ;
 
     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 ;
+        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 ArrayCompare (\@srt_1, [keys %h]);
-    ok ArrayCompare (\@srt_2, [keys %g]);
-    ok ArrayCompare (\@srt_3, [keys %k]);
-    ok ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]);
-    ok ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]);
-    ok ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]);
+    is_deeply [keys %h], \@srt_1 ;
+    is_deeply [keys %g], \@srt_2 ;
+    is_deeply [keys %k], \@srt_3 ;
+
+    is_deeply [getValues \%h], [qw(dd 0 0 x 3 1 abc)];
+    is_deeply [getValues \%g], [qw(dd 1 3 0 x abc 0)]
+        or diag "Expected [dd 1 0 3 x abc 0] got [@{ [getValues(\%g)] }]\n";
+    is_deeply [getValues \%k], [qw(0 x 3 0 1 dd abc)];
 
     # test DB_DUP_NEXT
     ok my $cur = (tied %g)->db_cursor() ;
@@ -397,15 +384,15 @@ umask(0) ;
 
     foreach (@Keys) {
         local $^W = 0 ;
-	my $value = shift @Values ;
+        my $value = shift @Values ;
         $h{$_} = $value ; 
         $g{$_} = $value ;
     }
 
-    ok ArrayCompare (\@srt_1, [keys %h]);
-    ok ArrayCompare (\@srt_2, [keys %g]);
-    ok ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]);
-    ok ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]);
+    is_deeply [keys %h], \@srt_1 ;
+    is_deeply [keys %g], \@srt_2 ;
+    is_deeply [getValues \%h], [qw(dd 0 11 2 x 3 1 abc)];
+    is_deeply [getValues \%h], [qw(dd 0 11 2 x 3 1 abc)];
 
 }
 
diff --git a/lang/perl/BerkeleyDB/t/heap.t b/lang/perl/BerkeleyDB/t/heap.t
new file mode 100644
index 00000000..f8a51ae3
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/heap.t
@@ -0,0 +1,564 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't';
+use BerkeleyDB; 
+use util ;
+use Test::More;
+
+plan(skip_all => "Heap needs Berkeley DB 5.2.x or better\n" )
+    if $BerkeleyDB::db_version < 5.2;
+
+# TODO - fix this
+plan(skip_all => "Heap suport not available\n" )
+    if ! BerkeleyDB::has_heap() ;
+
+plan tests => 68;
+
+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::Heap  -Stupid => 3 ; ' ;
+    ok $@ =~ /unknown key value\(s\) Stupid/  ;
+
+    eval ' $db = new BerkeleyDB::Heap -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+    ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/  
+        or print "# $@" ;
+
+    eval ' $db = new BerkeleyDB::Heap -Env => 2 ' ;
+    ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+    eval ' $db = new BerkeleyDB::Heap -Txn => "x" ' ;
+    ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+    my $obj = bless [], "main" ;
+    eval ' $db = new BerkeleyDB::Heap -Env => $obj ' ;
+    ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+{
+    # Tied Hash interface
+
+    my $lex = new LexFile $Dfile ;
+    my %hash ;
+    eval " tie %hash, 'BerkeleyDB::Heap', -Filename => '$Dfile',
+                                      -Flags    => DB_CREATE ; " ;
+    ok $@ =~ /^Tied Hash interface not supported with BerkeleyDB::Heap/;
+
+}
+# Now check the interface to Heap
+
+{
+    my $lex = new LexFile $Dfile ;
+
+    ok my $db = new BerkeleyDB::Heap -Filename => $Dfile, 
+				    -Flags    => DB_CREATE 
+        or diag "Cannot create Heap: [$!][$BerkeleyDB::Error]\n" ;
+
+    # Add a k/v pair
+    my $value ;
+    my $status ;
+    my $key1;
+    my $key2;
+    is $db->Env, undef;
+    ok $db->db_put($key1, "some value", DB_APPEND) == 0  
+        or diag "Cannot db_put: " . $db->status() . "[$!][$BerkeleyDB::Error]\n" ;
+    ok $db->status() == 0 ;
+    ok $db->db_get($key1, $value) == 0 
+        or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ;
+    ok $value eq "some value" ;
+    ok $db->db_put($key2, "value", DB_APPEND) == 0  ;
+    ok $db->db_get($key2, $value) == 0 
+        or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ;
+    ok $value eq "value" ;
+    ok $db->db_del($key1) == 0 ;
+    ok $db->db_get($key1, $value) == DB_NOTFOUND ;
+    ok $db->status() == DB_NOTFOUND ;
+    ok $db->status() =~ $DB_errors{'DB_NOTFOUND'} 
+        or diag "Status is [" . $db->status() . "]";
+
+    ok $db->db_sync() == 0 ;
+
+    # Check NOOVERWRITE will make put fail when attempting to overwrite
+    # an existing record.
+
+    ok $db->db_put( $key2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+    ok $db->status() =~ $DB_errors{'DB_KEYEXIST'} ;
+    ok $db->status() == DB_KEYEXIST ;
+
+
+    # check that the value of the key  has not been changed by the
+    # previous test
+    ok $db->db_get($key2, $value) == 0 ;
+    ok $value eq "value" ;
+
+    # test DB_GET_BOTH
+    my ($k, $v) = ($key2, "value") ;
+    ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
+
+    ($k, $v) = ($key2, "fred") ;
+    ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+    ($k, $v) = ("another", "value") ;
+    ok $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 my $lexD = new LexDir($home) ;
+
+    ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
+    					 @StdErrFile, -Home => $home ;
+    ok my $db = new BerkeleyDB::Heap -Filename => $Dfile, 
+				    -Env      => $env,
+				    -Flags    => DB_CREATE ;
+
+    isa_ok $db->Env, 'BerkeleyDB::Env';
+    $db->Env->errPrefix("abc");
+    is $db->Env->errPrefix("abc"), 'abc';
+    # Add a k/v pair
+    my $key ;
+    my $value ;
+    ok $db->db_put($key, "some value", DB_APPEND) == 0 ;
+    ok $db->db_get($key, $value) == 0 ;
+    ok $value eq "some value" ;
+    undef $db ;
+    undef $env ;
+}
+
+ 
+{
+    # cursors
+
+    my $lex = new LexFile $Dfile ;
+    my %hash ;
+    my ($k, $v) ;
+    ok my $db = new BerkeleyDB::Heap -Filename => $Dfile, 
+				     -Flags    => DB_CREATE ;
+    #print "[$db] [$!] $BerkeleyDB::Error\n" ;				     
+
+    # create some data
+    my %data =  ();
+    my %keys =  ();
+
+    my $ret = 0 ;
+    for my $v (qw(2 house sea)){
+        my $key;
+        $ret += $db->db_put($key, $v, DB_APPEND) ;
+        $data{$key} = $v;
+        $keys{$v} = $key;
+    }
+
+    ok $ret == 0 ;
+
+    # create the cursor
+    ok 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 $cursor->status() == DB_NOTFOUND ;
+    ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'};
+    ok keys %copy == 0 ;
+    ok $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 $status == DB_NOTFOUND ;
+    ok $status =~ $DB_errors{'DB_NOTFOUND'};
+    ok $cursor->status() == $status ;
+    ok $cursor->status() eq $status ;
+    ok keys %copy == 0 ;
+    ok $extras == 0, "extras == 0" ;
+
+    ($k, $v) = ($keys{"house"}, "house") ;
+    ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0, "c_get BOTH" ;
+
+    ($k, $v) = ($keys{"house"}, "door") ;
+    ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ;
+
+    ($k, $v) = ("black", "house") ;
+    ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ;
+
+}
+ 
+
+
+
+{
+    # in-memory file
+
+    my $lex = new LexFile $Dfile ;
+    my %hash ;
+    my $fd ;
+    my $value ;
+    #ok my $db = tie %hash, 'BerkeleyDB::Heap' ;
+    my $db = new BerkeleyDB::Heap 
+				     -Flags    => DB_CREATE ;
+
+    isa_ok $db, 'BerkeleyDB::Heap' ;
+    my $key;
+    ok $db->db_put($key, "some value", DB_APPEND) == 0  ;
+    ok $db->db_get($key, $value) == 0 ;
+    ok $value eq "some value", "some value" ;
+
+}
+ 
+if (0)
+{
+    # partial
+    # check works via API
+
+    my $lex = new LexFile $Dfile ;
+    my $value ;
+    ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
+                                     -Flags    => DB_CREATE ;
+
+    # create some data
+    my $red;
+    my $green;
+    my $blue;
+    my %data =  (
+		"red"	=> "boat",
+		"green"	=> "house",
+		"blue"	=> "sea",
+		) ;
+
+    my %keys =  (
+		"red" => \$red,
+		"green" => \$green,
+		"blue" => \$blue,
+		) ;
+
+    my $ret = 0 ;
+    while (my ($k, $v) = each %data) {
+        my $key;
+        $ret += $db->db_put($key, $v, DB_APPEND) ;
+        ${ $keys{$k} } = $key;
+    }
+    ok $ret == 0, "ret 0" ;
+
+
+    # do a partial get
+    my ($pon, $off, $len) = $db->partial_set(0,2) ;
+    ok ! $pon && $off == 0 && $len == 0 ;
+    ok $db->db_get($red, $value) == 0 && $value eq "bo" ;
+    ok $db->db_get($green, $value) == 0 && $value eq "ho" ;
+    ok $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 $pon ;
+    ok $off == 0 ;
+    ok $len == 2, "len 2" ;
+    ok $db->db_get($red, $value) == 0 && $value eq "t" ;
+    ok $db->db_get($green, $value) == 0 && $value eq "se" ;
+    ok $db->db_get($blue, $value) == 0 && $value eq "" ;
+
+    # switch of partial mode
+    ($pon, $off, $len) = $db->partial_clear() ;
+    ok $pon ;
+    ok $off == 3, "off 3" ;
+    ok $len == 2 ;
+    ok $db->db_get($red, $value) == 0 && $value eq "boat" ;
+    ok $db->db_get($green, $value) == 0 && $value eq "house" ;
+    ok $db->db_get($blue, $value) == 0 && $value eq "sea" ;
+
+    # now partial put
+    my $new;
+    $db->partial_set(0,2) ;
+    ok $db->db_put($red, "") == 0 ;
+    ok $db->db_put($green, "AB") == 0 ;
+    ok $db->db_put($blue, "XYZ") == 0 ;
+    ok $db->db_put($new, "KLM", DB_APPEND) == 0 ;
+
+    ($pon, $off, $len) = $db->partial_clear() ;
+    ok $pon ;
+    ok $off == 0 ;
+    ok $len == 2, "len 2" ;
+    ok $db->db_get($red, $value) == 0 && $value eq "at" ;
+    ok $db->db_get($green, $value) == 0 && $value eq "ABuse" ;
+    ok $db->db_get($blue, $value) == 0 && $value eq "XYZa" ;
+    ok $db->db_get($new, $value) == 0 && $value eq "KLM" ;
+
+    # now partial put
+    ($pon, $off, $len) = $db->partial_set(3,2) ;
+    ok ! $pon ;
+    ok $off == 0 ;
+    ok $len == 0 ;
+    ok $db->db_put($red, "PPP") == 0 ;
+    ok $db->db_put($green, "Q") == 0, "Q" ;
+    ok $db->db_put($blue, "XYZ") == 0, "XYZ" ; # <<<<<<<<<<<<<<
+    ok $db->db_put($new, "TU") == 0 ;
+
+    $db->partial_clear() ;
+    ok $db->db_get($red, $value) == 0 && $value eq "at\0PPP" ;
+    ok $db->db_get($green, $value) == 0 && $value eq "ABuQ" ;
+    ok $db->db_get($blue, $value) == 0 && $value eq "XYZXYZ" ;
+    ok $db->db_get($new, $value) == 0 && $value eq "KLMTU", "KLMTU" ;
+}
+
+
+{
+    # transaction
+
+    my $lex = new LexFile $Dfile ;
+    my %hash ;
+    my $value ;
+
+    my $home = "./fred" ;
+    ok my $lexD = new LexDir($home) ;
+    ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+				     -Flags => DB_CREATE|DB_INIT_TXN|
+					  	DB_INIT_MPOOL|DB_INIT_LOCK ;
+    ok my $txn = $env->txn_begin() ;
+    ok my $db1 = new BerkeleyDB::Heap -Filename => $Dfile,
+                                      	       -Flags    =>  DB_CREATE ,
+					       -Env 	 => $env,
+					       -Txn	 => $txn ;
+
+    ok ((my $Z = $txn->txn_commit()) == 0) ;
+    ok $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) {
+        my $key;
+        $ret += $db1->db_put($key, $v, DB_APPEND) ;
+    }
+    ok $ret == 0 ;
+
+    # should be able to see all the records
+
+    ok my $cursor = $db1->db_cursor() ;
+    my ($k, $v) = ("", "") ;
+    my $count = 0 ;
+    # sequence forwards
+    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+        ++ $count ;
+    }
+    ok $count == 3 ;
+    undef $cursor ;
+
+    # now abort the transaction
+    #ok $txn->txn_abort() == 0 ;
+    ok (($Z = $txn->txn_abort()) == 0) ;
+
+    # there shouldn't be any records in the database
+    $count = 0 ;
+    # sequence forwards
+    ok $cursor = $db1->db_cursor() ;
+    while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+        ++ $count ;
+    }
+    ok $count == 0 ;
+
+    undef $txn ;
+    undef $cursor ;
+    undef $db1 ;
+    undef $env ;
+    untie %hash ;
+}
+exit;
+
+{
+    # DB_DUP
+
+    my $lex = new LexFile $Dfile ;
+    my %hash ;
+    ok my $db = tie %hash, 'BerkeleyDB::Heap', -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 keys %hash == 6 ;
+
+    # create a cursor
+    ok my $cursor = $db->db_cursor() ;
+
+    my $key = "Wall" ;
+    my $value ;
+    ok $cursor->c_get($key, $value, DB_SET) == 0 ;
+    ok $key eq "Wall" && $value eq "Larry" ;
+    ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+    ok $key eq "Wall" && $value eq "Stone" ;
+    ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+    ok $key eq "Wall" && $value eq "Brick" ;
+    ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+    ok $key eq "Wall" && $value eq "Brick" ;
+
+    #my $ref = $db->db_stat() ; 
+    #ok ($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 my $db = new BerkeleyDB::Heap -Filename => $Dfile, 
+				     -Flags    => DB_CREATE,
+				 	-Minkey	=>3 ,
+					-Pagesize	=> 2 **12 
+					;
+
+    my $ref = $db->db_stat() ; 
+    ok $ref->{$recs} == 0;
+    ok $ref->{'bt_minkey'} == 3;
+    ok $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 $ret == 0 ;
+
+    $ref = $db->db_stat() ; 
+    ok $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 BerkeleyDB::Heap );
+   @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 ;
+
+    use Test::More;
+    BEGIN { push @INC, '.'; }    
+    eval 'use SubDB ; ';
+    ok $@ eq "" ;
+    my %h ;
+    my $X ;
+    eval '
+	$X = tie(%h, "SubDB", -Filename => "dbbtree.tmp", 
+			-Flags => DB_CREATE,
+			-Mode => 0640 );
+	' ;
+
+    ok $@ eq "" && $X ;
+
+    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+    ok $@ eq "" ;
+    ok $ret == 7 ;
+
+    my $value = 0;
+    $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
+    ok $@ eq "" ;
+    ok $ret == 10 ;
+
+    $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+    ok $@ eq ""  ;
+    ok $ret == 1 ;
+
+    $ret = eval '$X->A_new_method("joe") ' ;
+    ok $@ eq "" ;
+    ok $ret eq "[[10]]" ;
+
+    undef $X;
+    untie %h;
+    unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
+
diff --git a/lang/perl/BerkeleyDB/t/queue.t b/lang/perl/BerkeleyDB/t/queue.t
index fd372ae7..a2ffa76f 100644
--- a/lang/perl/BerkeleyDB/t/queue.t
+++ b/lang/perl/BerkeleyDB/t/queue.t
@@ -12,7 +12,7 @@ use util;
 plan(skip_all => "Queue needs Berkeley DB 3.3.x or better\n" )
     if $BerkeleyDB::db_version < 3.3;
     
-plan tests => 257;
+plan tests => 260;
 
 
 my $Dfile = "dbhash.tmp";
@@ -867,6 +867,28 @@ EOM
     undef $db ;
     untie @array ;
 }
+
+{
+    # RT #75691: scalar(@array) returns incorrect value after shift() on tied array
+    my $lex = new LexFile $Dfile ;
+    my @array ;
+    my $db ;
+    $db = tie @array, 'BerkeleyDB::Queue', 
+                        -Flags  => DB_CREATE ,
+				    	-Len       => 2,
+						-Filename => $Dfile ;
+    isa_ok $db, 'BerkeleyDB::Queue';                        
+    $FA ? push @array,  "ab", "cd", "ef", "gh"
+        : $db->push("ab", "cd", "ef", "gh") ;
+    is scalar(@array), 4;
+
+    $FA ? shift @array : $db->shift() ;
+    is scalar(@array), 3;
+
+    undef $db;
+    untie @array ;
+
+}
 __END__
 
 
diff --git a/lang/perl/BerkeleyDB/t/recno.t b/lang/perl/BerkeleyDB/t/recno.t
index fad7829e..1ebe0b40 100644
--- a/lang/perl/BerkeleyDB/t/recno.t
+++ b/lang/perl/BerkeleyDB/t/recno.t
@@ -907,6 +907,32 @@ EOM
     untie @array ;
 
 }
+
+SKIP:
+if(0)
+{
+    # RT #75691: scalar(@array) returns incorrect value after shift() on tied array
+    skip "Test needs Berkeley DB 3.2 or better", 4 
+        if $BerkeleyDB::db_version < 3.3;
+
+    my $lex = new LexFile $Dfile ;
+    my @array ;
+    my $db ;
+    ok $db = tie @array, 'BerkeleyDB::Recno', 
+                        -Flags  => DB_CREATE ,
+						-Filename => $Dfile ;
+
+    isa_ok $db, 'BerkeleyDB::Recno';
+    $FA ? push @array,  7, 9, 11, 13
+        : $db->push(7, 9, 11, 13) ;
+    is scalar(@array), 4;
+    $FA ? shift @array : $db->shift() ;
+    is scalar(@array), 3;
+
+    undef $db;
+    untie @array ;
+
+}
 __END__