3 # Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
5 # The testing is in two parts: first, run lots of tests on both a tied
6 # hash and an ordinary un-tied hash, and check they give the same
7 # answer. Then there are tests for those cases where the tied hashes
8 # should behave differently to normal hashes, that is, when using
13 if( $ENV{PERL_CORE} ) {
20 unless ( eval { require Data::Dumper; 1 } ) {
21 print "1..0 # Skip -- Data::Dumper is not available\n";
31 print "1..$numtests\n";
33 my $ref = []; my $ref1 = [];
35 package Boustrophedon; # A class with overloaded "".
36 sub new { my ($c, $s) = @_; bless \$s, $c }
37 use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} };
39 my $ox = Boustrophedon->new("foobar");
41 # Test standard hash functionality, by performing the same operations
42 # on a tied hash and on a normal hash, and checking that the results
43 # are the same. This does of course assume that Perl hashes are not
46 my @tests = standard_hash_tests();
48 my @ordinary_results = runtests(\@tests, undef);
49 foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
50 my @tied_results = runtests(\@tests, $class);
53 die if @ordinary_results != @tied_results;
54 foreach my $i (0 .. $#ordinary_results) {
55 my ($or, $ow, $oe) = @{$ordinary_results[$i]};
56 my ($tr, $tw, $te) = @{$tied_results[$i]};
60 $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr);
61 $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw);
62 $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te);
66 "failed for $class: $tests[$i]\n",
67 "ordinary hash gave:\n",
68 defined $or ? "\tresult: $or\n" : "\tundef result\n",
69 defined $ow ? "\twarning: $ow\n" : "\tno warning\n",
70 defined $oe ? "\texception: $oe\n" : "\tno exception\n",
71 "tied $class hash gave:\n",
72 defined $tr ? "\tresult: $tr\n" : "\tundef result\n",
73 defined $tw ? "\twarning: $tw\n" : "\tno warning\n",
74 defined $te ? "\texception: $te\n" : "\tno exception\n",
82 # Now test Tie::RefHash's special powers
84 $h = eval { tie %h, 'Tie::RefHash' };
87 test(ref($h) eq 'Tie::RefHash');
88 test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/);
90 test($h{$ref} eq 'cholet');
91 test(exists $h{$ref});
93 test(ref((keys %h)[0]) eq 'ARRAY');
94 test((keys %h)[0] eq $ref);
95 test((values %h) == 1);
96 test((values %h)[0] eq 'cholet');
98 while (my ($k, $v) = each %h) {
100 test(ref($k) eq 'ARRAY');
106 test(not defined $h{$ref});
107 test(not exists($h{$ref}));
108 test((keys %h) == 0);
109 test((values %h) == 0);
110 $h{$ox} = "bellow"; # overloaded ""
111 test(exists $h{$ox});
112 test($h{$ox} eq "bellow");
113 test(not exists $h{"foobarraboof"});
117 # And now Tie::RefHash::Nestable's differences from Tie::RefHash.
118 $h = eval { tie %h, 'Tie::RefHash::Nestable' };
121 test(ref($h) eq 'Tie::RefHash::Nestable');
122 test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/);
123 $h{$ref}->{$ref1} = 'bungo';
124 test($h{$ref}->{$ref1} eq 'bungo');
126 # Test that the nested hash is also tied (for current implementation)
127 test(defined(tied(%{$h{$ref}}))
128 and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ );
130 test((keys %h) == 1);
131 test((keys %h)[0] eq $ref);
132 test((keys %{$h{$ref}}) == 1);
133 test((keys %{$h{$ref}})[0] eq $ref1);
136 # Tests that delete returns the deleted element [perl #32193]
137 my $ref = \(my $var = "oink");
138 tie my %oink, 'Tie::RefHash';
139 $oink{$ref} = "ding";
140 test($oink{$ref} eq "ding");
141 test(delete($oink{$ref}) eq "ding");
144 die "expected to run $numtests tests, but ran ", $currtest - 1
145 if $currtest - 1 != $numtests;
154 # Print 'ok X' if true, 'not ok X' if false
155 # Uses global $currtest.
159 print 'not ' if not $t;
160 print 'ok ', $currtest++, "\n";
164 # Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string.
168 $d =~ s/^\$VAR1 =\s*//;
174 # Crudely dump a hash into a canonical string representation (because
175 # hash keys can appear in any order, Data::Dumper may give different
176 # strings for the same hash).
181 foreach (sort keys %$h) {
182 $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n";
187 # Run the tests and give results.
189 # Parameters: reference to list of tests to run
190 # name of class to use for tied hash, or undef if not tied
192 # Returns: list of [R, W, E] tuples, one for each test.
193 # R is the return value from running the test, W any warnings it gave,
194 # and E any exception raised with 'die'. E and W will be tidied up a
195 # little to remove irrelevant details like line numbers :-)
197 # Will also run a few of its own 'ok N' tests.
200 my ($tests, $class) = @_;
204 if (defined $class) {
205 $h = eval { tie %h, $class };
208 test(ref($h) eq $class);
209 test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/);
213 my ($result, $warning, $exception);
214 local $SIG{__WARN__} = sub { $warning .= $_[0] };
215 $result = scalar(eval $_);
218 die "$@:$_" unless defined $class;
222 foreach ($warning, $exception) {
224 s/ at .+ line \d+\.$//mg;
225 s/ at .+ line \d+, at .*//mg;
226 s/ at .+ line \d+, near .*//mg;
227 s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g;
230 my (@warnings, %seen);
231 foreach (split /\n/, $warning) {
232 push @warnings, $_ unless $seen{$_}++;
234 $warning = join("\n", @warnings);
236 push @r, [ $result, $warning, $exception ];
243 # Things that should work just the same for an ordinary hash and a
246 # Each test is a code string to be eval'd, it should do something with
247 # %h and give a scalar return value. The global $ref and $ref1 may
250 # One thing we don't test is that the ordering from 'keys', 'values'
251 # and 'each' is the same. You can't reasonably expect that.
253 sub standard_hash_tests {
256 # Library of standard tests on keys, values and each
257 my $STD_TESTS = <<'END'
258 join $;, sort keys %h;
259 join $;, sort values %h;
260 { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) }
261 { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) }
265 # Tests on the existence of the element 'foo'
266 my $FOO_TESTS = <<'END'
273 # Test storing and deleting 'foo'
274 push @r, split /\n/, <<"END"
289 # Test storing and removing under ordinary keys
290 my @things = ('boink', 0, 1, '', undef);
291 foreach my $key (map { dumped($_) } @things) {
292 foreach my $value ((map { dumped($_) } @things), '$ref') {
293 push @r, split /\n/, <<"END"
311 @slicetests = split /\n/, <<'END'
314 @h{'e'} = ('f', 'g');
316 @h{'j', 'k'} = ('l');
317 @h{'m', 'n'} = ('o', 'p');
318 @h{'q', 'r'} = ('s', 't', 'u');
321 my @aaa = @slicetests;
322 foreach (@slicetests) {
324 push @r, split(/\n/, $STD_TESTS);
328 push @r, '%h = ();', split(/\n/, $STD_TESTS);