From: Perl 5 Porters <perl5-porters@africa.nicoh.com>
Date: Fri, 5 Jul 1996 05:45:43 +0000 (+0000)
Subject: Updated as part of DB_File update
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=55d68b4ac0573816c9fea55197ad747423809658;p=p5sagit%2Fp5-mst-13.2.git

Updated as part of DB_File update
---

diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t
index d90de6c..f3cf944 100755
--- a/t/lib/db-btree.t
+++ b/t/lib/db-btree.t
@@ -12,16 +12,17 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..76\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,9 +346,53 @@ 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" ;
@@ -392,9 +437,9 @@ sub ArrayCompare
     1 ;
 }
  
-print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 74\n" : "not ok 74\n") ;
-print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 75\n" : "not ok 75\n") ;
-print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 76\n" : "not ok 76\n") ;
+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 ;
diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t
index 6c3ef55..5205fae 100755
--- a/t/lib/db-hash.t
+++ b/t/lib/db-hash.t
@@ -14,14 +14,15 @@ use Fcntl;
 
 print "1..43\n";
 
-$Dfile = "Op.db-hash";
+$Dfile = "dbhash.tmp";
 unlink $Dfile;
 
 umask(0);
 
 # Check the interface to HASHINFO
 
-$dbh = TIEHASH DB_File::HASHINFO ;
+#$dbh = TIEHASH DB_File::HASHINFO ;
+$dbh = new DB_File::HASHINFO ;
 print (($dbh->{bsize} == undef) ? "ok 1\n" : "not ok 1\n") ;
 print (($dbh->{ffactor} == undef) ? "ok 2\n" : "not ok 2\n") ;
 print (($dbh->{nelem} == undef) ? "ok 3\n" : "not ok 3\n") ;
@@ -49,9 +50,9 @@ print ($dbh->{lorder} == 1234 ? "ok 12\n" : "not ok 12\n") ;
 
 # Check that an invalid entry is caught both for store & fetch
 eval '$dbh->{fred} = 1234' ;
-print ($@ eq '' ? "ok 13\n" : "not ok 13\n") ;
+print ($@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ? "ok 13\n" : "not ok 13\n") ;
 eval '$q = $dbh->{fred}' ;
-print ($@ eq '' ? "ok 14\n" : "not ok 14\n") ;
+print ($@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ? "ok 14\n" : "not ok 14\n") ;
 
 # Now check the interface to HASH
 
@@ -69,7 +70,7 @@ print (!$i ? "ok 17\n" : "not ok 17\n");
 $h{'goner1'} = 'snork';
 
 $h{'abc'} = 'ABC';
-print ($h{'abc'} == 'ABC' ? "ok 18\n" : "not ok 18\n") ;
+print ($h{'abc'} eq 'ABC' ? "ok 18\n" : "not ok 18\n") ;
 print (defined $h{'jimmy'} ? "not ok 19\n" : "ok 19\n");
 
 $h{'def'} = 'DEF';
