#!./perl
+# This test was originally for pseudo-hashes. It now exists to ensure
+# they were properly removed in 5.9.
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
sub STORE { $_[0]->[$_[1]] = $_[2] }
sub FETCH { $_[0]->[$_[1]] }
sub FETCHSIZE { scalar(@{$_[0]})}
-sub STORESIZE { $#{$_[0]} = $_[1]+1 }
+sub STORESIZE { $#{$_[0]} = $_[1]+1 }
package main;
-print "1..29\n";
+require './test.pl';
+plan(tests => 40);
+
+# Helper function to check the typical error message.
+sub not_hash {
+ my($err) = shift;
+ like( $err, qr/^Not a HASH reference / ) ||
+ printf STDERR "# at %s line %d.\n", (caller)[1,2];
+}
+
+# Something to place inside if blocks and while loops that won't get
+# compiled out.
+my $foo = 42;
+sub no_op { $foo++ }
+
$sch = {
'abc' => 1,
$a = [];
$a->[0] = $sch;
-$a->{'abc'} = 'ABC';
-$a->{'def'} = 'DEF';
-$a->{'jkl'} = 'JKL';
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
-@keys = keys %$a;
-@values = values %$a;
+eval {
+ $a->{'def'} = 'DEF';
+};
+not_hash($@);
-if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";}
+eval {
+ $a->{'jkl'} = 'JKL';
+};
+not_hash($@);
-$i = 0; # stop -w complaints
+eval {
+ @keys = keys %$a;
+};
+not_hash($@);
+
+eval {
+ @values = values %$a;
+};
+not_hash($@);
-while (($key,$value) = each %$a) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
- $key =~ y/a-z/A-Z/;
- $i++ if $key eq $value;
+eval {
+ while( my($k,$v) = each %$a ) {
+ no_op;
}
-}
+};
+not_hash($@);
-if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";}
# quick check with tied array
tie @fake, 'Tie::StdArray';
$a = \@fake;
$a->[0] = $sch;
-$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
+
+eval {
+ if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
+};
+not_hash($@);
# quick check with tied array
tie @fake, 'Tie::BasicArray';
$a = \@fake;
$a->[0] = $sch;
-$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
+
+eval {
+ if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
+};
+not_hash($@);
# quick check with tied array & tied hash
require Tie::Hash;
%fake = %$sch;
$a->[0] = \%fake;
-$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
+eval {
+ $a->{'abc'} = 'ABC';
+};
+not_hash($@);
+
+eval {
+ if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
+};
+not_hash($@);
+
# hash slice
-my $slice = join('', 'x',@$a{'abc','def'},'x');
-print "not " if $slice ne 'xABCx';
-print "ok 6\n";
+eval {
+ my $slice = join('', 'x',@$a{'abc','def'},'x');
+};
+not_hash($@);
+
# evaluation in scalar context
my $avhv = [{}];
-print "not " if %$avhv;
-print "ok 7\n";
+
+eval {
+ () = %$avhv;
+};
+not_hash($@);
push @$avhv, "a";
-print "not " if %$avhv;
-print "ok 8\n";
+eval {
+ () = %$avhv;
+};
+not_hash($@);
$avhv = [];
eval { $a = %$avhv };
-print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;
-print "ok 9\n";
+not_hash($@);
$avhv = [{foo=>1, bar=>2}];
-print "not " unless %$avhv =~ m,^\d+/\d+,;
-print "ok 10\n";
+eval {
+ %$avhv =~ m,^\d+/\d+,;
+};
+not_hash($@);
# check if defelem magic works
sub f {
print "ok 11\n";
}
$a = [{key => 1}, 'a'];
-f($a->{key});
-print "not " unless $a->[1] eq 'b';
-print "ok 12\n";
+eval {
+ f($a->{key});
+};
+not_hash($@);
# check if exists() is behaving properly
$avhv = [{foo=>1,bar=>2,pants=>3}];
-print "not " if exists $avhv->{bar};
-print "ok 13\n";
+eval {
+ no_op if exists $avhv->{bar};
+};
+not_hash($@);
+
+eval {
+ $avhv->{pants} = undef;
+};
+not_hash($@);
-$avhv->{pants} = undef;
-print "not " unless exists $avhv->{pants};
-print "ok 14\n";
-print "not " if exists $avhv->{bar};
-print "ok 15\n";
+eval {
+ no_op if exists $avhv->{pants};
+};
+not_hash($@);
+
+eval {
+ no_op if exists $avhv->{bar};
+};
+not_hash($@);
-$avhv->{bar} = 10;
-print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10;
-print "ok 16\n";
+eval {
+ $avhv->{bar} = 10;
+};
+not_hash($@);
-$v = delete $avhv->{bar};
-print "not " unless $v == 10;
-print "ok 17\n";
+eval {
+ no_op unless exists $avhv->{bar} and $avhv->{bar} == 10;
+};
+not_hash($@);
-print "not " if exists $avhv->{bar};
-print "ok 18\n";
+eval {
+ $v = delete $avhv->{bar};
+};
+not_hash($@);
-$avhv->{foo} = 'xxx';
-$avhv->{bar} = 'yyy';
-$avhv->{pants} = 'zzz';
-@x = delete @{$avhv}{'foo','pants'};
-print "# @x\nnot " unless "@x" eq "xxx zzz";
-print "ok 19\n";
+eval {
+ no_op if exists $avhv->{bar};
+};
+not_hash($@);
-print "not " unless "$avhv->{bar}" eq "yyy";
-print "ok 20\n";
+eval {
+ $avhv->{foo} = 'xxx';
+};
+not_hash($@);
+eval {
+ $avhv->{bar} = 'yyy';
+};
+not_hash($@);
+eval {
+ $avhv->{pants} = 'zzz';
+};
+not_hash($@);
+eval {
+ @x = delete @{$avhv}{'foo','pants'};
+};
+not_hash($@);
+eval {
+ no_op unless "$avhv->{bar}" eq "yyy";
+};
+not_hash($@);
# hash assignment
-%$avhv = ();
-print "not " unless ref($avhv->[0]) eq 'HASH';
-print "ok 21\n";
+eval {
+ %$avhv = ();
+};
+not_hash($@);
-%hv = %$avhv;
-print "not " if grep defined, values %hv;
-print "ok 22\n";
-print "not " if grep ref, keys %hv;
-print "ok 23\n";
+eval {
+ %hv = %$avhv;
+};
+not_hash($@);
-%$avhv = (foo => 29, pants => 2, bar => 0);
-print "not " unless "@$avhv[1..3]" eq '29 0 2';
-print "ok 24\n";
+eval {
+ %$avhv = (foo => 29, pants => 2, bar => 0);
+};
+not_hash($@);
my $extra;
my @extra;
-($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo';
-print "ok 25\n";
-
-%$avhv = ();
-(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra;
-print "ok 26\n";
-
-@extra = qw(whatever and stuff);
-%$avhv = ();
-(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0;
-print "ok 27\n";
-
-%$avhv = ();
-(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
-print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6;
-print "ok 28\n";
+eval {
+ ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
+
+eval {
+ %$avhv = ();
+ (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
+
+eval {
+ @extra = qw(whatever and stuff);
+ %$avhv = ();
+};
+not_hash($@);
+eval {
+ (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
+
+eval {
+ (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
+};
+not_hash($@);
# Check hash slices (BUG ID 20010423.002)
$avhv = [{foo=>1, bar=>2}];
-@$avhv{"foo", "bar"} = (42, 53);
-print "not " unless $avhv->{foo} == 42 && $avhv->{bar} == 53;
-print "ok 29\n";
+eval {
+ @$avhv{"foo", "bar"} = (42, 53);
+};
+not_hash($@);
projects / p5sagit/p5-mst-13.2.git / blobdiff