| 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(); |
| 33 | |
| 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); |
| 70 | $h = eval { tie %h, 'Tie::RefHash' }; |
| 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. |
| 100 | $h = eval { tie %h, 'Tie::RefHash::Nestable' }; |
| 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 | |
| 117 | |
| 118 | die "expected to run $numtests tests, but ran ", $currtest - 1 |
| 119 | if $currtest - 1 != $numtests; |
| 120 | |
| 121 | @tests = (); |
| 122 | undef $ref; |
| 123 | undef $ref1; |
| 124 | |
| 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) { |
| 179 | $h = eval { tie %h, $class }; |
| 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 $_); |
| 190 | if ($@) |
| 191 | { |
| 192 | die "$@:$_" unless defined $class; |
| 193 | $exception = $@; |
| 194 | } |
| 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; |
| 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) } |
| 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' |
| 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 |
| 301 | push @r, '%h = ();', split(/\n/, $STD_TESTS); |
| 302 | |
| 303 | return @r; |
| 304 | } |
| 305 | |