Updated as part of DB_File update

[p5sagit/p5-mst-13.2.git] / t / lib / db-btree.t

diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t
index 308b8f4..f3cf944 100755 (executable)
--- a/t/lib/db-btree.t
+++ b/t/lib/db-btree.t
@@ -12,16 +12,17 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..73\n";
+print "1..86\n";
 
-$Dfile = "Op.db-btree";
+$Dfile = "dbbtree.tmp";
 unlink $Dfile;
 
 umask(0);
 
 # Check the interface to BTREEINFO
 
-$dbh = TIEHASH DB_File::BTREEINFO ;
+#$dbh = TIEHASH DB_File::BTREEINFO ;
+$dbh = new DB_File::BTREEINFO ;
 print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ;
 print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
 print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
@@ -57,9 +58,9 @@ print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ;
 
 # Check that an invalid entry is caught both for store & fetch
 eval '$dbh->{fred} = 1234' ;
-print ($@ eq '' ? "ok 17\n" : "not ok 17\n") ;
+print ($@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ? "ok 17\n" : "not ok 17\n") ;
 eval '$q = $dbh->{fred}' ;
-print ($@ eq '' ? "ok 18\n" : "not ok 18\n") ;
+print ($@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ? "ok 18\n" : "not ok 18\n") ;
 
 # Now check the interface to BTREE
 
@@ -77,7 +78,7 @@ print (!$i ? "ok 21\n" : "not ok 21\n");
 $h{'goner1'} = 'snork';
 
 $h{'abc'} = 'ABC';
-print ($h{'abc'} == 'ABC' ? "ok 22\n" : "not ok 22\n") ;
+print ($h{'abc'} eq 'ABC' ? "ok 22\n" : "not ok 22\n") ;
 print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n");
 
 $h{'def'} = 'DEF';
@@ -152,7 +153,7 @@ while (($key,$value) = each(%h)) {
 
 if ($i == 30) {print "ok 26\n";} else {print "not ok 26\n";}
 
-@keys = ('blurfl', keys(h), 'dyick');
+@keys = ('blurfl', keys(%h), 'dyick');
 if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}
 
 #Check that the keys can be retrieved in order
@@ -345,7 +346,104 @@ print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\
 $status = $Y->fd ;
 print ($status == -1 ? "ok 73\n" : "not ok 73\n") ;
 
+
 undef $Y ;
 untie %h ;
 
+# Duplicate keys
+my $bt = new DB_File::BTREEINFO ;
+$bt->{flags} = R_DUP ;
+print (($YY = tie(%hh, DB_File, $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ? "ok 74\n" : "not ok 74");
+
+$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
+print(scalar $YY->get_dup('Unknown') == 0 ? "ok 75\n" : "not ok 75\n") ;
+print(scalar $YY->get_dup('Smith') == 1 ? "ok 76\n" : "not ok 76\n") ;
+print(scalar $YY->get_dup('Wall') == 3 ? "ok 77\n" : "not ok 77\n") ;
+
+# now in list context
+my @unknown = $YY->get_dup('Unknown') ;
+print( "@unknown" eq "" ? "ok 78\n" : "not ok 78\n") ;
+
+my @smith = $YY->get_dup('Smith') ;
+print( "@smith" eq "John" ? "ok 79\n" : "not ok 79\n") ;
+
+my @wall = $YY->get_dup('Wall') ;
+my %wall ;
+@wall{@wall} = @wall ;
+print( (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 80\n" : "not ok 80\n") ;
+
+# hash
+my %unknown = $YY->get_dup('Unknown', 1) ;
+print( keys %unknown == 0 ? "ok 81\n" : "not ok 81\n") ;
+
+my %smith = $YY->get_dup('Smith', 1) ;
+print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ;
+
+my %wall = $YY->get_dup('Wall', 1) ;
+print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ;
+
+undef $YY ;
+untie %hh ;
+unlink $Dfile;
+
+
+# test multiple callbacks
+$Dfile1 = "btree1" ;
+$Dfile2 = "btree2" ;
+$Dfile3 = "btree3" ;
+ 
+$dbh1 = TIEHASH DB_File::BTREEINFO ;
+$dbh1->{compare} = sub { $_[0] <=> $_[1] } ;
+ 
+$dbh2 = TIEHASH DB_File::BTREEINFO ;
+$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
+ 
+$dbh3 = TIEHASH DB_File::BTREEINFO ;
+$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
+ 
+ 
+tie(%h, DB_File,$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
+tie(%g, DB_File,$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
+tie(%k, DB_File,$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
+ 
+@Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
+@srt_1 = sort { $a <=> $b } @Keys ;
+@srt_2 = sort { $a cmp $b } @Keys ;
+@srt_3 = sort { length $a <=> length $b } @Keys ;
+ 
+foreach (@Keys) {
+    $h{$_} = 1 ;
+    $g{$_} = 1 ;
+    $k{$_} = 1 ;
+}
+ 
+sub ArrayCompare
+{
+    my($a, $b) = @_ ;
+ 
+    return 0 if @$a != @$b ;
+ 
+    foreach (1 .. length @$a)
+    {
+        return 0 unless $$a[$_] eq $$b[$_] ;
+    }
+ 
+    1 ;
+}
+ 
+print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 84\n" : "not ok 84\n") ;
+print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 85\n" : "not ok 85\n") ;
+print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 86\n" : "not ok 86\n") ;
+
+untie %h ;
+untie %g ;
+untie %k ;
+unlink $Dfile1, $Dfile2, $Dfile3 ;
+
 exit ;