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 plan tests => 15;
  12
  13 my %h;
  14
  15 ok (!Internals::HvREHASH(%h), "hash doesn't start with rehash flag on");
  16
  17 foreach (1..10) {
  18   $h{"\0"x$_}++;
  19 }
  20
  21 ok (!Internals::HvREHASH(%h), "10 entries doesn't trigger rehash");
  22
  23 foreach (11..20) {
  24   $h{"\0"x$_}++;
  25 }
  26
  27 ok (Internals::HvREHASH(%h), "20 entries triggers rehash");
  28
  29
  30
  31
  32 # second part using an emulation of the PERL_HASH in perl, mounting an
  33 # attack on a pre-populated hash. This is also useful if you need normal
  34 # keys which don't contain \0 -- suitable for stashes
  35
  36 use constant MASK_U32  => 2**32;
  37 use constant HASH_SEED => 0;
  38 use constant THRESHOLD => 14;
  39 use constant START     => "a";
  40
  41 # some initial hash data
  42 my %h2 = map {$_ => 1} 'a'..'cc';
  43
  44 ok (!Internals::HvREHASH(%h2),
  45     "starting with pre-populated non-pathological hash (rehash flag if off)");
  46
  47 my @keys = get_keys(\%h2);
  48 $h2{$_}++ for @keys;
  49 ok (Internals::HvREHASH(%h2),
  50     scalar(@keys) . " colliding into the same bucket keys are triggering rehash");
  51
  52 sub get_keys {
  53     my $hr = shift;
  54
  55     # the minimum of bits required to mount the attack on a hash
  56     my $min_bits = log(THRESHOLD)/log(2);
  57
  58     # if the hash has already been populated with a significant amount
  59     # of entries the number of mask bits can be higher
  60     my $keys = scalar keys %$hr;
  61     my $bits = $keys ? log($keys)/log(2) : 0;
  62     $bits = $min_bits if $min_bits > $bits;
  63
  64     $bits = int($bits) < $bits ? int($bits) + 1 : int($bits);
  65     # need to add 2 bits to cover the internal split cases
  66     $bits += 2;
  67     my $mask = 2**$bits-1;
  68     print "# using mask: $mask ($bits)\n";
  69
  70     my @keys;
  71     my $s = START;
  72     my $c = 0;
  73     # get 2 keys on top of the THRESHOLD
  74     my $hash;
  75     while (@keys < THRESHOLD+2) {
  76         # next if exists $hash->{$s};
  77         $hash = hash($s);
  78         next unless ($hash & $mask) == 0;
  79         $c++;
  80         printf "# %2d: %5s, %10s\n", $c, $s, $hash;
  81         push @keys, $s;
  82     } continue {
  83         $s++;
  84     }
  85
  86     return @keys;
  87 }
  88
  89
  90 # trying to provide the fastest equivalent of C macro's PERL_HASH in
  91 # Perl - the main complication is that it uses U32 integer, which we
  92 # can't do in perl, without doing some tricks
  93 sub hash {
  94     my $s = shift;
  95     my @c = split //, $s;
  96     my $u = HASH_SEED;
  97     for (@c) {
  98         # (A % M) + (B % M) == (A + B) % M
  99         # This works because '+' produces a NV, which is big enough to hold
 100         # the intermediate result. We only need the % before any "^" and "&"
 101         # to get the result in the range for an I32.
 102         # and << doesn't work on NV, so using 1 << 10
 103         $u += ord;
 104         $u += $u * (1 << 10); $u %= MASK_U32;
 105         $u ^= $u >> 6;
 106     }
 107     $u += $u << 3;  $u %= MASK_U32;
 108     $u ^= $u >> 11; $u %= MASK_U32;
 109     $u += $u << 15; $u %= MASK_U32;
 110     $u;
 111 }
 112
 113 # This will crash perl if it fails
 114
 115 use constant PVBM => 'foo';
 116
 117 my $dummy = index 'foo', PVBM;
 118 eval { my %h = (a => PVBM); 1 };
 119
 120 ok (!$@, 'fbm scalar can be inserted into a hash');
 121
 122
 123 my $destroyed;
 124 { package Class; DESTROY { ++$destroyed; } }
 125
 126 $destroyed = 0;
 127 {
 128     my %h;
 129     keys(%h) = 1;
 130     $h{key} = bless({}, 'Class');
 131 }
 132 is($destroyed, 1, 'Timely hash destruction with lvalue keys');
 133
 134
 135 # [perl #79178] Hash keys must not be stringified during compilation
 136 # Run perl -MO=Concise -e '$a{\"foo"}' on a non-threaded pre-5.13.8 version
 137 # to see why.
 138 {
 139     my $key;
 140     package bar;
 141     sub TIEHASH { bless {}, $_[0] }
 142     sub FETCH { $key = $_[1] }
 143     package main;
 144     tie my %h, "bar";
 145     () = $h{\'foo'};
 146     is ref $key, SCALAR =>
 147      'hash keys are not stringified during compilation';
 148 }
 149
 150 # Part of RT #85026: Deleting the current iterator in void context does not
 151 # free it.
 152 {
 153     my $gone;
 154     no warnings 'once';
 155     local *::DESTROY = sub { ++$gone };
 156     my %a=(a=>bless[]);
 157     each %a;   # make the entry with the obj the current iterator
 158     delete $a{a};
 159     ok $gone, 'deleting the current iterator in void context frees the val'
 160 }
 161
 162 # [perl #99660] Deleted hash element visible to destructor
 163 {
 164     my %h;
 165     $h{k} = bless [];
 166     my $normal_exit;
 167     local *::DESTROY = sub { my $x = $h{k}; ++$normal_exit };
 168     delete $h{k}; # must be in void context to trigger the bug
 169     ok $normal_exit, 'freed hash elems are not visible to DESTROY';
 170 }
 171
 172 # [perl #100340] Similar bug: freeing a hash elem during a delete
 173 sub guard::DESTROY {
 174    ${$_[0]}->();
 175 };
 176 *guard = sub (&) {
 177    my $callback = shift;
 178    return bless \$callback, "guard"
 179 };
 180 {
 181   my $ok;
 182   my %t; %t = (
 183     stash => {
 184         guard => guard(sub{
 185             $ok++;
 186             delete $t{stash};
 187         }),
 188         foo => "bar",
 189         bar => "baz",
 190     },
 191   );
 192   ok eval { delete $t{stash}{guard}; # must be in void context
 193             1 },
 194     'freeing a hash elem from destructor called by delete does not die';
 195   diag $@ if $@; # panic: free from wrong pool
 196   is $ok, 1, 'the destructor was called';
 197 }
 198
 199 # Weak references to pad hashes
 200 SKIP: {
 201     skip_if_miniperl("No Scalar::Util::weaken under miniperl", 1);
 202     my $ref;
 203     require Scalar::Util;
 204     {
 205         my %hash;
 206         Scalar::Util::weaken($ref = \%hash);
 207         1;  # the previous statement must not be the last
 208     }
 209     is $ref, undef, 'weak refs to pad hashes go stale on scope exit';
 210 }
 211
 212 # [perl #107440]
 213 sub A::DESTROY { $::ra = 0 }
 214 $::ra = {a=>bless [], 'A'};
 215 undef %$::ra;
 216 pass 'no crash when freeing hash that is being undeffed';
 217 $::ra = {a=>bless [], 'A'};
 218 %$::ra = ('a'..'z');
 219 pass 'no crash when freeing hash that is being exonerated, ahem, cleared';