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';
@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
}
}
-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);
$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.
$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) }
}
--- /dev/null
+#!./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');
+
+}
+
+
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;
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 <<REQUIRE_OK;
exit;
}
-
-# A way to display scalars containing control characters and Unicode.
-sub display {
- map { join("", map { $_ > 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 {
projects / p5sagit/p5-mst-13.2.git / commitdiff