diff options
author | Nicholas Clark <nick@ccl4.org> | 2001-12-10 23:22:28 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-12-10 22:51:44 +0000 |
commit | 677fb045b6c17916b0e551a2501b48489b6ded72 (patch) | |
tree | 77dabd52c4a7de1f26296b060f6aba72c0eb64d4 /t/test.pl | |
parent | cda41bc103281f18855c0da8ed14366b1358eda9 (diff) | |
download | perl-677fb045b6c17916b0e551a2501b48489b6ded72.tar.gz |
Re: [PATCH] tests for hash assignment
Message-ID: <20011210232228.M21702@plum.flirble.org>
p4raw-id: //depot/perl@13604
Diffstat (limited to 't/test.pl')
-rw-r--r-- | t/test.pl | 71 |
1 files changed, 64 insertions, 7 deletions
@@ -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 <<REQUIRE_OK; @@ -265,13 +329,6 @@ sub BAILOUT { 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 { |