@@ -135,7 +136,7 @@ $X->DELETE('goner3');
 
 if ($#keys == 29 && $#values == 29) {print "ok 21\n";} else {print "not ok 21\n";}
 
-while (($key,$value) = each(h)) {
+while (($key,$value) = each(%h)) {
     if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
 	$key =~ y/a-z/A-Z/;
 	$i++ if $key eq $value;
@@ -144,7 +145,7 @@ while (($key,$value) = each(h)) {
 
 if ($i == 30) {print "ok 22\n";} else {print "not ok 22\n";}
 
-@keys = ('blurfl', keys(h), 'dyick');
+@keys = ('blurfl', keys(%h), 'dyick');
 if ($#keys == 31) {print "ok 23\n";} else {print "not ok 23\n";}
 
 $h{'foo'} = '';
diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t
index 64ad7b8..ba5c7ed 100755
--- a/t/lib/db-recno.t
+++ b/t/lib/db-recno.t
@@ -11,24 +11,35 @@ BEGIN {
 
 use DB_File; 
 use Fcntl;
+use strict ;
+use vars qw($dbh $Dfile) ;
 
-print "1..30\n";
+sub ok
+{
+    my $no = shift ;
+    my $result = shift ;
 
-$Dfile = "Op.db-recno";
-unlink $Dfile;
+    print "not " unless $result ;
+    print "ok $no\n" ;
+}
+
+print "1..35\n";
+
+my $Dfile = "recno.tmp";
+unlink $Dfile ;
 
 umask(0);
 
 # Check the interface to RECNOINFO
 
-$dbh = TIEHASH DB_File::RECNOINFO ;
-print (($dbh->{bval} == 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") ;
-print (($dbh->{flags} == undef) ? "ok 4\n" : "not ok 4\n") ;
-print (($dbh->{lorder} == undef) ? "ok 5\n" : "not ok 5\n") ;
-print (($dbh->{reclen} == undef) ? "ok 6\n" : "not ok 6\n") ;
-print (($dbh->{bfname} == undef) ? "ok 7\n" : "not ok 7\n") ;
+my $dbh = new DB_File::RECNOINFO ;
+ok(1, $dbh->{bval} == undef ) ;
+ok(2, $dbh->{cachesize} == undef) ;
+ok(3, $dbh->{psize} == undef) ;
+ok(4, $dbh->{flags} == undef) ;
+ok(5, $dbh->{lorder} == undef);
+ok(6, $dbh->{reclen} == undef);
+ok(7, $dbh->{bfname} eq undef);
 
 $dbh->{bval} = 3000 ;
 print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ;
@@ -54,27 +65,29 @@ print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ;
 
 # Check that an invalid entry is caught both for store & fetch
 eval '$dbh->{fred} = 1234' ;
-print ($@ eq '' ? "ok 15\n" : "not ok 15\n") ;
-eval '$q = $dbh->{fred}' ;
-print ($@ eq '' ? "ok 16\n" : "not ok 16\n") ;
+print ($@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ? "ok 15\n" : "not ok 15\n") ;
+eval 'my $q = $dbh->{fred}' ;
+print ($@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ? "ok 16\n" : "not ok 16\n") ;
 
 # Now check the interface to RECNOINFO
 
-print (($X = tie(@h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO )) ? "ok 17\n" : "not ok 17");
+my $X  ;
+my @h ;
+ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+#print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");
 
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
-   $blksize,$blocks) = stat($Dfile);
-print (($mode & 0777) == 0640 ? "ok 18\n" : "not ok 18\n");
+ok(18, ( (stat($Dfile))[2] & 0777) == 0640) ;
 
-#$l = @h ;
-$l = $X->length ;
+#my $l = @h ;
+my $l = $X->length ;
 print (!$l ? "ok 19\n" : "not ok 19\n");
 
-@data = qw( a b c d ever f g h  i j k longername m n o p) ;
+my @data = qw( a b c d ever f g h  i j k longername m n o p) ;
 
 $h[0] = shift @data ;
 print ($h[0] eq 'a' ? "ok 20\n" : "not ok 20\n") ;
 
+my $ i;
 foreach (@data)
   { $h[++$i] = $_ }
 
@@ -91,7 +104,7 @@ $data[3] = 'replaced' ;
 print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n");
 
 #PUSH
-@push_data = qw(added to the end) ;
+my @push_data = qw(added to the end) ;
 #push (@h, @push_data) ;
 $X->push(@push_data) ;
 push (@data, @push_data) ;
@@ -100,7 +113,7 @@ print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n");
 # POP
 pop (@data) ;
 #$value = pop(@h) ;
-$value = $X->pop ;
+my $value = $X->pop ;
 print ($value eq 'end' ? "not ok 26\n" : "ok 26\n");
 
 # SHIFT
@@ -114,7 +127,7 @@ print ($value eq shift @data ? "not ok 27\n" : "ok 27\n");
 $X->unshift ;
 print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ;
 
-@new_data = qw(add this to the start of the array) ;
+my @new_data = qw(add this to the start of the array) ;
 #unshift @h, @new_data ;
 $X->unshift (@new_data) ;
 unshift (@data, @new_data) ;
@@ -124,14 +137,29 @@ print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ;
 
 # Now both arrays should be identical
 
-$ok = 1 ;
-$j = 0 ;
+my $ok = 1 ;
+my $j = 0 ;
 foreach (@data)
 {
    $ok = 0, last if $_ ne $h[$j ++] ; 
 }
 print ($ok ? "ok 30\n" : "not ok 30\n") ;
 
+# Neagtive subscripts
+
+# get the last element of the array
+print($h[-1] eq $data[-1] ? "ok 31\n" : "not ok 31\n") ;
+print($h[-1] eq $h[$X->length -1] ? "ok 32\n" : "not ok 32\n") ;
+
+# get the first element using a negative subscript
+eval '$h[ - ( $X->length)] = "abcd"' ;
+print ($@ eq "" ? "ok 33\n" : "not ok 33\n") ;
+print ($h[0] eq "abcd" ? "ok 34\n" : "not ok 34\n") ;
+
+# now try to read before the start of the array
+eval '$h[ - (1 + $X->length)] = 1234' ;
+print ($@ =~ '^Modification of non-creatable array value attempted' ? "ok 35\n" : "not ok 35\n") ;
+
 # IMPORTANT - $X must be undefined before the untie otherwise the
 #             underlying DB close routine will not get called.
 undef $X ;