lib/Tie/RefHash/refhash.t

   1 #!/usr/bin/perl -T -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     if( $ENV{PERL_CORE} ) {
  14         chdir 't';
  15         @INC = '../lib';
  16     }
  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   }
  24 }
  25
  26 use strict;
  27 use Tie::RefHash;
  28 use Data::Dumper;
  29 my $numtests = 39;
  30 my $currtest = 1;
  31 print "1..$numtests\n";
  32
  33 my $ref = []; my $ref1 = [];
  34
  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
  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();
  47
  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);
  84 $h = eval { tie %h, 'Tie::RefHash' };
  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);
 110 $h{$ox} = "bellow"; # overloaded ""
 111 test(exists $h{$ox});
 112 test($h{$ox} eq "bellow");
 113 test(not exists $h{"foobarraboof"});
 114 undef $h;
 115 untie %h;
 116
 117 # And now Tie::RefHash::Nestable's differences from Tie::RefHash.
 118 $h = eval { tie %h, 'Tie::RefHash::Nestable' };
 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
 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 }
 143
 144 die "expected to run $numtests tests, but ran ", $currtest - 1
 145   if $currtest - 1 != $numtests;
 146
 147 @tests = ();
 148 undef $ref;
 149 undef $ref1;
 150
 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) {
 205         $h = eval { tie %h, $class };
 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 $_);
 216         if ($@)
 217          {
 218           die "$@:$_" unless defined $class;
 219           $exception = $@;
 220          }
 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;
 227       s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g;
 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;
 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) }
 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'
 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
 328     push @r, '%h = ();', split(/\n/, $STD_TESTS);
 329
 330     return @r;
 331 }