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'} !~ m!\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