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