t/op/hash.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10
  11 # This will crash perl if it fails
  12
  13 use constant PVBM => 'foo';
  14
  15 my $dummy = index 'foo', PVBM;
  16 eval { my %h = (a => PVBM); 1 };
  17
  18 ok (!$@, 'fbm scalar can be inserted into a hash');
  19
  20
  21 my $destroyed;
  22 { package Class; DESTROY { ++$destroyed; } }
  23
  24 $destroyed = 0;
  25 {
  26     my %h;
  27     keys(%h) = 1;
  28     $h{key} = bless({}, 'Class');
  29 }
  30 is($destroyed, 1, 'Timely hash destruction with lvalue keys');
  31
  32
  33 # [perl #79178] Hash keys must not be stringified during compilation
  34 # Run perl -MO=Concise -e '$a{\"foo"}' on a non-threaded pre-5.13.8 version
  35 # to see why.
  36 {
  37     my $key;
  38     package bar;
  39     sub TIEHASH { bless {}, $_[0] }
  40     sub FETCH { $key = $_[1] }
  41     package main;
  42     tie my %h, "bar";
  43     () = $h{\'foo'};
  44     is ref $key, SCALAR =>
  45      'hash keys are not stringified during compilation';
  46 }
  47
  48 # Part of RT #85026: Deleting the current iterator in void context does not
  49 # free it.
  50 {
  51     my $gone;
  52     no warnings 'once';
  53     local *::DESTROY = sub { ++$gone };
  54     my %a=(a=>bless[]);
  55     each %a;   # make the entry with the obj the current iterator
  56     delete $a{a};
  57     ok $gone, 'deleting the current iterator in void context frees the val'
  58 }
  59
  60 # [perl #99660] Deleted hash element visible to destructor
  61 {
  62     my %h;
  63     $h{k} = bless [];
  64     my $normal_exit;
  65     local *::DESTROY = sub { my $x = $h{k}; ++$normal_exit };
  66     delete $h{k}; # must be in void context to trigger the bug
  67     ok $normal_exit, 'freed hash elems are not visible to DESTROY';
  68 }
  69
  70 # [perl #100340] Similar bug: freeing a hash elem during a delete
  71 sub guard::DESTROY {
  72    ${$_[0]}->();
  73 };
  74 *guard = sub (&) {
  75    my $callback = shift;
  76    return bless \$callback, "guard"
  77 };
  78 {
  79   my $ok;
  80   my %t; %t = (
  81     stash => {
  82         guard => guard(sub{
  83             $ok++;
  84             delete $t{stash};
  85         }),
  86         foo => "bar",
  87         bar => "baz",
  88     },
  89   );
  90   ok eval { delete $t{stash}{guard}; # must be in void context
  91             1 },
  92     'freeing a hash elem from destructor called by delete does not die';
  93   diag $@ if $@; # panic: free from wrong pool
  94   is $ok, 1, 'the destructor was called';
  95 }
  96
  97 # Weak references to pad hashes
  98 SKIP: {
  99     skip_if_miniperl("No Scalar::Util::weaken under miniperl", 1);
 100     my $ref;
 101     require Scalar::Util;
 102     {
 103         my %hash;
 104         Scalar::Util::weaken($ref = \%hash);
 105         1;  # the previous statement must not be the last
 106     }
 107     is $ref, undef, 'weak refs to pad hashes go stale on scope exit';
 108 }
 109
 110 # [perl #107440]
 111 sub A::DESTROY { $::ra = 0 }
 112 $::ra = {a=>bless [], 'A'};
 113 undef %$::ra;
 114 pass 'no crash when freeing hash that is being undeffed';
 115 $::ra = {a=>bless [], 'A'};
 116 %$::ra = ('a'..'z');
 117 pass 'no crash when freeing hash that is being exonerated, ahem, cleared';
 118
 119 # If I have these correct then removing any part of the lazy hash fill handling
 120 # code in hv.c will cause some of these tests to start failing.
 121 sub validate_hash {
 122   my ($desc, $h) = @_;
 123   local $::Level = $::Level + 1;
 124
 125   my $scalar = %$h;
 126   my $expect = qr!\A(\d+)/(\d+)\z!;
 127   like($scalar, $expect, "$desc in scalar context matches pattern");
 128   my ($used, $total) = $scalar =~ $expect;
 129   cmp_ok($total, '>', 0, "$desc has >0 array size ($total)");
 130   cmp_ok($used, '>', 0, "$desc uses >0 heads ($used)");
 131   cmp_ok($used, '<=', $total,
 132          "$desc doesn't use more heads than are available");
 133   return ($used, $total);
 134 }
 135
 136 sub torture_hash {
 137   my $desc = shift;
 138   # Intentionally use an anon hash rather than a lexical, as lexicals default
 139   # to getting reused on subsequent calls
 140   my $h = {};
 141   ++$h->{$_} foreach @_;
 142
 143   my ($used0, $total0) = validate_hash($desc, $h);
 144   # Remove half the keys each time round, until there are only 1 or 2 left
 145   my @groups;
 146   my ($h2, $h3, $h4);
 147   while (keys %$h > 2) {
 148     my $take = (keys %$h) / 2 - 1;
 149     my @keys = (keys %$h)[0 .. $take];
 150     my $scalar = %$h;
 151     delete @$h{@keys};
 152     push @groups, $scalar, \@keys;
 153
 154     my $count = keys %$h;
 155     my ($used, $total) = validate_hash("$desc (-$count)", $h);
 156     is($total, $total0, "$desc ($count) has same array size");
 157     cmp_ok($used, '<=', $used0, "$desc ($count) has same or fewer heads");
 158     ++$h2->{$_} foreach @keys;
 159     my (undef, $total2) = validate_hash("$desc (+$count)", $h2);
 160     cmp_ok($total2, '<=', $total0, "$desc ($count) array size no larger");
 161
 162     # Each time this will get emptied then repopulated. If the fill isn't reset
 163     # when the hash is emptied, the used count will likely exceed the array
 164     %$h3 = %$h2;
 165     my (undef, $total3) = validate_hash("$desc (+$count copy)", $h3);
 166     is($total3, $total2, "$desc (+$count copy) has same array size");
 167
 168     # This might use fewer buckets than the original
 169     %$h4 = %$h;
 170     my (undef, $total4) = validate_hash("$desc ($count copy)", $h4);
 171     cmp_ok($total4, '<=', $total0, "$desc ($count copy) array size no larger");
 172   }
 173
 174   my $scalar = %$h;
 175   my @keys = keys %$h;
 176   delete @$h{@keys};
 177   is(scalar %$h, 0, "scalar keys for empty $desc");
 178
 179   # Rebuild the original hash, and build a copy
 180   # These will fail if hash key addition and deletion aren't handled correctly
 181   my $h1;
 182   foreach (@keys) {
 183     ++$h->{$_};
 184     ++$h1->{$_};
 185   }
 186   is(scalar %$h, $scalar, "scalar keys restored when rebuilding");
 187
 188   while (@groups) {
 189     my $keys = pop @groups;
 190     ++$h->{$_} foreach @$keys;
 191     my (undef, $total) = validate_hash("$desc " . keys %$h, $h);
 192     is($total, $total0, "bucket count is constant when rebuilding");
 193     is(scalar %$h, pop @groups, "scalar keys is identical when rebuilding");
 194     ++$h1->{$_} foreach @$keys;
 195     validate_hash("$desc copy " . keys %$h1, $h1);
 196   }
 197   # This will fail if the fill count isn't handled correctly on hash split
 198   is(scalar %$h1, scalar %$h, "scalar keys is identical on copy and original");
 199 }
 200
 201 torture_hash('a .. zz', 'a' .. 'zz');
 202 torture_hash('0 .. 9', 0 .. 9);
 203 torture_hash("'Perl'", 'Rules');
 204
 205 done_testing();