view release on metacpan or  search on metacpan

t/comp/hints.t  view on Meta::CPAN

	}
	1;
    }
    1;
` or warn $@;
print "ok 26 - no crash when cloning a tied hint hash\n";

{
    my $w;
    local $SIG{__WARN__} = sub { $w = shift };
    eval q`
	package namespace::clean::_TieHintHasi;
    
	sub TIEHASH  { bless[] }
	sub STORE    { $_[0][0]{$_[1]} = $_[2] }
	sub FETCH    { $_[0][0]{$_[1]} }
	sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
      # Intentionally commented out:
      #  sub NEXTKEY  { each %{$_[0][0]} }
    
	package main;
    
	BEGIN {
    	    $^H{foo} = "bar"; # activate localisation magic
    	    tie( %^H, 'namespace::clean::_TieHintHasi' ); # sabotage %^H
    	    $^H{foo} = "bar"; # create an element in the tied hash
	}
	{ ; } # clone the tied hint hash
    `;
    print "not " if $w;
    print "ok 27 - double-freeing explosive tied hints hash\n";
    print "# got: $w" if $w;
}

# Setting ${^WARNING_BITS} to its own value should not change things.
{
    my $w;
    local $SIG{__WARN__} = sub { $w++ };
    BEGIN {
	# should have no effect:
	my $x = ${^WARNING_BITS};
	${^WARNING_BITS} = $x;
    }
    {
	local $^W = 1;
	() = 1 + undef;
    }
    print "# ", $w//'no', " warnings\nnot " unless $w == 1;
    print "ok 28 - ",
          "setting \${^WARNING_BITS} to its own value has no effect\n";
}

# [perl #112326]
# this code could cause a crash, due to PL_hints continuing to point to th
# hints hash currently being freed

{
    package Foo;
    my @h = qw(a 1 b 2);
    BEGIN {
	$^H{FOO} = bless {};
    }
    sub DESTROY {
	@h = %^H;
	delete $INC{strict}; require strict; # boom!
    }
    my $h = join ':', %h;
    # this isn't the main point of the test; the main point is that
    # it doesn't crash!
    print "not " if $h ne '';
    print "ok 29 - #112326\n";
}


# [perl #112444]
# A destructor called while %^H is freed should not be able to stop %^H
# from being magical (due to *^H{HASH} being undef).
{
    BEGIN {
	# Make sure %^H is clear and not localised, to begin with
	%^H = ();
	$^H = 0;
    }
    DESTROY { %^H }
    {
	{
	    BEGIN {
		$^H{foom} = bless[];
	    }
	} # scope exit triggers destructor, which autovivifies a non-
	  # magical %^H
	BEGIN {
	    # Here we have the %^H created by DESTROY, which is
	    # not localised
	    $^H{112444} = 'baz';
	}
    } # %^H leaks on scope exit
    BEGIN { @keez = keys %^H }
}
print "not " if @keez;
print "ok 30 - %^H does not leak when autovivified in destructor\n";
print "# keys are: @keez\n" if @keez;


# Add new tests above this require, in case it fails.
require './test.pl';

# bug #27040: hints hash was being double-freed
my $result = runperl(
    prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}',
    stderr => 1
);
print "not " if length $result;
print "ok 31 - double-freeing hints hash\n";
print "# got: $result\n" if length $result;

__END__
# Add new tests above require 'test.pl'