summaryrefslogtreecommitdiff
path: root/t/test.pl
diff options
context:
space:
mode:
authorNicholas Clark <nick@ccl4.org>2001-12-10 23:22:28 +0000
committerJarkko Hietaniemi <jhi@iki.fi>2001-12-10 22:51:44 +0000
commit677fb045b6c17916b0e551a2501b48489b6ded72 (patch)
tree77dabd52c4a7de1f26296b060f6aba72c0eb64d4 /t/test.pl
parentcda41bc103281f18855c0da8ed14366b1358eda9 (diff)
downloadperl-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.pl71
1 files changed, 64 insertions, 7 deletions
diff --git a/t/test.pl b/t/test.pl
index bd5d577446..4f8a4633b5 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 <<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 {