Commit | Line | Data |
f0f40d86 |
1 | #!/usr/bin/perl -T -w |
778e8f97 |
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 { |
f0f40d86 |
13 | if( $ENV{PERL_CORE} ) { |
14 | chdir 't'; |
15 | @INC = '../lib'; |
b5cc9730 |
16 | } |
f0f40d86 |
17 | } |
18 | |
19 | BEGIN { |
20 | unless ( eval { require Data::Dumper; 1 } ) { |
21 | print "1..0 # Skip -- Data::Dumper is not available\n"; |
22 | exit 0; |
23 | } |
778e8f97 |
24 | } |
25 | |
26 | use strict; |
27 | use Tie::RefHash; |
28 | use Data::Dumper; |
18592d64 |
29 | my $numtests = 39; |
778e8f97 |
30 | my $currtest = 1; |
31 | print "1..$numtests\n"; |
32 | |
33 | my $ref = []; my $ref1 = []; |
34 | |
05d3035d |
35 | package Boustrophedon; # A class with overloaded "". |
36 | sub new { my ($c, $s) = @_; bless \$s, $c } |
37 | use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} }; |
38 | package main; |
39 | my $ox = Boustrophedon->new("foobar"); |
40 | |
778e8f97 |
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 |
44 | # buggy :-) |
45 | # |
46 | my @tests = standard_hash_tests(); |
24026386 |
47 | |
778e8f97 |
48 | my @ordinary_results = runtests(\@tests, undef); |
49 | foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') { |
50 | my @tied_results = runtests(\@tests, $class); |
51 | my $all_ok = 1; |
52 | |
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]}; |
57 | |
58 | my $ok = 1; |
59 | local $^W = 0; |
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); |
63 | |
64 | if (not $ok) { |
65 | print STDERR |
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", |
75 | "\n"; |
76 | $all_ok = 0; |
77 | } |
78 | } |
79 | test($all_ok); |
80 | } |
81 | |
82 | # Now test Tie::RefHash's special powers |
83 | my (%h, $h); |
24026386 |
84 | $h = eval { tie %h, 'Tie::RefHash' }; |
778e8f97 |
85 | warn $@ if $@; |
86 | test(not $@); |
87 | test(ref($h) eq 'Tie::RefHash'); |
88 | test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/); |
89 | $h{$ref} = 'cholet'; |
90 | test($h{$ref} eq 'cholet'); |
91 | test(exists $h{$ref}); |
92 | test((keys %h) == 1); |
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'); |
97 | my $count = 0; |
98 | while (my ($k, $v) = each %h) { |
99 | if ($count++ == 0) { |
100 | test(ref($k) eq 'ARRAY'); |
101 | test($k eq $ref); |
102 | } |
103 | } |
104 | test($count == 1); |
105 | delete $h{$ref}; |
106 | test(not defined $h{$ref}); |
107 | test(not exists($h{$ref})); |
108 | test((keys %h) == 0); |
109 | test((values %h) == 0); |
05d3035d |
110 | $h{$ox} = "bellow"; # overloaded "" |
111 | test(exists $h{$ox}); |
112 | test($h{$ox} eq "bellow"); |
113 | test(not exists $h{"foobarraboof"}); |
778e8f97 |
114 | undef $h; |
115 | untie %h; |
116 | |
117 | # And now Tie::RefHash::Nestable's differences from Tie::RefHash. |
24026386 |
118 | $h = eval { tie %h, 'Tie::RefHash::Nestable' }; |
778e8f97 |
119 | warn $@ if $@; |
120 | test(not $@); |
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'); |
125 | |
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=/ ); |
129 | |
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); |
134 | |
18592d64 |
135 | { |
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"); |
142 | } |
24026386 |
143 | |
778e8f97 |
144 | die "expected to run $numtests tests, but ran ", $currtest - 1 |
145 | if $currtest - 1 != $numtests; |
24026386 |
146 | |
147 | @tests = (); |
148 | undef $ref; |
149 | undef $ref1; |
150 | |
778e8f97 |
151 | exit(); |
152 | |
153 | |
154 | # Print 'ok X' if true, 'not ok X' if false |
155 | # Uses global $currtest. |
156 | # |
157 | sub test { |
158 | my $t = shift; |
159 | print 'not ' if not $t; |
160 | print 'ok ', $currtest++, "\n"; |
161 | } |
162 | |
163 | |
164 | # Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. |
165 | sub dumped { |
166 | my $s = shift; |
167 | my $d = Dumper($s); |
168 | $d =~ s/^\$VAR1 =\s*//; |
169 | $d =~ s/;$//; |
170 | chomp $d; |
171 | return $d; |
172 | } |
173 | |
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). |
177 | # |
178 | sub dumph { |
179 | my $h = shift; |
180 | my $r = ''; |
181 | foreach (sort keys %$h) { |
182 | $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n"; |
183 | } |
184 | return $r; |
185 | } |
186 | |
187 | # Run the tests and give results. |
188 | # |
189 | # Parameters: reference to list of tests to run |
190 | # name of class to use for tied hash, or undef if not tied |
191 | # |
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 :-) |
196 | # |
197 | # Will also run a few of its own 'ok N' tests. |
198 | # |
199 | sub runtests { |
200 | my ($tests, $class) = @_; |
201 | my @r; |
202 | |
203 | my (%h, $h); |
204 | if (defined $class) { |
24026386 |
205 | $h = eval { tie %h, $class }; |
778e8f97 |
206 | warn $@ if $@; |
207 | test(not $@); |
208 | test(ref($h) eq $class); |
209 | test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/); |
210 | } |
211 | |
212 | foreach (@$tests) { |
213 | my ($result, $warning, $exception); |
214 | local $SIG{__WARN__} = sub { $warning .= $_[0] }; |
215 | $result = scalar(eval $_); |
24026386 |
216 | if ($@) |
217 | { |
218 | die "$@:$_" unless defined $class; |
219 | $exception = $@; |
220 | } |
778e8f97 |
221 | |
222 | foreach ($warning, $exception) { |
223 | next if not defined; |
224 | s/ at .+ line \d+\.$//mg; |
225 | s/ at .+ line \d+, at .*//mg; |
226 | s/ at .+ line \d+, near .*//mg; |
f0f40d86 |
227 | s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g; |
778e8f97 |
228 | } |
229 | |
230 | my (@warnings, %seen); |
231 | foreach (split /\n/, $warning) { |
232 | push @warnings, $_ unless $seen{$_}++; |
233 | } |
234 | $warning = join("\n", @warnings); |
235 | |
236 | push @r, [ $result, $warning, $exception ]; |
237 | } |
238 | |
239 | return @r; |
240 | } |
241 | |
242 | |
243 | # Things that should work just the same for an ordinary hash and a |
244 | # Tie::RefHash. |
245 | # |
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 |
248 | # also be used. |
249 | # |
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. |
252 | # |
253 | sub standard_hash_tests { |
254 | my @r; |
255 | |
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; |
24026386 |
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) } |
778e8f97 |
262 | END |
263 | ; |
264 | |
265 | # Tests on the existence of the element 'foo' |
266 | my $FOO_TESTS = <<'END' |
267 | defined $h{foo}; |
268 | exists $h{foo}; |
269 | $h{foo}; |
270 | END |
271 | ; |
272 | |
273 | # Test storing and deleting 'foo' |
274 | push @r, split /\n/, <<"END" |
275 | $STD_TESTS; |
276 | $FOO_TESTS; |
277 | \$h{foo} = undef; |
278 | $STD_TESTS; |
279 | $FOO_TESTS; |
280 | \$h{foo} = 'hello'; |
281 | $STD_TESTS; |
282 | $FOO_TESTS; |
283 | delete \$h{foo}; |
284 | $STD_TESTS; |
285 | $FOO_TESTS; |
286 | END |
287 | ; |
288 | |
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" |
294 | \$h{$key} = $value; |
295 | $STD_TESTS; |
296 | defined \$h{$key}; |
297 | exists \$h{$key}; |
298 | \$h{$key}; |
299 | delete \$h{$key}; |
300 | $STD_TESTS; |
301 | defined \$h{$key}; |
302 | exists \$h{$key}; |
303 | \$h{$key}; |
304 | END |
305 | ; |
306 | } |
307 | } |
308 | |
309 | # Test hash slices |
310 | my @slicetests; |
311 | @slicetests = split /\n/, <<'END' |
778e8f97 |
312 | @h{'b'} = (); |
313 | @h{'c'} = ('d'); |
314 | @h{'e'} = ('f', 'g'); |
315 | @h{'h', 'i'} = (); |
316 | @h{'j', 'k'} = ('l'); |
317 | @h{'m', 'n'} = ('o', 'p'); |
318 | @h{'q', 'r'} = ('s', 't', 'u'); |
319 | END |
320 | ; |
321 | my @aaa = @slicetests; |
322 | foreach (@slicetests) { |
323 | push @r, $_; |
324 | push @r, split(/\n/, $STD_TESTS); |
325 | } |
326 | |
327 | # Test CLEAR |
24026386 |
328 | push @r, '%h = ();', split(/\n/, $STD_TESTS); |
778e8f97 |
329 | |
330 | return @r; |
331 | } |