use Config;
-plan tests => 30;
+plan tests => 46;
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
}
SKIP: {
- skip "disabled under -Dmad (eval leaks)", 5 if $Config{mad};
+ skip "disabled under -Dmad (eval leaks)", 6 if $Config{mad};
leak(2, 0, sub { eval '"${<<END}"
' }, 'unterminated here-doc in quotes in multiline eval');
leak(2, 0, sub { eval '"${<<END
'unterminated here-doc in file');
leak(2, 0, sub { eval 'tr/9-0//' }, 'tr/9-0//');
leak(2, 0, sub { eval 'tr/a-z-0//' }, 'tr/a-z-0//');
+ leak(2, 0, sub { eval 'no warnings; nonexistent_function 33838' },
+ 'bareword followed by number');
}
# [perl #114764] Attributes leak scalars
undef $h;
}, 'tied hash iteration does not leak');
-# Hash assignment was leaking when assigning explosive scalars
-package sty {
- sub TIESCALAR { bless [] }
- sub FETCH { die }
+package explosive_scalar {
+ sub TIESCALAR { my $self = shift; bless [undef, {@_}], $self }
+ sub FETCH { die 'FETCH' if $_[0][1]{FETCH}; $_[0][0] }
+ sub STORE { die 'STORE' if $_[0][1]{STORE}; $_[0][0] = $_[1] }
}
+tie my $die_on_fetch, 'explosive_scalar', FETCH => 1;
+
+# List assignment was leaking when assigning explosive scalars to
+# aggregates.
leak(2, 0, sub {
- tie my $x, sty;
- eval {%a = ($x, 0)}; # key
- eval {%a = (0, $x)}; # value
- eval {%a = ($x,$x)}; # both
+ eval {%a = ($die_on_fetch, 0)}; # key
+ eval {%a = (0, $die_on_fetch)}; # value
+ eval {%a = ($die_on_fetch, $die_on_fetch)}; # both
}, 'hash assignment does not leak');
+leak(2, 0, sub {
+ eval {@a = ($die_on_fetch)};
+ eval {($die_on_fetch, $b) = ($b, $die_on_fetch)};
+ # restore
+ tie $die_on_fetch, 'explosive_scalar', FETCH => 1;
+}, 'array assignment does not leak');
+
+# [perl #107000]
+package hhtie {
+ sub TIEHASH { bless [] }
+ sub STORE { $_[0][0]{$_[1]} = $_[2] }
+ sub FETCH { die if $explosive; $_[0][0]{$_[1]} }
+ sub FIRSTKEY { keys %{$_[0][0]}; each %{$_[0][0]} }
+ sub NEXTKEY { each %{$_[0][0]} }
+}
+leak(2,!!$Config{mad}, sub {
+ eval q`
+ BEGIN {
+ $hhtie::explosive = 0;
+ tie %^H, hhtie;
+ $^H{foo} = bar;
+ $hhtie::explosive = 1;
+ }
+ { 1; }
+ `;
+}, 'hint-hash copying does not leak');
+
+package explosive_array {
+ sub TIEARRAY { bless [[], {}], $_[0] }
+ sub FETCH { die if $_[0]->[1]{FETCH}; $_[0]->[0][$_[1]] }
+ sub FETCHSIZE { die if $_[0]->[1]{FETCHSIZE}; scalar @{ $_[0]->[0] } }
+ sub STORE { die if $_[0]->[1]{STORE}; $_[0]->[0][$_[1]] = $_[2] }
+ sub CLEAR { die if $_[0]->[1]{CLEAR}; @{$_[0]->[0]} = () }
+ sub EXTEND { die if $_[0]->[1]{EXTEND}; return }
+ sub explode { my $self = shift; $self->[1] = {@_} }
+}
+
+leak(2, 0, sub {
+ tie my @a, 'explosive_array';
+ tied(@a)->explode( STORE => 1 );
+ my $x = 0;
+ eval { @a = ($x) };
+}, 'explosive array assignment does not leak');
+
+leak(2, 0, sub {
+ my ($a, $b);
+ eval { warn $die_on_fetch };
+}, 'explosive warn argument');
+
+leak(2, 0, sub {
+ my $foo = sub { return $die_on_fetch };
+ my $res = eval { $foo->() };
+ my @res = eval { $foo->() };
+}, 'function returning explosive does not leak');
+
+leak(2, 0, sub {
+ my $res = eval { {$die_on_fetch, 0} };
+ $res = eval { {0, $die_on_fetch} };
+}, 'building anon hash with explosives does not leak');
+
+leak(2, 0, sub {
+ my $res = eval { [$die_on_fetch] };
+}, 'building anon array with explosives does not leak');
+
+leak(2, 0, sub {
+ my @a;
+ eval { push @a, $die_on_fetch };
+}, 'pushing exploding scalar does not leak');
+
+leak(2, 0, sub {
+ eval { push @-, '' };
+}, 'pushing onto read-only array does not leak');
+
+# Run-time regexp code blocks
+{
+ use re 'eval';
+ my @tests = ('[(?{})]','(?{})');
+ for my $t (@tests) {
+ leak(2, 0, sub {
+ / $t/;
+ }, "/ \$x/ where \$x is $t does not leak");
+ leak(2, 0, sub {
+ /(?{})$t/;
+ }, "/(?{})\$x/ where \$x is $t does not leak");
+ }
+}
+
+
+{
+ use warnings FATAL => 'all';
+ leak(2, 0, sub {
+ eval { printf uNopened 42 };
+ }, 'printfing to bad handle under fatal warnings does not leak');
+ open my $fh, ">", \my $buf;
+ leak(2, 0, sub {
+ eval { printf $fh chr 2455 };
+ }, 'wide fatal warning does not make printf leak');
+ close $fh or die $!;
+}