3 # A place to put some simple leak tests. Uses XS::APItest to make
4 # PL_sv_count available, allowing us to run a bit of code multiple times and
5 # see if the count increases.
12 eval { require XS::APItest; XS::APItest->import('sv_count'); 1 }
13 or skip_all("XS::APItest not available");
20 # run some code N times. If the number of SVs at the end of loop N is
21 # greater than (N-1)*delta at the end of loop 1, we've got a leak
24 my ($n, $delta, $code, @rest) = @_;
30 $sv0 = $sv1 if $i == 1;
32 cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest);
35 # Like leak, but run a string eval instead.
36 # The code is used instead of the test name
37 # if the name is absent.
39 my ($n,$delta,$code,@rest) = @_;
40 no warnings 'deprecated'; # Silence the literal control character warning
41 leak $n, $delta, sub { eval $code },
45 # run some expression N times. The expr is concatenated N times and then
46 # evaled, ensuring that that there are no scope exits between executions.
47 # If the number of SVs at the end of expr N is greater than (N-1)*delta at
48 # the end of expr 1, we've got a leak
51 my ($n, $delta, $expr, @rest) = @_;
54 my $true = 1; # avoid stuff being optimised away
55 my $code1 = "($expr || \$true)";
56 my $code = "$code1 && (\$sv0 = sv_count())" . ("&& $code1" x 4)
57 . " && (\$sv1 = sv_count())";
59 cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest);
62 fail("eval @rest: $@");
69 leak(5, 0, sub {}, "basic check 1 of leak test infrastructure");
70 leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure");
71 leak(5, 1, sub {push @a,1;}, "basic check 3 of leak test infrastructure");
76 $key++ while exists $ENV{$key};
77 leak(2, 0, sub { delete local $ENV{$key} },
78 'delete local on nonexistent env var');
82 my $f = "use warnings FATAL =>";
83 my $all = "$f 'all';";
84 eleak(2, 0, "$f 'deprecated'; qq|\\c\{|", 'qq|\c{| with fatal warnings');
85 eleak(2, 0, "$f 'syntax'; qq|\\c`|", 'qq|\c`| with fatal warnings');
86 eleak(2, 0, "$all /\$\\ /", '/$\ / with fatal warnings');
87 eleak(2, 0, "$all s//\\1/", 's//\1/ with fatal warnings');
88 eleak(2, 0, "$all qq|\\i|", 'qq|\i| with fatal warnings');
89 eleak(2, 0, "$f 'digit'; qq|\\o{9}|", 'qq|\o{9}| with fatal warnings');
90 eleak(3, 1, "$f 'misc'; sub foo{} sub foo:lvalue",
91 'ignored :lvalue with fatal warnings');
92 eleak(2, 0, "no warnings; use feature ':all'; $f 'misc';
93 my sub foo{} sub foo:lvalue",
94 'ignored mysub :lvalue with fatal warnings');
95 eleak(2, 0, "no warnings; use feature ':all'; $all
96 my sub foo{} sub foo:lvalue{}",
97 'fatal mysub redef warning');
98 eleak(2, 0, "$all sub foo{} sub foo{}", 'fatal sub redef warning');
99 eleak(2, 0, "$all *x=sub {}",
100 'fatal sub redef warning with sub-to-glob assignment');
101 eleak(2, 0, "$all *x=sub() {1}",
102 'fatal const sub redef warning with sub-to-glob assignment');
103 eleak(2, 0, "$all XS::APItest::newCONSTSUB(\\%main::=>name=>0=>1)",
104 'newCONSTSUB sub redefinition with fatal warnings');
105 eleak(2, 0, "$f 'misc'; my\$a,my\$a", 'double my with fatal warnings');
106 eleak(2, 0, "$f 'misc'; our\$a,our\$a", 'double our with fatal warnings');
107 eleak(2, 0, "$f 'closure';
108 sub foo { my \$x; format=\n\@\n\$x\n.\n} write; ",
109 'format closing over unavailable var with fatal warnings');
110 eleak(2, 0, "$all /(?{})?/ ", '(?{})? with fatal warnings');
111 eleak(2, 0, "$all /(?{})+/ ", '(?{})+ with fatal warnings');
112 eleak(2, 0, "$all /[\\i]/ ", 'invalid charclass escape with fatal warns');
113 eleak(2, 0, "$all /[:foo:]/ ", '/[:foo:]/ with fatal warnings');
114 eleak(2, 0, "$all /[a-\\d]/ ", '[a-\d] char class with fatal warnings');
115 eleak(2, 0, "$all v111111111111111111111111111111111111111111111111",
116 'vstring num overflow with fatal warnings');
118 eleak(2, 0, 'sub{<*>}');
119 # Use a random number of ops, so that the glob op does not reuse the same
120 # address each time, giving us false passes.
121 leak(2, 0, sub { eval '$x+'x(1 + rand() * 100) . '<*>'; },
122 'freeing partly iterated glob');
124 eleak(2, 0, 'goto sub {}', 'goto &sub in eval');
125 eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort');
126 eleak(2, 0, '/(?{ goto sub {} })/', 'goto &sub in regexp');
128 sub TIEARRAY { bless [], $_[0] }
129 sub FETCH { $_[0]->[$_[1]] }
130 sub STORE { $_[0]->[$_[1]] = $_[2] }
132 # local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>"
135 leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
140 eleak(2, 0, "BEGIN{overload::constant integer=>sub{}} 1,1,1,1,1,1,1,1,1,1",
141 '"too many errors" from constant overloading returning undef');
142 # getting this one to leak was complicated; we have to unset LOCALIZE_HH:
143 eleak(2, 0, 'BEGIN{overload::constant integer=>sub{}; $^H &= ~ 0x00020000}
144 1,1,1,1,1,1,1,1,1,1',
145 '"too many errors" from constant overloading with $^H sabotaged');
146 eleak(2, 0, "BEGIN{overload::constant integer=>sub{}; undef %^H}
147 1,1,1,1,1,1,1,1,1,1",
148 '"too many errors" from constant overloading with %^H undefined');
151 # [perl #74484] repeated tries leaked SVs on the tmps stack
153 leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak");
155 # [perl #48004] map/grep didn't free tmps till the end
158 # qr/1/ just creates tmps that are hopefully freed per iteration
162 my @count = (0) x 4; # pre-allocate
163 # Using 0..3 with constant endpoints will cause an erroneous test fail-
164 # ure, as the SV in the op tree needs to be copied (to protect it),
165 # but copying happens *during iteration*, causing the number of SVs to
166 # go up. Using a variable (0..$_3) will cause evaluation of the range
167 # operator at run time, not compile time, so the values will already be
168 # on the stack before grep starts.
171 grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
172 is(@count[3] - @count[0], 0, "void grep expr: no new tmps per iter");
173 grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
174 is(@count[3] - @count[0], 0, "void grep block: no new tmps per iter");
176 $s = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
177 is(@count[3] - @count[0], 0, "scalar grep expr: no new tmps per iter");
178 $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
179 is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter");
181 @a = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
182 is(@count[3] - @count[0], 0, "list grep expr: no new tmps per iter");
183 @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
184 is(@count[3] - @count[0], 0, "list grep block: no new tmps per iter");
187 map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
188 is(@count[3] - @count[0], 0, "void map expr: no new tmps per iter");
189 map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
190 is(@count[3] - @count[0], 0, "void map block: no new tmps per iter");
192 $s = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
193 is(@count[3] - @count[0], 0, "scalar map expr: no new tmps per iter");
194 $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
195 is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter");
197 @a = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3;
198 is(@count[3] - @count[0], 3, "list map expr: one new tmp per iter");
199 @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3;
200 is(@count[3] - @count[0], 3, "list map block: one new tmp per iter");
205 { # broken by 304474c3, fixed by cefd5c7c, but didn't seem to cause
206 # any other test failures
207 # base test case from ribasushi (Peter Rabbitson)
208 eval { require Scalar::Util; Scalar::Util->import("weaken"); 1; }
209 or skip "no weaken", 1;
214 my $out = { in => $in, in => undef }
216 ok(!$weak, "hash referenced weakened SV released");
220 leak(2,0, sub { eval { prototype "CORE::fu" } }, 'prototype errors');
222 # RT #72246: rcatline memory leak on bad $/
227 open CATLINE, '<', \$f;
228 local $/ = "\x{262E}";
229 my $str = "\x{2622}";
230 eval { $str .= <CATLINE> };
245 "<html><body></body></html>" =~ m/$RE/gcs;
249 }, "named regexp captures");
253 eleak(2,0,'/[\xdf]/i');
254 eleak(2,0,'s![^/]!!');
256 eleak(2,0,'/[[:ascii:]]/');
257 eleak(2,0,'/[[.zog.]]/');
258 eleak(2,0,'/[.zog.]/');
259 eleak(2,0,'no warnings; /(?[])/');
260 eleak(2,0,'no warnings; /(?[[a]+[b]])/');
261 eleak(2,0,'no warnings; /(?[[a]-[b]])/');
262 eleak(2,0,'no warnings; /(?[[a]&[b]])/');
263 eleak(2,0,'no warnings; /(?[[a]|[b]])/');
264 eleak(2,0,'no warnings; /(?[[a]^[b]])/');
265 eleak(2,0,'no warnings; /(?[![a]])/');
266 eleak(2,0,'no warnings; /(?[\p{Word}])/');
267 eleak(2,0,'no warnings; /(?[[a]+)])/');
268 eleak(2,0,'no warnings; /(?[\d\d)])/');
270 # These can generate one ref count, but just once.
271 eleak(4,1,'chr(0x100) =~ /[[:punct:]]/');
272 eleak(4,1,'chr(0x100) =~ /[[:^punct:]]/');
273 eleak(4,1,'chr(0x100) =~ /[[:word:]]/');
274 eleak(4,1,'chr(0x100) =~ /[[:^word:]]/');
276 eleak(2,0,'chr(0x100) =~ /\P{Assigned}/');
277 leak(2,0,sub { /(??{})/ }, '/(??{})/');
279 leak(2,0,sub { !$^V }, '[perl #109762] version object in boolean context');
282 # [perl #114356] run-time rexexp with unchanging pattern got
284 eleak(2, 0, q{ my $x = "x"; "abc" =~ /$x/ for 1..5 }, '#114356');
286 eleak(2, 0, 'sub', '"sub" with nothing following');
287 eleak(2, 0, '+sub:a{}', 'anon subs with invalid attributes');
288 eleak(2, 0, 'no warnings; sub a{1 1}', 'sub with syntax error');
289 eleak(2, 0, 'no warnings; sub {1 1}', 'anon sub with syntax error');
290 eleak(2, 0, 'no warnings; use feature ":all"; my sub a{1 1}',
291 'my sub with syntax error');
293 # Reification (or lack thereof)
294 leak(2, 0, sub { sub { local $_[0]; shift }->(1) },
295 'local $_[0] on surreal @_, followed by shift');
296 leak(2, 0, sub { sub { local $_[0]; \@_ }->(1) },
297 'local $_[0] on surreal @_, followed by reification');
300 sub Recursive::Redefinition::DESTROY {
301 *recredef = sub { CORE::state $x } # state makes it cloneable
304 bless \&recredef, "Recursive::Redefinition"; eval "sub recredef{}"
305 }, 'recursive sub redefinition');
308 eleak(2, 0, '"${<<END}"
309 ', 'unterminated here-doc in quotes in multiline eval');
310 eleak(2, 0, '"${<<END
311 }"', 'unterminated here-doc in multiline quotes in eval');
312 leak(2, 0, sub { eval { do './op/svleak.pl' } },
313 'unterminated here-doc in file');
314 eleak(2, 0, 'tr/9-0//');
315 eleak(2, 0, 'tr/a-z-0//');
316 eleak(2, 0, 'no warnings; nonexistent_function 33838',
317 'bareword followed by number');
318 eleak(2, 0, '//dd;'x20, '"too many errors" when parsing m// flags');
319 eleak(2, 0, 's///dd;'x20, '"too many errors" when parsing s/// flags');
320 eleak(2, 0, 'no warnings; 2 2;BEGIN{}',
321 'BEGIN block after syntax error');
323 local %INC; # in case Errno is already loaded
324 eleak(2, 0, 'no warnings; 2@!{',
325 'implicit "use Errno" after syntax error');
327 eleak(2, 0, "\"\$\0\356\"", 'qq containing $ <null> something');
328 eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words');
329 eleak(2, 0, "+ + +;qq|\\N{a}|"x10,'qq"\N{a}" after errors');
330 eleak(2, 0, "qq|\\N{%}|", 'qq"\N{%}" (invalid charname)');
331 eleak(2, 0, "qq|\\N{au}|;", 'qq"\N{invalid}"');
332 eleak(2, 0, "qq|\\c|;"x10, '"too many errors" from qq"\c"');
333 eleak(2, 0, "qq|\\o|;"x10, '"too many errors" from qq"\o"');
334 eleak(2, 0, "qq|\\x{|;"x10, '"too many errors" from qq"\x{"');
335 eleak(2, 0, "qq|\\N|;"x10, '"too many errors" from qq"\N"');
336 eleak(2, 0, "qq|\\N{|;"x10, '"too many errors" from qq"\N{"');
337 eleak(2, 0, "qq|\\N{U+GETG}|;"x10,'"too many errors" from qq"\N{U+JUNK}"');
340 # [perl #114764] Attributes leak scalars
341 leak(2, 0, sub { eval 'my $x : shared' }, 'my $x :shared used to leak');
343 eleak(2, 0, 'ref: 1', 'labels');
345 # Tied hash iteration was leaking if the hash was freed before itera-
348 sub TIEHASH { bless [] }
356 }, 'tied hash iteration does not leak');
358 package explosive_scalar {
359 sub TIESCALAR { my $self = shift; bless [undef, {@_}], $self }
360 sub FETCH { die 'FETCH' if $_[0][1]{FETCH}; $_[0][0] }
361 sub STORE { die 'STORE' if $_[0][1]{STORE}; $_[0][0] = $_[1] }
363 tie my $die_on_fetch, 'explosive_scalar', FETCH => 1;
365 # List assignment was leaking when assigning explosive scalars to
368 eval {%a = ($die_on_fetch, 0)}; # key
369 eval {%a = (0, $die_on_fetch)}; # value
370 eval {%a = ($die_on_fetch, $die_on_fetch)}; # both
371 eval {%a = ($die_on_fetch)}; # key, odd elements
372 }, 'hash assignment does not leak');
374 eval {@a = ($die_on_fetch)};
375 eval {($die_on_fetch, $b) = ($b, $die_on_fetch)};
377 tie $die_on_fetch, 'explosive_scalar', FETCH => 1;
378 }, 'array assignment does not leak');
382 sub TIEHASH { bless [] }
383 sub STORE { $_[0][0]{$_[1]} = $_[2] }
384 sub FETCH { die if $explosive; $_[0][0]{$_[1]} }
385 sub FIRSTKEY { keys %{$_[0][0]}; each %{$_[0][0]} }
386 sub NEXTKEY { each %{$_[0][0]} }
391 $hhtie::explosive = 0;
394 $hhtie::explosive = 1;
398 }, 'hint-hash copying does not leak');
400 package explosive_array {
401 sub TIEARRAY { bless [[], {}], $_[0] }
402 sub FETCH { die if $_[0]->[1]{FETCH}; $_[0]->[0][$_[1]] }
403 sub FETCHSIZE { die if $_[0]->[1]{FETCHSIZE}; scalar @{ $_[0]->[0] } }
404 sub STORE { die if $_[0]->[1]{STORE}; $_[0]->[0][$_[1]] = $_[2] }
405 sub CLEAR { die if $_[0]->[1]{CLEAR}; @{$_[0]->[0]} = () }
406 sub EXTEND { die if $_[0]->[1]{EXTEND}; return }
407 sub explode { my $self = shift; $self->[1] = {@_} }
411 tie my @a, 'explosive_array';
412 tied(@a)->explode( STORE => 1 );
415 }, 'explosive array assignment does not leak');
419 eval { warn $die_on_fetch };
420 }, 'explosive warn argument');
423 my $foo = sub { return $die_on_fetch };
424 my $res = eval { $foo->() };
425 my @res = eval { $foo->() };
426 }, 'function returning explosive does not leak');
429 my $res = eval { {$die_on_fetch, 0} };
430 $res = eval { {0, $die_on_fetch} };
431 }, 'building anon hash with explosives does not leak');
434 my $res = eval { [$die_on_fetch] };
435 }, 'building anon array with explosives does not leak');
439 eval { push @a, $die_on_fetch };
440 }, 'pushing exploding scalar does not leak');
443 eval { push @-, '' };
444 }, 'pushing onto read-only array does not leak');
447 # Run-time regexp code blocks
450 my @tests = ('[(?{})]','(?{})');
454 }, "/ \$x/ where \$x is $t does not leak");
457 }, "/(?{})\$x/ where \$x is $t does not leak");
463 use warnings FATAL => 'all';
466 eval { printf uNopened 42 };
467 }, 'printfing to bad handle under fatal warnings does not leak');
468 open my $fh, ">", \my $buf;
470 eval { printf $fh chr 2455 };
471 }, 'wide fatal warning does not make printf leak');
476 leak(2,0,sub{eval{require untohunothu}}, 'requiring nonexistent module');
479 use constant const_av_xsub_leaked => 1 .. 3;
480 leak(5, 0, sub { scalar &const_av_xsub_leaked }, "const_av_sub in scalar context");