1#!./perl 2 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. 6 7BEGIN { 8 chdir 't' if -d 't'; 9 @INC = '../lib'; 10 require './test.pl'; 11 12 eval { require XS::APItest; XS::APItest->import('sv_count'); 1 } 13 or skip_all("XS::APItest not available"); 14} 15 16use Config; 17 18plan tests => 150; 19 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 22# 23sub leak { 24 my ($n, $delta, $code, @rest) = @_; 25 my $sv0 = 0; 26 my $sv1 = 0; 27 for my $i (1..$n) { 28 &$code(); 29 $sv1 = sv_count(); 30 $sv0 = $sv1 if $i == 1; 31 } 32 cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest); 33} 34 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. 38sub eleak { 39 my ($n,$delta,$code,@rest) = @_; 40 no warnings 'deprecated'; # Silence the literal control character warning 41 leak $n, $delta, sub { eval $code }, 42 @rest ? @rest : $code 43} 44 45# run some expression N times. The expr is concatenated N times and then 46# evaled, ensuring 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 49# 50sub leak_expr { 51 my ($n, $delta, $expr, @rest) = @_; 52 my $sv0 = 0; 53 my $sv1 = 0; 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())"; 58 if (eval $code) { 59 cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest); 60 } 61 else { 62 fail("eval @rest: $@"); 63 } 64} 65 66 67my @a; 68 69leak(5, 0, sub {}, "basic check 1 of leak test infrastructure"); 70leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure"); 71leak(5, 1, sub {push @a,1;}, "basic check 3 of leak test infrastructure"); 72 73# delete 74{ 75 my $key = "foo"; 76 $key++ while exists $ENV{$key}; 77 leak(2, 0, sub { delete local $ENV{$key} }, 78 'delete local on nonexistent env var'); 79} 80 81# defined 82leak(2, 0, sub { defined *{"!"} }, 'defined *{"!"}'); 83leak(2, 0, sub { defined *{"["} }, 'defined *{"["}'); 84leak(2, 0, sub { defined *{"-"} }, 'defined *{"-"}'); 85sub def_bang { defined *{"!"}; delete $::{"!"} } 86def_bang; 87leak(2, 0, \&def_bang,'defined *{"!"} vivifying GV'); 88leak(2, 0, sub { defined *{"["}; delete $::{"["} }, 89 'defined *{"["} vivifying GV'); 90sub def_neg { defined *{"-"}; delete $::{"-"} } 91def_neg; 92leak(2, 0, \&def_neg, 'defined *{"-"} vivifying GV'); 93 94# Fatal warnings 95my $f = "use warnings FATAL =>"; 96my $all = "$f 'all';"; 97eleak(2, 0, "$f 'deprecated'; qq|\\c\{|", 'qq|\c{| with fatal warnings'); 98eleak(2, 0, "$f 'syntax'; qq|\\c`|", 'qq|\c`| with fatal warnings'); 99eleak(2, 0, "$all /\$\\ /", '/$\ / with fatal warnings'); 100eleak(2, 0, "$all s//\\1/", 's//\1/ with fatal warnings'); 101eleak(2, 0, "$all qq|\\i|", 'qq|\i| with fatal warnings'); 102eleak(2, 0, "$f 'digit'; qq|\\o{9}|", 'qq|\o{9}| with fatal warnings'); 103eleak(3, 1, "$f 'misc'; sub foo{} sub foo:lvalue", 104 'ignored :lvalue with fatal warnings'); 105eleak(2, 0, "no warnings; use feature ':all'; $f 'misc'; 106 my sub foo{} sub foo:lvalue", 107 'ignored mysub :lvalue with fatal warnings'); 108eleak(2, 0, "no warnings; use feature ':all'; $all 109 my sub foo{} sub foo:lvalue{}", 110 'fatal mysub redef warning'); 111eleak(2, 0, "$all sub foo{} sub foo{}", 'fatal sub redef warning'); 112eleak(2, 0, "$all *x=sub {}", 113 'fatal sub redef warning with sub-to-glob assignment'); 114eleak(2, 0, "$all *x=sub() {1}", 115 'fatal const sub redef warning with sub-to-glob assignment'); 116eleak(2, 0, "$all XS::APItest::newCONSTSUB(\\%main::=>name=>0=>1)", 117 'newCONSTSUB sub redefinition with fatal warnings'); 118eleak(2, 0, "$f 'misc'; my\$a,my\$a", 'double my with fatal warnings'); 119eleak(2, 0, "$f 'misc'; our\$a,our\$a", 'double our with fatal warnings'); 120eleak(2, 0, "$f 'closure'; 121 sub foo { my \$x; format=\n\@\n\$x\n.\n} write; ", 122 'format closing over unavailable var with fatal warnings'); 123eleak(2, 0, "$all /(?{})?/ ", '(?{})? with fatal warnings'); 124eleak(2, 0, "$all /(?{})+/ ", '(?{})+ with fatal warnings'); 125eleak(2, 0, "$all /[\\i]/ ", 'invalid charclass escape with fatal warns'); 126eleak(2, 0, "$all /[:foo:]/ ", '/[:foo:]/ with fatal warnings'); 127eleak(2, 0, "$all /[a-\\d]/ ", '[a-\d] char class with fatal warnings'); 128eleak(2, 0, "$all v111111111111111111111111111111111111111111111111", 129 'vstring num overflow with fatal warnings'); 130 131eleak(2, 0, 'sub{<*>}'); 132# Use a random number of ops, so that the glob op does not reuse the same 133# address each time, giving us false passes. 134leak(2, 0, sub { eval '$x+'x(1 + rand() * 100) . '<*>'; }, 135 'freeing partly iterated glob'); 136 137eleak(2, 0, 'goto sub {}', 'goto &sub in eval'); 138eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort'); 139eleak(2, 0, '/(?{ goto sub {} })/', 'goto &sub in regexp'); 140 141sub TIEARRAY { bless [], $_[0] } 142sub FETCH { $_[0]->[$_[1]] } 143sub STORE { $_[0]->[$_[1]] = $_[2] } 144 145# local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>" 146{ 147 tie my @a, 'main'; 148 leak(5, 0, sub {local $a[0]}, "local \$tied[0]"); 149} 150 151# Overloading 152require overload; 153eleak(2, 0, "BEGIN{overload::constant integer=>sub{}} 1,1,1,1,1,1,1,1,1,1", 154 '"too many errors" from constant overloading returning undef'); 155# getting this one to leak was complicated; we have to unset LOCALIZE_HH: 156eleak(2, 0, 'BEGIN{overload::constant integer=>sub{}; $^H &= ~ 0x00020000} 157 1,1,1,1,1,1,1,1,1,1', 158 '"too many errors" from constant overloading with $^H sabotaged'); 159eleak(2, 0, "BEGIN{overload::constant integer=>sub{}; undef %^H} 160 1,1,1,1,1,1,1,1,1,1", 161 '"too many errors" from constant overloading with %^H undefined'); 162 163 164# [perl #74484] repeated tries leaked SVs on the tmps stack 165 166leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak"); 167 168# [perl #48004] map/grep didn't free tmps till the end 169 170{ 171 # qr/1/ just creates tmps that are hopefully freed per iteration 172 173 my $s; 174 my @a; 175 my @count = (0) x 4; # pre-allocate 176 # Using 0..3 with constant endpoints will cause an erroneous test fail- 177 # ure, as the SV in the op tree needs to be copied (to protect it), 178 # but copying happens *during iteration*, causing the number of SVs to 179 # go up. Using a variable (0..$_3) will cause evaluation of the range 180 # operator at run time, not compile time, so the values will already be 181 # on the stack before grep starts. 182 my $_3 = 3; 183 184 grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3; 185 is(@count[3] - @count[0], 0, "void grep expr: no new tmps per iter"); 186 grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3; 187 is(@count[3] - @count[0], 0, "void grep block: no new tmps per iter"); 188 189 $s = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3; 190 is(@count[3] - @count[0], 0, "scalar grep expr: no new tmps per iter"); 191 $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3; 192 is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter"); 193 194 @a = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3; 195 is(@count[3] - @count[0], 0, "list grep expr: no new tmps per iter"); 196 @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3; 197 is(@count[3] - @count[0], 0, "list grep block: no new tmps per iter"); 198 199 200 map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3; 201 is(@count[3] - @count[0], 0, "void map expr: no new tmps per iter"); 202 map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3; 203 is(@count[3] - @count[0], 0, "void map block: no new tmps per iter"); 204 205 $s = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3; 206 is(@count[3] - @count[0], 0, "scalar map expr: no new tmps per iter"); 207 $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3; 208 is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter"); 209 210 @a = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..$_3; 211 is(@count[3] - @count[0], 3, "list map expr: one new tmp per iter"); 212 @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..$_3; 213 is(@count[3] - @count[0], 3, "list map block: one new tmp per iter"); 214 215} 216 217# Map plus sparse array 218{ 219 my @a; 220 $a[10] = 10; 221 leak(3, 0, sub { my @b = map 1, @a }, 222 'map reading from sparse array'); 223} 224 225SKIP: 226{ # broken by 304474c3, fixed by cefd5c7c, but didn't seem to cause 227 # any other test failures 228 # base test case from ribasushi (Peter Rabbitson) 229 eval { require Scalar::Util; Scalar::Util->import("weaken"); 1; } 230 or skip "no weaken", 1; 231 my $weak; 232 { 233 $weak = my $in = {}; 234 weaken($weak); 235 my $out = { in => $in, in => undef } 236 } 237 ok(!$weak, "hash referenced weakened SV released"); 238} 239 240# prototype() errors 241leak(2,0, sub { eval { prototype "CORE::fu" } }, 'prototype errors'); 242 243# RT #72246: rcatline memory leak on bad $/ 244 245leak(2, 0, 246 sub { 247 my $f; 248 open CATLINE, '<', \$f; 249 local $/ = "\x{262E}"; 250 my $str = "\x{2622}"; 251 eval { $str .= <CATLINE> }; 252 }, 253 "rcatline leak" 254); 255 256{ 257 my $RE = qr/ 258 (?: 259 <(?<tag> 260 \s* 261 [^>\s]+ 262 )> 263 )?? 264 /xis; 265 266 "<html><body></body></html>" =~ m/$RE/gcs; 267 268 leak(5, 0, sub { 269 my $tag = $+{tag}; 270 }, "named regexp captures"); 271} 272 273eleak(2,0,'/[:]/'); 274eleak(2,0,'/[\xdf]/i'); 275eleak(2,0,'s![^/]!!'); 276eleak(2,0,'/[pp]/'); 277eleak(2,0,'/[[:ascii:]]/'); 278eleak(2,0,'/[[.zog.]]/'); 279eleak(2,0,'/[.zog.]/'); 280eleak(2,0,'/|\W/', '/|\W/ [perl #123198]'); 281eleak(2,0,'no warnings; /(?[])/'); 282eleak(2,0,'no warnings; /(?[[a]+[b]])/'); 283eleak(2,0,'no warnings; /(?[[a]-[b]])/'); 284eleak(2,0,'no warnings; /(?[[a]&[b]])/'); 285eleak(2,0,'no warnings; /(?[[a]|[b]])/'); 286eleak(2,0,'no warnings; /(?[[a]^[b]])/'); 287eleak(2,0,'no warnings; /(?[![a]])/'); 288eleak(2,0,'no warnings; /(?[\p{Word}])/'); 289eleak(2,0,'no warnings; /(?[[a]+)])/'); 290eleak(2,0,'no warnings; /(?[\d\d)])/'); 291 292# These can generate one ref count, but just once. 293eleak(4,1,'chr(0x100) =~ /[[:punct:]]/'); 294eleak(4,1,'chr(0x100) =~ /[[:^punct:]]/'); 295eleak(4,1,'chr(0x100) =~ /[[:word:]]/'); 296eleak(4,1,'chr(0x100) =~ /[[:^word:]]/'); 297 298eleak(2,0,'chr(0x100) =~ /\P{Assigned}/'); 299leak(2,0,sub { /(??{})/ }, '/(??{})/'); 300 301leak(2,0,sub { !$^V }, '[perl #109762] version object in boolean context'); 302 303 304# [perl #114356] run-time rexexp with unchanging pattern got 305# inflated refcounts 306eleak(2, 0, q{ my $x = "x"; "abc" =~ /$x/ for 1..5 }, '#114356'); 307 308eleak(2, 0, 'sub', '"sub" with nothing following'); 309eleak(2, 0, '+sub:a{}', 'anon subs with invalid attributes'); 310eleak(2, 0, 'no warnings; sub a{1 1}', 'sub with syntax error'); 311eleak(2, 0, 'no warnings; sub {1 1}', 'anon sub with syntax error'); 312eleak(2, 0, 'no warnings; use feature ":all"; my sub a{1 1}', 313 'my sub with syntax error'); 314 315# Reification (or lack thereof) 316leak(2, 0, sub { sub { local $_[0]; shift }->(1) }, 317 'local $_[0] on surreal @_, followed by shift'); 318leak(2, 0, sub { sub { local $_[0]; \@_ }->(1) }, 319 'local $_[0] on surreal @_, followed by reification'); 320 321sub recredef {} 322sub Recursive::Redefinition::DESTROY { 323 *recredef = sub { CORE::state $x } # state makes it cloneable 324} 325leak(2, 0, sub { 326 bless \&recredef, "Recursive::Redefinition"; eval "sub recredef{}" 327}, 'recursive sub redefinition'); 328 329# Sub calls 330leak(2, 0, sub { local *_; $_[1]=1; &re::regname }, 331 'passing sparse array to xsub via ampersand call'); 332 333# Syntax errors 334eleak(2, 0, '"${<<END}" 335 ', 'unterminated here-doc in quotes in multiline eval'); 336eleak(2, 0, '"${<<END 337 }"', 'unterminated here-doc in multiline quotes in eval'); 338leak(2, 0, sub { eval { do './op/svleak.pl' } }, 339 'unterminated here-doc in file'); 340eleak(2, 0, 'tr/9-0//'); 341eleak(2, 0, 'tr/a-z-0//'); 342eleak(2, 0, 'no warnings; nonexistent_function 33838', 343 'bareword followed by number'); 344eleak(2, 0, '//dd;'x20, '"too many errors" when parsing m// flags'); 345eleak(2, 0, 's///dd;'x20, '"too many errors" when parsing s/// flags'); 346eleak(2, 0, 'no warnings; 2 2;BEGIN{}', 347 'BEGIN block after syntax error'); 348{ 349 local %INC; # in case Errno is already loaded 350 eleak(2, 0, 'no warnings; 2@!{', 351 'implicit "use Errno" after syntax error'); 352} 353eleak(2, 0, "\"\$\0\356\"", 'qq containing $ <null> something'); 354eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words'); 355eleak(2, 0, "+ + +;qq|\\N{a}|"x10,'qq"\N{a}" after errors'); 356eleak(2, 0, "qq|\\N{%}|", 'qq"\N{%}" (invalid charname)'); 357eleak(2, 0, "qq|\\N{au}|;", 'qq"\N{invalid}"'); 358eleak(2, 0, "qq|\\c|;"x10, '"too many errors" from qq"\c"'); 359eleak(2, 0, "qq|\\o|;"x10, '"too many errors" from qq"\o"'); 360eleak(2, 0, "qq|\\x{|;"x10, '"too many errors" from qq"\x{"'); 361eleak(2, 0, "qq|\\N|;"x10, '"too many errors" from qq"\N"'); 362eleak(2, 0, "qq|\\N{|;"x10, '"too many errors" from qq"\N{"'); 363eleak(2, 0, "qq|\\N{U+GETG}|;"x10,'"too many errors" from qq"\N{U+JUNK}"'); 364 365 366# [perl #114764] Attributes leak scalars 367leak(2, 0, sub { eval 'my $x : shared' }, 'my $x :shared used to leak'); 368 369eleak(2, 0, 'ref: 1', 'labels'); 370 371# Tied hash iteration was leaking if the hash was freed before itera- 372# tion was over. 373package t { 374 sub TIEHASH { bless [] } 375 sub FIRSTKEY { 0 } 376} 377leak(2, 0, sub { 378 my $h = {}; 379 tie %$h, t; 380 each %$h; 381 undef $h; 382}, 'tied hash iteration does not leak'); 383 384package explosive_scalar { 385 sub TIESCALAR { my $self = shift; bless [undef, {@_}], $self } 386 sub FETCH { die 'FETCH' if $_[0][1]{FETCH}; $_[0][0] } 387 sub STORE { die 'STORE' if $_[0][1]{STORE}; $_[0][0] = $_[1] } 388} 389tie my $die_on_fetch, 'explosive_scalar', FETCH => 1; 390 391# List assignment was leaking when assigning explosive scalars to 392# aggregates. 393leak(2, 0, sub { 394 eval {%a = ($die_on_fetch, 0)}; # key 395 eval {%a = (0, $die_on_fetch)}; # value 396 eval {%a = ($die_on_fetch, $die_on_fetch)}; # both 397 eval {%a = ($die_on_fetch)}; # key, odd elements 398}, 'hash assignment does not leak'); 399leak(2, 0, sub { 400 eval {@a = ($die_on_fetch)}; 401 eval {($die_on_fetch, $b) = ($b, $die_on_fetch)}; 402 # restore 403 tie $die_on_fetch, 'explosive_scalar', FETCH => 1; 404}, 'array assignment does not leak'); 405 406# [perl #107000] 407package hhtie { 408 sub TIEHASH { bless [] } 409 sub STORE { $_[0][0]{$_[1]} = $_[2] } 410 sub FETCH { die if $explosive; $_[0][0]{$_[1]} } 411 sub FIRSTKEY { keys %{$_[0][0]}; each %{$_[0][0]} } 412 sub NEXTKEY { each %{$_[0][0]} } 413} 414leak(2, 0, sub { 415 eval q` 416 BEGIN { 417 $hhtie::explosive = 0; 418 tie %^H, hhtie; 419 $^H{foo} = bar; 420 $hhtie::explosive = 1; 421 } 422 { 1; } 423 `; 424}, 'hint-hash copying does not leak'); 425 426package explosive_array { 427 sub TIEARRAY { bless [[], {}], $_[0] } 428 sub FETCH { die if $_[0]->[1]{FETCH}; $_[0]->[0][$_[1]] } 429 sub FETCHSIZE { die if $_[0]->[1]{FETCHSIZE}; scalar @{ $_[0]->[0] } } 430 sub STORE { die if $_[0]->[1]{STORE}; $_[0]->[0][$_[1]] = $_[2] } 431 sub CLEAR { die if $_[0]->[1]{CLEAR}; @{$_[0]->[0]} = () } 432 sub EXTEND { die if $_[0]->[1]{EXTEND}; return } 433 sub explode { my $self = shift; $self->[1] = {@_} } 434} 435 436leak(2, 0, sub { 437 tie my @a, 'explosive_array'; 438 tied(@a)->explode( STORE => 1 ); 439 my $x = 0; 440 eval { @a = ($x) }; 441}, 'explosive array assignment does not leak'); 442 443leak(2, 0, sub { 444 my ($a, $b); 445 eval { warn $die_on_fetch }; 446}, 'explosive warn argument'); 447 448leak(2, 0, sub { 449 my $foo = sub { return $die_on_fetch }; 450 my $res = eval { $foo->() }; 451 my @res = eval { $foo->() }; 452}, 'function returning explosive does not leak'); 453 454leak(2, 0, sub { 455 my $res = eval { {$die_on_fetch, 0} }; 456 $res = eval { {0, $die_on_fetch} }; 457}, 'building anon hash with explosives does not leak'); 458 459leak(2, 0, sub { 460 my $res = eval { [$die_on_fetch] }; 461}, 'building anon array with explosives does not leak'); 462 463leak(2, 0, sub { 464 my @a; 465 eval { push @a, $die_on_fetch }; 466}, 'pushing exploding scalar does not leak'); 467 468leak(2, 0, sub { 469 eval { push @-, '' }; 470}, 'pushing onto read-only array does not leak'); 471 472 473# Run-time regexp code blocks 474{ 475 use re 'eval'; 476 my @tests = ('[(?{})]','(?{})'); 477 for my $t (@tests) { 478 leak(2, 0, sub { 479 / $t/; 480 }, "/ \$x/ where \$x is $t does not leak"); 481 leak(2, 0, sub { 482 /(?{})$t/; 483 }, "/(?{})\$x/ where \$x is $t does not leak"); 484 } 485} 486 487 488{ 489 use warnings FATAL => 'all'; 490 leak(2, 0, sub { 491 no warnings 'once'; 492 eval { printf uNopened 42 }; 493 }, 'printfing to bad handle under fatal warnings does not leak'); 494 open my $fh, ">", \my $buf; 495 leak(2, 0, sub { 496 eval { printf $fh chr 2455 }; 497 }, 'wide fatal warning does not make printf leak'); 498 close $fh or die $!; 499} 500 501 502leak(2,0,sub{eval{require untohunothu}}, 'requiring nonexistent module'); 503 504# [perl #120939] 505use constant const_av_xsub_leaked => 1 .. 3; 506leak(5, 0, sub { scalar &const_av_xsub_leaked }, "const_av_sub in scalar context"); 507 508# check that OP_MULTIDEREF doesn't leak when compiled and then freed 509 510eleak(2, 0, <<'EOF', 'OP_MULTIDEREF'); 511no strict; 512no warnings; 513my ($x, @a, %h, $r, $k, $i); 514$x = $a[0]{foo}{$k}{$i}; 515$x = $h[0]{foo}{$k}{$i}; 516$x = $r->[0]{foo}{$k}{$i}; 517$x = $mdr::a[0]{foo}{$mdr::k}{$mdr::i}; 518$x = $mdr::h[0]{foo}{$mdr::k}{$mdr::i}; 519$x = $mdr::r->[0]{foo}{$mdr::k}{$mdr::i}; 520EOF 521 522# un-localizing a tied (or generally magic) item could leak if the things 523# called by mg_set() died 524 525{ 526 package MG_SET; 527 528 sub TIESCALAR { bless [] } 529 sub FETCH { 1; } 530 my $do_die = 0; 531 sub STORE { die if $do_die; } 532 533 sub f { 534 local $s; 535 tie $s, 'MG_SET'; 536 local $s; 537 $do_die = 1; 538 } 539 sub g { 540 eval { my $x = f(); }; 541 } 542 543 ::leak(5,0, \&g, "MG_SET"); 544} 545 546# check that @_ isn't leaked when dieing while goto'ing a new sub 547 548{ 549 package my_goto; 550 sub TIEARRAY { bless [] } 551 sub FETCH { 1 } 552 sub STORE { die if $_[0][0]; $_[0][0] = 1 } 553 554 sub f { eval { g() } } 555 sub g { 556 my @a; 557 tie @a, "my_goto"; 558 local $a[0]; 559 goto &h; 560 } 561 sub h {} 562 563 ::leak(5, 0, \&f, q{goto shouldn't leak @_}); 564} 565 566# [perl #128313] POSIX warnings shouldn't leak 567{ 568 no warnings 'experimental'; 569 use re 'strict'; 570 my $a = 'aaa'; 571 my $b = 'aa'; 572 sub f { $a =~ /[^.]+$b/; } 573 ::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings}); 574} 575 576# check that B::RHE->HASH does not leak 577{ 578 package BHINT; 579 sub foo {} 580 require B; 581 my $op = B::svref_2object(\&foo)->ROOT->first; 582 sub lk { { my $d = $op->hints_hash->HASH } } 583 ::leak(3, 0, \&lk, q!B::RHE->HASH shoudln't leak!); 584} 585 586 587# dying while compiling a regex with codeblocks imported from an embedded 588# qr// could leak 589 590{ 591 my sub codeblocks { 592 my $r = qr/(?{ 1; })/; 593 my $c = '(?{ 2; })'; 594 eval { /$r$c/ } 595 } 596 ::leak(2, 0, \&codeblocks, q{leaking embedded qr codeblocks}); 597} 598 599{ 600 # Perl_reg_named_buff_fetch() leaks an AV when called with an RE 601 # with no named captures 602 sub named { 603 "x" =~ /x/; 604 re::regname("foo", 1); 605 } 606 ::leak(2, 0, \&named, "Perl_reg_named_buff_fetch() on no-name RE"); 607} 608 609{ 610 sub N_leak { eval 'tr//\N{}-0/' } 611 ::leak(2, 0, \&N_leak, "a bad \\N{} in a range leaks"); 612} 613 614leak 2,0,\&XS::APItest::PerlIO_stderr,'T_INOUT in default typemap'; 615leak 2,0,\&XS::APItest::PerlIO_stdin, 'T_IN in default typemap'; 616leak 2,0,\&XS::APItest::PerlIO_stdout,'T_OUT in default typemap'; 617SKIP: { 618 skip "for now; crashes"; 619 leak 2,1,sub{XS::APItest::PerlIO_exportFILE(*STDIN,"");0}, 620 'T_STDIO in default typemap'; 621} 622 623{ 624 my %rh= ( qr/^foo/ => 1); 625 sub Regex_Key_Leak { my ($r)= keys %rh; "foo"=~$r; } 626 leak 2, 0, \&Regex_Key_Leak,"RT #132892 - regex patterns should not leak"; 627} 628 629{ 630 # perl #133660 631 fresh_perl_is(<<'PERL', "ok", {}, "check goto core sub doesn't leak"); 632# done this way to avoid overloads for all of svleak.t 633use B; 634BEGIN { 635 *CORE::GLOBAL::open = sub (*;$@) { 636 goto \&CORE::open; 637 }; 638} 639 640my $refcount; 641{ 642 open(my $fh, '<', 'TEST'); 643 my $sv = B::svref_2object($fh); 644 print $sv->REFCNT == 1 ? "ok" : "not ok"; 645} 646PERL 647} 648