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