#!./perl -w
BEGIN {
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
}
use strict;
# This will crash perl if it fails
use constant PVBM => 'foo';
my $dummy = index 'foo', PVBM;
eval { my %h = (a => PVBM); 1 };
ok (!$@, 'fbm scalar can be inserted into a hash');
my $destroyed;
{ package Class; DESTROY { ++$destroyed; } }
$destroyed = 0;
{
my %h;
keys(%h) = 1;
$h{key} = bless({}, 'Class');
}
is($destroyed, 1, 'Timely hash destruction with lvalue keys');
# [perl #79178] Hash keys must not be stringified during compilation
# Run perl -MO=Concise -e '$a{\"foo"}' on a non-threaded pre-5.13.8 version
# to see why.
{
my $key;
package bar;
sub TIEHASH { bless {}, $_[0] }
sub FETCH { $key = $_[1] }
package main;
tie my %h, "bar";
() = $h{\'foo'};
is ref $key, SCALAR =>
'ref hash keys are not stringified during compilation';
use constant u => undef;
no warnings 'uninitialized'; # work around unfixed bug #105918
() = $h{+u};
is $key, undef,
'undef hash keys are not stringified during compilation, either';
}
# Part of RT #85026: Deleting the current iterator in void context does not
# free it.
{
my $gone;
no warnings 'once';
local *::DESTROY = sub { ++$gone };
my %a=(a=>bless[]);
each %a; # make the entry with the obj the current iterator
delete $a{a};
ok $gone, 'deleting the current iterator in void context frees the val'
}
# [perl #99660] Deleted hash element visible to destructor
{
my %h;
$h{k} = bless [];
my $normal_exit;
local *::DESTROY = sub { my $x = $h{k}; ++$normal_exit };
delete $h{k}; # must be in void context to trigger the bug
ok $normal_exit, 'freed hash elems are not visible to DESTROY';
}
# [perl #100340] Similar bug: freeing a hash elem during a delete
sub guard::DESTROY {
${$_[0]}->();
};
*guard = sub (&) {
my $callback = shift;
return bless \$callback, "guard"
};
{
my $ok;
my %t; %t = (
stash => {
guard => guard(sub{
$ok++;
delete $t{stash};
}),
foo => "bar",
bar => "baz",
},
);
ok eval { delete $t{stash}{guard}; # must be in void context
1 },
'freeing a hash elem from destructor called by delete does not die';
diag $@ if $@; # panic: free from wrong pool
is $ok, 1, 'the destructor was called';
}
# Weak references to pad hashes
SKIP: {
skip_if_miniperl("No Scalar::Util::weaken under miniperl", 1);
my $ref;
require Scalar::Util;
{
my %hash;
Scalar::Util::weaken($ref = \%hash);
1; # the previous statement must not be the last
}
is $ref, undef, 'weak refs to pad hashes go stale on scope exit';
}
# [perl #107440]
sub A::DESTROY { $::ra = 0 }
$::ra = {a=>bless [], 'A'};
undef %$::ra;
pass 'no crash when freeing hash that is being undeffed';
$::ra = {a=>bless [], 'A'};
%$::ra = ('a'..'z');
pass 'no crash when freeing hash that is being exonerated, ahem, cleared';
# If I have these correct then removing any part of the lazy hash fill handling
# code in hv.c will cause some of these tests to start failing.
sub validate_hash {
my ($desc, $h) = @_;
local $::Level = $::Level + 1;
# test that scalar(%hash) works as expected, which as of perl 5.25 is
# the same as 0+keys %hash;
my $scalar= scalar %$h;
my $count= 0+keys %$h;
is($scalar, $count, "$desc scalar() should be the same as 0+keys() as of perl 5.25");
require Hash::Util;
sub Hash::Util::bucket_ratio (\%);
# back compat tests, via Hash::Util::bucket_ratio();
my $ratio = Hash::Util::bucket_ratio(%$h);
my $expect = qr!\A(\d+)/(\d+)\z!;
like($ratio, $expect, "$desc bucket_ratio matches pattern");
my ($used, $total)= (0,0);
($used, $total)= ($1,$2) if $ratio =~ /$expect/;
cmp_ok($total, '>', 0, "$desc has >0 array size ($total)");
cmp_ok($used, '>', 0, "$desc uses >0 heads ($used)");
cmp_ok($used, '<=', $total,
"$desc doesn't use more heads than are available");
return ($used, $total);
}
sub torture_hash {
my $desc = shift;
# Intentionally use an anon hash rather than a lexical, as lexicals default
# to getting reused on subsequent calls
my $h = {};
++$h->{$_} foreach @_;
my ($used0, $total0) = validate_hash($desc, $h);
# Remove half the keys each time round, until there are only 1 or 2 left
my @groups;
my ($h2, $h3, $h4);
while (keys %$h > 2) {
my $take = (keys %$h) / 2 - 1;
my @keys = (sort keys %$h)[0..$take];
my $scalar = %$h;
delete @$h{@keys};
push @groups, $scalar, \@keys;
my $count = keys %$h;
my ($used, $total) = validate_hash("$desc (-$count)", $h);
is($total, $total0, "$desc ($count) has same array size");
cmp_ok($used, '<=', $used0, "$desc ($count) has same or fewer heads");
++$h2->{$_} foreach @keys;
my (undef, $total2) = validate_hash("$desc (+$count)", $h2);
cmp_ok($total2, '<=', $total0, "$desc ($count) array size no larger");
# Each time this will get emptied then repopulated. If the fill isn't reset
# when the hash is emptied, the used count will likely exceed the array
%$h3 = %$h2;
is(join(",", sort keys %$h3),join(",",sort keys %$h2),"$desc (+$count copy) has same keys");
my (undef, $total3) = validate_hash("$desc (+$count copy)", $h3);
# We now only split when we collide on insert AND exceed the load factor
# when we did so. Building a hash via %x=%y means a pseudo-random key
# order inserting into %x, and we may end up encountering a collision
# at a different point in the load order, resulting in a possible power of
# two difference under the current load factor expectations. If this test
# fails then it is probably because DO_HSPLIT was changed, and this test
# needs to be adjusted accordingly.
ok( $total2 == $total3 || $total2*2==$total3 || $total2==$total3*2,
"$desc (+$count copy) array size within a power of 2 of each other");
# This might use fewer buckets than the original
%$h4 = %$h;
my (undef, $total4) = validate_hash("$desc ($count copy)", $h4);
cmp_ok($total4, '<=', $total0, "$desc ($count copy) array size no larger");
}
my $scalar = %$h;
my @keys = sort keys %$h;
delete @$h{@keys};
is(scalar %$h, 0, "scalar keys for empty $desc");
# Rebuild the original hash, and build a copy
# These will fail if hash key addition and deletion aren't handled correctly
my $h1;
foreach (@keys) {
++$h->{$_};
++$h1->{$_};
}
is(scalar %$h, $scalar, "scalar keys restored when rebuilding");
while (@groups) {
my $keys = pop @groups;
++$h->{$_} foreach @$keys;
my (undef, $total) = validate_hash($desc, $h);
ok($total == $total0 || $total == ($total0*2), "bucket count is expected size when rebuilding");
is(scalar %$h, pop @groups, "scalar keys is identical when rebuilding");
++$h1->{$_} foreach @$keys;
validate_hash("$desc copy", $h1);
}
# This will fail if the fill count isn't handled correctly on hash split
is(scalar %$h1, scalar %$h, "scalar keys is identical on copy and original");
}
if (is_miniperl) {
print "# skipping torture_hash tests on miniperl because no Hash::Util\n";
} else {
torture_hash('a .. zz', 'a' .. 'zz');
torture_hash('0 .. 9', 0 .. 9);
torture_hash("'Perl'", 'Rules');
}
{
my %h = qw(a x b y c z);
no warnings qw(misc uninitialized);
%h = $h{a};
is(join(':', %h), 'x:', 'hash self-assign');
}
# magic keys and values should be evaluated before the hash on the LHS is
# cleared
package Magic {
my %inner;
sub TIEHASH { bless [] }
sub FETCH { $inner{$_[1]} }
sub STORE { $inner{$_[1]} = $_[2]; }
sub CLEAR { %inner = () }
my (%t1, %t2);
tie %t1, 'Magic';
tie %t2, 'Magic';
%inner = qw(a x b y);
%t1 = (@t2{'a','b'});
::is(join( ':', %inner), "x:y", "magic keys");
}
done_testing();