This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Skip test if Data::Dumper not built
[perl5.git] / lib / Tie / RefHash.t
1 #!/usr/bin/perl -w
2
3 # Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
4
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
9 # references as keys.
10
11
12 BEGIN {
13     chdir 't' if -d 't';
14     @INC = '.'; 
15     push @INC, '../lib';
16     require Config;
17     if (($Config::Config{'extensions'} !~ /\bData::Dumper\b/) ){
18         print "1..0 # Skip -- Perl configured without Data::Dumper module\n";
19         exit 0;
20     }
21 }    
22
23 use strict;
24 use Tie::RefHash;
25 use Data::Dumper;
26 my $numtests = 37;
27 my $currtest = 1;
28 print "1..$numtests\n";
29
30 my $ref = []; my $ref1 = [];
31
32 package Boustrophedon; # A class with overloaded "".
33 sub new { my ($c, $s) = @_; bless \$s, $c }
34 use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} };
35 package main;
36 my $ox = Boustrophedon->new("foobar");
37
38 # Test standard hash functionality, by performing the same operations
39 # on a tied hash and on a normal hash, and checking that the results
40 # are the same.  This does of course assume that Perl hashes are not
41 # buggy :-)
42
43 my @tests = standard_hash_tests();
44
45 my @ordinary_results = runtests(\@tests, undef);
46 foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
47     my @tied_results = runtests(\@tests, $class);
48     my $all_ok = 1;
49
50     die if @ordinary_results != @tied_results;
51     foreach my $i (0 .. $#ordinary_results) {
52         my ($or, $ow, $oe) = @{$ordinary_results[$i]};
53         my ($tr, $tw, $te) = @{$tied_results[$i]};
54         
55         my $ok = 1;
56         local $^W = 0;
57         $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr);
58         $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw);
59         $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te);
60         
61         if (not $ok) {
62             print STDERR
63               "failed for $class: $tests[$i]\n",
64               "ordinary hash gave:\n",
65               defined $or ? "\tresult:    $or\n" : "\tundef result\n",
66               defined $ow ? "\twarning:   $ow\n" : "\tno warning\n",
67               defined $oe ? "\texception: $oe\n" : "\tno exception\n",
68               "tied $class hash gave:\n",
69               defined $tr ? "\tresult:    $tr\n" : "\tundef result\n",
70               defined $tw ? "\twarning:   $tw\n" : "\tno warning\n",
71               defined $te ? "\texception: $te\n" : "\tno exception\n",
72               "\n";
73             $all_ok = 0;
74         }
75     }
76     test($all_ok);
77 }
78
79 # Now test Tie::RefHash's special powers
80 my (%h, $h);
81 $h = eval { tie %h, 'Tie::RefHash' };
82 warn $@ if $@;
83 test(not $@);
84 test(ref($h) eq 'Tie::RefHash');
85 test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/);
86 $h{$ref} = 'cholet';
87 test($h{$ref} eq 'cholet');
88 test(exists $h{$ref});
89 test((keys %h) == 1);
90 test(ref((keys %h)[0]) eq 'ARRAY');
91 test((keys %h)[0] eq $ref);
92 test((values %h) == 1);
93 test((values %h)[0] eq 'cholet');
94 my $count = 0;
95 while (my ($k, $v) = each %h) {
96     if ($count++ == 0) {
97         test(ref($k) eq 'ARRAY');
98         test($k eq $ref);
99     }
100 }
101 test($count == 1);
102 delete $h{$ref};
103 test(not defined $h{$ref});
104 test(not exists($h{$ref}));
105 test((keys %h) == 0);
106 test((values %h) == 0);
107 $h{$ox} = "bellow"; # overloaded ""
108 test(exists $h{$ox});
109 test($h{$ox} eq "bellow");
110 test(not exists $h{"foobarraboof"});
111 undef $h;
112 untie %h;
113
114 # And now Tie::RefHash::Nestable's differences from Tie::RefHash.
115 $h = eval { tie %h, 'Tie::RefHash::Nestable' };
116 warn $@ if $@;
117 test(not $@);
118 test(ref($h) eq 'Tie::RefHash::Nestable');
119 test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/);
120 $h{$ref}->{$ref1} = 'bungo';
121 test($h{$ref}->{$ref1} eq 'bungo');
122
123 # Test that the nested hash is also tied (for current implementation)
124 test(defined(tied(%{$h{$ref}}))
125      and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ );
126
127 test((keys %h) == 1);
128 test((keys %h)[0] eq $ref);
129 test((keys %{$h{$ref}}) == 1);
130 test((keys %{$h{$ref}})[0] eq $ref1);
131
132
133 die "expected to run $numtests tests, but ran ", $currtest - 1
134   if $currtest - 1 != $numtests;
135
136 @tests = ();
137 undef $ref;
138 undef $ref1;
139
140 exit();
141
142
143 # Print 'ok X' if true, 'not ok X' if false
144 # Uses global $currtest.
145
146 sub test {
147     my $t = shift;
148     print 'not ' if not $t;
149     print 'ok ', $currtest++, "\n";
150 }
151
152
153 # Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. 
154 sub dumped {
155     my $s = shift;
156     my $d = Dumper($s);
157     $d =~ s/^\$VAR1 =\s*//;
158     $d =~ s/;$//;
159     chomp $d;
160     return $d;
161 }
162
163 # Crudely dump a hash into a canonical string representation (because
164 # hash keys can appear in any order, Data::Dumper may give different
165 # strings for the same hash).
166
167 sub dumph {
168     my $h = shift;
169     my $r = '';
170     foreach (sort keys %$h) {
171         $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n";
172     }
173     return $r;
174 }
175
176 # Run the tests and give results.
177
178 # Parameters: reference to list of tests to run
179 #             name of class to use for tied hash, or undef if not tied
180
181 # Returns: list of [R, W, E] tuples, one for each test.
182 # R is the return value from running the test, W any warnings it gave,
183 # and E any exception raised with 'die'.  E and W will be tidied up a
184 # little to remove irrelevant details like line numbers :-)
185
186 # Will also run a few of its own 'ok N' tests.
187
188 sub runtests {
189     my ($tests, $class) = @_;
190     my @r;
191
192     my (%h, $h);
193     if (defined $class) {
194         $h = eval { tie %h, $class };
195         warn $@ if $@;
196         test(not $@);
197         test(ref($h) eq $class);
198         test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/);
199     }
200
201     foreach (@$tests) {
202         my ($result, $warning, $exception);
203         local $SIG{__WARN__} = sub { $warning .= $_[0] };
204         $result = scalar(eval $_);
205         if ($@)
206          {
207           die "$@:$_" unless defined $class;
208           $exception = $@;
209          }
210
211         foreach ($warning, $exception) {
212             next if not defined;
213             s/ at .+ line \d+\.$//mg;
214             s/ at .+ line \d+, at .*//mg;
215             s/ at .+ line \d+, near .*//mg;
216             s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g;
217         }
218
219         my (@warnings, %seen);
220         foreach (split /\n/, $warning) {
221             push @warnings, $_ unless $seen{$_}++;
222         }
223         $warning = join("\n", @warnings);
224
225         push @r, [ $result, $warning, $exception ];
226     }
227
228     return @r;
229 }
230
231
232 # Things that should work just the same for an ordinary hash and a
233 # Tie::RefHash.
234
235 # Each test is a code string to be eval'd, it should do something with
236 # %h and give a scalar return value.  The global $ref and $ref1 may
237 # also be used.
238
239 # One thing we don't test is that the ordering from 'keys', 'values'
240 # and 'each' is the same.  You can't reasonably expect that.
241
242 sub standard_hash_tests {
243     my @r;
244
245     # Library of standard tests on keys, values and each
246     my $STD_TESTS = <<'END'
247     join $;, sort keys %h;
248     join $;, sort values %h;
249     { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) }
250     { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) }
251 END
252   ;
253     
254     # Tests on the existence of the element 'foo'
255     my $FOO_TESTS = <<'END'
256     defined $h{foo};
257     exists $h{foo};
258     $h{foo};    
259 END
260   ;
261
262     # Test storing and deleting 'foo'
263     push @r, split /\n/, <<"END"
264     $STD_TESTS;
265     $FOO_TESTS;
266     \$h{foo} = undef;
267     $STD_TESTS;
268     $FOO_TESTS;
269     \$h{foo} = 'hello';
270     $STD_TESTS;
271     $FOO_TESTS;
272     delete  \$h{foo};
273     $STD_TESTS;
274     $FOO_TESTS;
275 END
276   ;
277
278     # Test storing and removing under ordinary keys
279     my @things = ('boink', 0, 1, '', undef);
280     foreach my $key (map { dumped($_) } @things) {
281         foreach my $value ((map { dumped($_) } @things), '$ref') {
282             push @r, split /\n/, <<"END"
283             \$h{$key} = $value;
284             $STD_TESTS;
285             defined \$h{$key};
286             exists \$h{$key};
287             \$h{$key};
288             delete \$h{$key};
289             $STD_TESTS;
290             defined \$h{$key};
291             exists \$h{$key};
292             \$h{$key};
293 END
294   ;
295         }
296     }
297     
298     # Test hash slices
299     my @slicetests;
300     @slicetests = split /\n/, <<'END'
301     @h{'b'} = ();
302     @h{'c'} = ('d');
303     @h{'e'} = ('f', 'g');
304     @h{'h', 'i'} = ();
305     @h{'j', 'k'} = ('l');
306     @h{'m', 'n'} = ('o', 'p');
307     @h{'q', 'r'} = ('s', 't', 'u');
308 END
309   ;
310     my @aaa = @slicetests;
311     foreach (@slicetests) {
312         push @r, $_;
313         push @r, split(/\n/, $STD_TESTS);
314     }
315
316     # Test CLEAR
317     push @r, '%h = ();', split(/\n/, $STD_TESTS);
318
319     return @r;
320 }
321