X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDB_File%2Ft%2Fdb-hash.t;h=86a64ff7057f82efb85386452fbbf8b7c2467b21;hb=9c095db2b2b99b70926d6f45029789d614441504;hp=7dba15d721872950d1c153b23f3879415eae949c;hpb=262eaca6eb732e73845054dff64d084e4bec522e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/DB_File/t/db-hash.t b/ext/DB_File/t/db-hash.t index 7dba15d..86a64ff 100755 --- a/ext/DB_File/t/db-hash.t +++ b/ext/DB_File/t/db-hash.t @@ -23,7 +23,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..143\n"; +print "1..161\n"; unlink glob "__db.*"; @@ -34,6 +34,8 @@ sub ok print "not " unless $result ; print "ok $no\n" ; + + return $result ; } { @@ -580,7 +582,8 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $k = 'Fred'; $v =''; ok(74, ! $db->seq($k, $v, R_FIRST) ) ; - ok(75, $k eq "FRED") ; + ok(75, $k eq "Fred") ; + #print "k [$k]\n" ; ok(76, $v eq "[Jxe]") ; # fk sk fv sv ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ; @@ -874,14 +877,14 @@ EOM # # ok(128, $@ =~ /^DB_File hash callback: recursion detected/); # { -# no warnings; +# local ($^W) = 0; #no warnings; # untie %hash; # } # unlink $Dfile; #} -ok(127,1); -ok(128,1); +#ok(127,1); +#ok(128,1); { # Check that two hash's don't interact @@ -899,8 +902,8 @@ ok(128,1); my (%h); - ok(129, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); - ok(130, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); + ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); + ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); $hash1{DEFG} = 5; $hash1{XYZ} = 2; @@ -910,11 +913,11 @@ ok(128,1); $hash2{xyz} = 2; $hash2{abcde} = 5; - ok(131, $h1_count > 0); - ok(132, $h1_count == $h2_count); + ok(129, $h1_count > 0); + ok(130, $h1_count == $h2_count); - ok(133, safeUntie \%hash1); - ok(134, safeUntie \%hash2); + ok(131, safeUntie \%hash1); + ok(132, safeUntie \%hash2); unlink $Dfile, $Dfile2; } @@ -929,14 +932,17 @@ ok(128,1); unlink $Dfile; tie %hash1, 'DB_File',$Dfile, undef; - ok(135, $warn_count == 0); + ok(133, $warn_count == 0); $warn_count = 0; + unlink $Dfile; tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef; - ok(136, $warn_count == 0); + ok(134, $warn_count == 0); + unlink $Dfile; tie %hash1, 'DB_File',$Dfile, undef, undef; - ok(137, $warn_count == 0); + ok(135, $warn_count == 0); $warn_count = 0; + untie %hash1; unlink $Dfile; } @@ -949,7 +955,7 @@ ok(128,1); my $Dfile = "xxy.db"; unlink $Dfile; - ok(138, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + ok(136, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); $db->filter_fetch_key (sub { }) ; $db->filter_store_key (sub { }) ; @@ -959,10 +965,10 @@ ok(128,1); $_ = "original" ; $h{"fred"} = "joe" ; - ok(139, $h{"fred"} eq "joe"); + ok(137, $h{"fred"} eq "joe"); eval { grep { $h{$_} } (1, 2, 3) }; - ok (140, ! $@); + ok (138, ! $@); # delete the filters @@ -973,17 +979,181 @@ ok(128,1); $h{"fred"} = "joe" ; - ok(141, $h{"fred"} eq "joe"); + ok(139, $h{"fred"} eq "joe"); - ok(142, $db->FIRSTKEY() eq "fred") ; + ok(140, $db->FIRSTKEY() eq "fred") ; eval { grep { $h{$_} } (1, 2, 3) }; - ok (143, ! $@); + ok (141, ! $@); undef $db ; untie %h; unlink $Dfile; } +{ + # Check low-level API works with filter + + use warnings ; + use strict ; + my (%h, $db) ; + my $Dfile = "xxy.db"; + unlink $Dfile; + + ok(142, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + + $db->filter_fetch_key (sub { $_ = unpack("i", $_) } ); + $db->filter_store_key (sub { $_ = pack("i", $_) } ); + $db->filter_fetch_value (sub { $_ = unpack("i", $_) } ); + $db->filter_store_value (sub { $_ = pack("i", $_) } ); + + $_ = 'fred'; + + my $key = 22 ; + my $value = 34 ; + + $db->put($key, $value) ; + ok 143, $key == 22; + ok 144, $value == 34 ; + ok 145, $_ eq 'fred'; + #print "k [$key][$value]\n" ; + + my $val ; + $db->get($key, $val) ; + ok 146, $key == 22; + ok 147, $val == 34 ; + ok 148, $_ eq 'fred'; + + $key = 51 ; + $value = 454; + $h{$key} = $value ; + ok 149, $key == 51; + ok 150, $value == 454 ; + ok 151, $_ eq 'fred'; + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Regression Test for bug 30237 + # Check that substr can be used in the key to db_put + # and that db_put does not trigger the warning + # + # Use of uninitialized value in subroutine entry + + + use warnings ; + use strict ; + my (%h, $db) ; + my $Dfile = "xxy.db"; + unlink $Dfile; + + ok(152, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + my $warned = ''; + local $SIG{__WARN__} = sub {$warned = $_[0]} ; + + # db-put with substr of key + my %remember = () ; + for my $ix ( 1 .. 2 ) + { + my $key = $ix . "data" ; + my $value = "value$ix" ; + $remember{$key} = $value ; + $db->put(substr($key,0), $value) ; + } + + ok 153, $warned eq '' + or print "# Caught warning [$warned]\n" ; + + # db-put with substr of value + $warned = ''; + for my $ix ( 10 .. 12 ) + { + my $key = $ix . "data" ; + my $value = "value$ix" ; + $remember{$key} = $value ; + $db->put($key, substr($value,0)) ; + } + + ok 154, $warned eq '' + or print "# Caught warning [$warned]\n" ; + + # via the tied hash is not a problem, but check anyway + # substr of key + $warned = ''; + for my $ix ( 30 .. 32 ) + { + my $key = $ix . "data" ; + my $value = "value$ix" ; + $remember{$key} = $value ; + $h{substr($key,0)} = $value ; + } + + ok 155, $warned eq '' + or print "# Caught warning [$warned]\n" ; + + # via the tied hash is not a problem, but check anyway + # substr of value + $warned = ''; + for my $ix ( 40 .. 42 ) + { + my $key = $ix . "data" ; + my $value = "value$ix" ; + $remember{$key} = $value ; + $h{$key} = substr($value,0) ; + } + + ok 156, $warned eq '' + or print "# Caught warning [$warned]\n" ; + + my %bad = () ; + $key = ''; + for ($status = $db->seq($key, $value, R_FIRST ) ; + $status == 0 ; + $status = $db->seq($key, $value, R_NEXT ) ) { + + #print "# key [$key] value [$value]\n" ; + if (defined $remember{$key} && defined $value && + $remember{$key} eq $value) { + delete $remember{$key} ; + } + else { + $bad{$key} = $value ; + } + } + + ok 157, keys %bad == 0 ; + ok 158, keys %remember == 0 ; + + print "# missing -- $key $value\n" while ($key, $value) = each %remember; + print "# bad -- $key $value\n" while ($key, $value) = each %bad; + + # Make sure this fix does not break code to handle an undef key + # Berkeley DB undef key is bron between versions 2.3.16 and + my $value = 'fred'; + $warned = ''; + $db->put(undef, $value) ; + ok 159, $warned eq '' + or print "# Caught warning [$warned]\n" ; + $warned = ''; + + my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ; + print "# db_ver $DB_File::db_ver\n"; + $value = '' ; + $db->get(undef, $value) ; + ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ; + ok 161, $warned eq '' + or print "# Caught warning [$warned]\n" ; + $warned = ''; + + undef $db ; + untie %h; + unlink $Dfile; +} exit ;