From: Nicholas Clark Date: Mon, 10 Dec 2001 23:22:28 +0000 (+0000) Subject: Re: [PATCH] tests for hash assignment X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=677fb045b6c17916b0e551a2501b48489b6ded72;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH] tests for hash assignment Message-ID: <20011210232228.M21702@plum.flirble.org> p4raw-id: //depot/perl@13604 --- diff --git a/MANIFEST b/MANIFEST index 34a181f..5501dbf 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2190,6 +2190,7 @@ t/op/grent.t See if getgr*() functions work t/op/grep.t See if grep() and map() work t/op/groups.t See if $( works t/op/gv.t See if typeglobs work +t/op/hashassign.t See if hash assignments work t/op/hashwarn.t See if warnings for bad hash assignments work t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/inccode.t See if coderefs work in @INC diff --git a/t/op/each.t b/t/op/each.t index eb2dce0..556479e 100755 --- a/t/op/each.t +++ b/t/op/each.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; + @INC = '../lib'; + require './test.pl'; } -print "1..27\n"; +plan tests => 34; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -42,7 +42,8 @@ $h{'z'} = 'Z'; @keys = keys %h; @values = values %h; -if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";} +ok ($#keys == 29, "keys"); +ok ($#values == 29, "values"); $i = 0; # stop -w complaints @@ -54,65 +55,58 @@ while (($key,$value) = each(%h)) { } } -if ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";} +ok ($i == 30, "each count"); @keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";} +ok ($#keys == 31, "added a key"); $size = ((split('/',scalar %h))[1]); keys %h = $size * 5; $newsize = ((split('/',scalar %h))[1]); -if ($newsize == $size * 8) {print "ok 4\n";} else {print "not ok 4\n";} +ok ($newsize == $size * 8, "resize"); keys %h = 1; $size = ((split('/',scalar %h))[1]); -if ($size == $newsize) {print "ok 5\n";} else {print "not ok 5\n";} +ok ($size == $newsize, "same size"); %h = (1,1); $size = ((split('/',scalar %h))[1]); -if ($size == $newsize) {print "ok 6\n";} else {print "not ok 6\n";} +ok ($size == $newsize, "still same size"); undef %h; %h = (1,1); $size = ((split('/',scalar %h))[1]); -if ($size == 8) {print "ok 7\n";} else {print "not ok 7\n";} +ok ($size == 8, "size 8"); # test scalar each %hash = 1..20; $total = 0; $total += $key while $key = each %hash; -print "# Scalar each is bad.\nnot " unless $total == 100; -print "ok 8\n"; +ok ($total == 100, "test scalar each"); for (1..3) { @foo = each %hash } keys %hash; $total = 0; $total += $key while $key = each %hash; -print "# Scalar keys isn't resetting the iterator.\nnot " if $total != 100; -print "ok 9\n"; +ok ($total == 100, "test scalar keys resets iterator"); for (1..3) { @foo = each %hash } $total = 0; $total += $key while $key = each %hash; -print "# Iterator of each isn't being maintained.\nnot " if $total == 100; -print "ok 10\n"; +ok ($total != 100, "test iterator of each is being maintained"); for (1..3) { @foo = each %hash } values %hash; $total = 0; $total += $key while $key = each %hash; -print "# Scalar values isn't resetting the iterator.\nnot " if $total != 100; -print "ok 11\n"; +ok ($total == 100, "test values keys resets iterator"); $size = (split('/', scalar %hash))[1]; keys(%hash) = $size / 2; -print "not " if $size != (split('/', scalar %hash))[1]; -print "ok 12\n"; +ok ($size == (split('/', scalar %hash))[1]); keys(%hash) = $size + 100; -print "not " if $size == (split('/', scalar %hash))[1]; -print "ok 13\n"; +ok ($size != (split('/', scalar %hash))[1]); -print "not " if keys(%hash) != 10; -print "ok 14\n"; +ok (keys(%hash) == 10, "keys (%hash)"); -print keys(hash) != 10 ? "not ok 15\n" : "ok 15\n"; +ok (keys(hash) == 10, "keys (hash)"); $i = 0; %h = (a => A, b => B, c=> C, d => D, abc => ABC); @@ -123,18 +117,19 @@ while (($key, $value) = each(h)) { $i++; } } -if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } +ok ($i == 5); +@tests = (&next_test, &next_test, &next_test); { package Obj; - sub DESTROY { print "ok 18\n"; } + sub DESTROY { print "ok $::tests[1] # DESTROY called\n"; } { my $h = { A => bless [], __PACKAGE__ }; while (my($k,$v) = each %$h) { - print "ok 17\n" if $k eq 'A' and ref($v) eq 'Obj'; + print "ok $::tests[0]\n" if $k eq 'A' and ref($v) eq 'Obj'; } } - print "ok 19\n"; + print "ok $::tests[2]\n"; } # Check for Unicode hash keys. @@ -142,39 +137,34 @@ if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } $u{"\x{12345}"} = "bar"; @u{"\x{123456}"} = "zap"; +my %u2; foreach (keys %u) { - unless (length() == 1) { - print "not "; - last; - } + ok (length() == 1, "Check length of " . _qq $_); + $u2{$_} = $u{$_}; } -print "ok 20\n"; +ok (eq_hash(\%u, \%u2), "copied unicode hash keys correctly?"); $a = "\xe3\x81\x82"; $A = "\x{3042}"; %b = ( $a => "non-utf8"); %u = ( $A => "utf8"); -print "not " if exists $b{$A}; -print "ok 21\n"; -print "not " if exists $u{$a}; -print "ok 22\n"; +ok (!exists $b{$A}, "utf8 key in bytes hash"); +ok (!exists $u{$a}, "bytes key in utf8 hash"); print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056. -print "ok 23\n"; +pass ("if we got here change 8056 worked"); print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056. -print "ok 24\n"; +pass ("change 8056 is thanks to Inaba Hiroto"); # on EBCDIC chars are mapped differently so pick something that needs encoding # there too. $d = pack("U*", 0xe3, 0x81, 0xAF); { use bytes; $ol = bytes::length($d) } -print "not " unless $ol > 3; -print "ok 25\n"; +ok ($ol > 3, "check encoding on EBCDIC"); %u = ($d => "downgrade"); for (keys %u) { - print "not " if length ne 3 or $_ ne "\xe3\x81\xAF"; - print "ok 26\n"; + ok (length == 3, "check length"); + is ($_, "\xe3\x81\xAF", "check value"); } { - { use bytes; print "not " if bytes::length($d) != $ol } - print "ok 27\n"; + { use bytes; ok (bytes::length($d) == $ol) } } diff --git a/t/op/hashassign.t b/t/op/hashassign.t new file mode 100644 index 0000000..a1c66c3 --- /dev/null +++ b/t/op/hashassign.t @@ -0,0 +1,275 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} + +# use strict; + +plan tests => 206; + +my @comma = ("key", "value"); + +# The peephole optimiser already knows that it should convert the string in +# $foo{string} into a shared hash key scalar. It might be worth making the +# tokeniser build the LHS of => as a shared hash key scalar too. +# And so there's the possiblility of it going wrong +# And going right on 8 bit but wrong on utf8 keys. +# And really we should also try utf8 literals in {} and => in utf8.t + +# Some of these tests are (effectively) duplicated in each.t +my %comma = @comma; +ok (keys %comma == 1, 'keys on comma hash'); +ok (values %comma == 1, 'values on comma hash'); +# defeat any tokeniser or optimiser cunning +my $key = 'ey'; +is ($comma{"k" . $key}, "value", 'is key present? (unoptimised)'); +# now with cunning: +is ($comma{key}, "value", 'is key present? (maybe optimised)'); +#tokeniser may treat => differently. +my @temp = (key=>undef); +is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); + +@temp = %comma; +ok (eq_array (\@comma, \@temp), 'list from comma hash'); + +@temp = each %comma; +ok (eq_array (\@comma, \@temp), 'first each from comma hash'); +@temp = each %comma; +ok (eq_array ([], \@temp), 'last each from comma hash'); + +my %temp = %comma; + +ok (keys %temp == 1, 'keys on copy of comma hash'); +ok (values %temp == 1, 'values on copy of comma hash'); +is ($temp{'k' . $key}, "value", 'is key present? (unoptimised)'); +# now with cunning: +is ($temp{key}, "value", 'is key present? (maybe optimised)'); +@temp = (key=>undef); +is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); + +@temp = %temp; +ok (eq_array (\@temp, \@temp), 'list from copy of comma hash'); + +@temp = each %temp; +ok (eq_array (\@temp, \@temp), 'first each from copy of comma hash'); +@temp = each %temp; +ok (eq_array ([], \@temp), 'last each from copy of comma hash'); + +my @arrow = (Key =>"Value"); + +my %arrow = @arrow; +ok (keys %arrow == 1, 'keys on arrow hash'); +ok (values %arrow == 1, 'values on arrow hash'); +# defeat any tokeniser or optimiser cunning +$key = 'ey'; +is ($arrow{"K" . $key}, "Value", 'is key present? (unoptimised)'); +# now with cunning: +is ($arrow{Key}, "Value", 'is key present? (maybe optimised)'); +#tokeniser may treat => differently. +@temp = ('Key', undef); +is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); + +@temp = %arrow; +ok (eq_array (\@arrow, \@temp), 'list from arrow hash'); + +@temp = each %arrow; +ok (eq_array (\@arrow, \@temp), 'first each from arrow hash'); +@temp = each %arrow; +ok (eq_array ([], \@temp), 'last each from arrow hash'); + +%temp = %arrow; + +ok (keys %temp == 1, 'keys on copy of arrow hash'); +ok (values %temp == 1, 'values on copy of arrow hash'); +is ($temp{'K' . $key}, "Value", 'is key present? (unoptimised)'); +# now with cunning: +is ($temp{Key}, "Value", 'is key present? (maybe optimised)'); +@temp = ('Key', undef); +is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); + +@temp = %temp; +ok (eq_array (\@temp, \@temp), 'list from copy of arrow hash'); + +@temp = each %temp; +ok (eq_array (\@temp, \@temp), 'first each from copy of arrow hash'); +@temp = each %temp; +ok (eq_array ([], \@temp), 'last each from copy of arrow hash'); + +my %direct = ('Camel', 2, 'Dromedary', 1); +my %slow; +$slow{Dromedary} = 1; +$slow{Camel} = 2; + +ok (eq_hash (\%slow, \%direct), "direct list assignment to hash"); +%direct = (Camel => 2, 'Dromedary' => 1); +ok (eq_hash (\%slow, \%direct), "direct list assignment to hash using =>"); + +$slow{Llama} = 0; # A llama is not a camel :-) +ok (!eq_hash (\%direct, \%slow), "different hashes should not be equal!"); + +my (%names, %names_copy); +%names = ('$' => 'Scalar', '@' => 'Array', # Grr ' + '%', 'Hash', '&', 'Code'); +%names_copy = %names; +ok (eq_hash (\%names, \%names_copy), "check we can copy our hash"); + +sub in { + my %args = @_; + return eq_hash (\%names, \%args); +} + +ok (in (%names), "pass hash into a method"); + +sub in_method { + my $self = shift; + my %args = @_; + return eq_hash (\%names, \%args); +} + +ok (main->in_method (%names), "pass hash into a method"); + +sub out { + return %names; +} +%names_copy = out (); + +ok (eq_hash (\%names, \%names_copy), "pass hash from a subroutine"); + +sub out_method { + my $self = shift; + return %names; +} +%names_copy = main->out_method (); + +ok (eq_hash (\%names, \%names_copy), "pass hash from a method"); + +sub in_out { + my %args = @_; + return %args; +} +%names_copy = in_out (%names); + +ok (eq_hash (\%names, \%names_copy), "pass hash to and from a subroutine"); + +sub in_out_method { + my $self = shift; + my %args = @_; + return %args; +} +%names_copy = main->in_out_method (%names); + +ok (eq_hash (\%names, \%names_copy), "pass hash to and from a method"); + +my %names_copy2 = %names; +ok (eq_hash (\%names, \%names_copy2), "check copy worked"); + +# This should get ignored. +%names_copy = ('%', 'Associative Array', %names); + +ok (eq_hash (\%names, \%names_copy), "duplicates at the start of a list"); + +# This should not +%names_copy = ('*', 'Typeglob', %names); + +$names_copy2{'*'} = 'Typeglob'; +ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at the end of a list"); + +%names_copy = ('%', 'Associative Array', '*', 'Endangered species', %names, + '*', 'Typeglob',); + +ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at both ends"); + +# And now UTF8 + +foreach my $chr (60, 200, 600, 6000, 60000) { + # This little game may set a UTF8 flag internally. Or it may not. :-) + my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}"); + chop ($key, $value); + my @utf8c = ($key, $value); + my %utf8c = @utf8c; + + ok (keys %utf8c == 1, 'keys on utf8 comma hash'); + ok (values %utf8c == 1, 'values on utf8 comma hash'); + # defeat any tokeniser or optimiser cunning + is ($utf8c{"" . $key}, $value, 'is key present? (unoptimised)'); + my $tempval = sprintf '$utf8c{"\x{%x}"}', $chr; + is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); + $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; + eval $tempval or die "'$tempval' gave $@"; + is ($utf8c{$temp[0]}, $value, 'is key present? (using LHS of $tempval)'); + + @temp = %utf8c; + ok (eq_array (\@utf8c, \@temp), 'list from utf8 comma hash'); + + @temp = each %utf8c; + ok (eq_array (\@utf8c, \@temp), 'first each from utf8 comma hash'); + @temp = each %utf8c; + ok (eq_array ([], \@temp), 'last each from utf8 comma hash'); + + %temp = %utf8c; + + ok (keys %temp == 1, 'keys on copy of utf8 comma hash'); + ok (values %temp == 1, 'values on copy of utf8 comma hash'); + is ($temp{"" . $key}, $value, 'is key present? (unoptimised)'); + $tempval = sprintf '$temp{"\x{%x}"}', $chr; + is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); + $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; + eval $tempval or die "'$tempval' gave $@"; + is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); + + @temp = %temp; + ok (eq_array (\@temp, \@temp), 'list from copy of utf8 comma hash'); + + @temp = each %temp; + ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 comma hash'); + @temp = each %temp; + ok (eq_array ([], \@temp), 'last each from copy of utf8 comma hash'); + + my $assign = sprintf '("\x{%x}" => "%d")', $chr, $chr; + print "# $assign\n"; + my (@utf8a) = eval $assign; + + my %utf8a = @utf8a; + ok (keys %utf8a == 1, 'keys on utf8 arrow hash'); + ok (values %utf8a == 1, 'values on utf8 arrow hash'); + # defeat any tokeniser or optimiser cunning + is ($utf8a{$key . ""}, $value, 'is key present? (unoptimised)'); + $tempval = sprintf '$utf8a{"\x{%x}"}', $chr; + is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); + $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; + eval $tempval or die "'$tempval' gave $@"; + is ($utf8a{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); + + @temp = %utf8a; + ok (eq_array (\@utf8a, \@temp), 'list from utf8 arrow hash'); + + @temp = each %utf8a; + ok (eq_array (\@utf8a, \@temp), 'first each from utf8 arrow hash'); + @temp = each %utf8a; + ok (eq_array ([], \@temp), 'last each from utf8 arrow hash'); + + %temp = %utf8a; + + ok (keys %temp == 1, 'keys on copy of utf8 arrow hash'); + ok (values %temp == 1, 'values on copy of utf8 arrow hash'); + is ($temp{'' . $key}, $value, 'is key present? (unoptimised)'); + $tempval = sprintf '$temp{"\x{%x}"}', $chr; + is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); + $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; + eval $tempval or die "'$tempval' gave $@"; + is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); + + @temp = %temp; + ok (eq_array (\@temp, \@temp), 'list from copy of utf8 arrow hash'); + + @temp = each %temp; + ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 arrow hash'); + @temp = each %temp; + ok (eq_array ([], \@temp), 'last each from copy of utf8 arrow hash'); + +} + + diff --git a/t/test.pl b/t/test.pl index bd5d577..4f8a463 100644 --- a/t/test.pl +++ b/t/test.pl @@ -79,10 +79,47 @@ sub _q { my $x = shift; return 'undef' unless defined $x; my $q = $x; + $q =~ s/\\/\\\\/; $q =~ s/'/\\'/; return "'$q'"; } +sub _qq { + my $x = shift; + return defined $x ? '"' . display ($x) . '"' : 'undef'; +}; + +# keys are the codes \n etc map to, values are 2 char strings such as \n +my %backslash_escape; +foreach my $x (split //, 'nrtfa\\\'"') { + $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; +} +# A way to display scalars containing control characters and Unicode. +# Trying to avoid setting $_, or relying on local $_ to work. +sub display { + my @result; + foreach my $x (@_) { + if (defined $x and not ref $x) { + my $y = ''; + foreach my $c (unpack("U*", $x)) { + if ($c > 255) { + $y .= sprintf "\\x{%x}", $c; + } elsif ($backslash_escape{$c}) { + $y .= $backslash_escape{$c}; + } else { + my $z = chr $c; # Maybe we can get away with a literal... + $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; + $y .= $z; + } + } + $x = $y; + } + return $x unless wantarray; + push @result, $x; + } + return @result; +} + sub is { my ($got, $expected, $name, @mess) = @_; my $pass = $got eq $expected; @@ -160,6 +197,33 @@ sub eq_array { return 1; } +sub eq_hash { + my ($orig, $suspect) = @_; + my $fail; + while (my ($key, $value) = each %$suspect) { + # Force a hash recompute if this perl's internals can cache the hash key. + $key = "" . $key; + if (exists $orig->{$key}) { + if ($orig->{$key} ne $value) { + print "# key ", _qq($key), " was ", _qq($orig->{$key}), + " now ", _qq($value), "\n"; + $fail = 1; + } + } else { + print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; + $fail = 1; + } + } + foreach (keys %$orig) { + # Force a hash recompute if this perl's internals can cache the hash key. + $_ = "" . $_; + next if (exists $suspect->{$_}); + print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; + $fail = 1; + } + !$fail; +} + sub require_ok { my ($require) = @_; eval < 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_)) } @_; -} - - # A somewhat safer version of the sometimes wrong $^X. my $Perl; sub which_perl {