t/op/svleak.t

   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
   7 BEGIN {
   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
  16 use Config;
  17
  18 plan tests => 146;
  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 #
  23 sub 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.
  38 sub 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 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 #
  50 sub 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
  67 my @a;
  68
  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");
  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
  82 leak(2, 0, sub { defined *{"!"} }, 'defined *{"!"}');
  83 leak(2, 0, sub { defined *{"["} }, 'defined *{"["}');
  84 leak(2, 0, sub { defined *{"-"} }, 'defined *{"-"}');
  85 sub def_bang { defined *{"!"}; delete $::{"!"} }
  86 def_bang;
  87 leak(2, 0, \&def_bang,'defined *{"!"} vivifying GV');
  88 leak(2, 0, sub { defined *{"["}; delete $::{"["} },
  89     'defined *{"["} vivifying GV');
  90 sub def_neg { defined *{"-"}; delete $::{"-"} }
  91 def_neg;
  92 leak(2, 0, \&def_neg, 'defined *{"-"} vivifying GV');
  93
  94 # Fatal warnings
  95 my $f = "use warnings FATAL =>";
  96 my $all = "$f 'all';";
  97 eleak(2, 0, "$f 'deprecated'; qq|\\c\{|", 'qq|\c{| with fatal warnings');
  98 eleak(2, 0, "$f 'syntax'; qq|\\c`|", 'qq|\c`| with fatal warnings');
  99 eleak(2, 0, "$all /\$\\ /", '/$\ / with fatal warnings');
 100 eleak(2, 0, "$all s//\\1/", 's//\1/ with fatal warnings');
 101 eleak(2, 0, "$all qq|\\i|", 'qq|\i| with fatal warnings');
 102 eleak(2, 0, "$f 'digit'; qq|\\o{9}|", 'qq|\o{9}| with fatal warnings');
 103 eleak(3, 1, "$f 'misc'; sub foo{} sub foo:lvalue",
 104      'ignored :lvalue with fatal warnings');
 105 eleak(2, 0, "no warnings; use feature ':all'; $f 'misc';
 106              my sub foo{} sub foo:lvalue",
 107      'ignored mysub :lvalue with fatal warnings');
 108 eleak(2, 0, "no warnings; use feature ':all'; $all
 109              my sub foo{} sub foo:lvalue{}",
 110      'fatal mysub redef warning');
 111 eleak(2, 0, "$all sub foo{} sub foo{}", 'fatal sub redef warning');
 112 eleak(2, 0, "$all *x=sub {}",
 113      'fatal sub redef warning with sub-to-glob assignment');
 114 eleak(2, 0, "$all *x=sub() {1}",
 115      'fatal const sub redef warning with sub-to-glob assignment');
 116 eleak(2, 0, "$all XS::APItest::newCONSTSUB(\\%main::=>name=>0=>1)",
 117      'newCONSTSUB sub redefinition with fatal warnings');
 118 eleak(2, 0, "$f 'misc'; my\$a,my\$a", 'double my with fatal warnings');
 119 eleak(2, 0, "$f 'misc'; our\$a,our\$a", 'double our with fatal warnings');
 120 eleak(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');
 123 eleak(2, 0, "$all /(?{})?/ ", '(?{})? with fatal warnings');
 124 eleak(2, 0, "$all /(?{})+/ ", '(?{})+ with fatal warnings');
 125 eleak(2, 0, "$all /[\\i]/ ", 'invalid charclass escape with fatal warns');
 126 eleak(2, 0, "$all /[:foo:]/ ", '/[:foo:]/ with fatal warnings');
 127 eleak(2, 0, "$all /[a-\\d]/ ", '[a-\d] char class with fatal warnings');
 128 eleak(2, 0, "$all v111111111111111111111111111111111111111111111111",
 129      'vstring num overflow with fatal warnings');
 130
 131 eleak(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.
 134 leak(2, 0, sub { eval '$x+'x(1 + rand() * 100) . '<*>'; },
 135     'freeing partly iterated glob');
 136
 137 eleak(2, 0, 'goto sub {}', 'goto &sub in eval');
 138 eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort');
 139 eleak(2, 0, '/(?{ goto sub {} })/', 'goto &sub in regexp');
 140
 141 sub TIEARRAY    { bless [], $_[0] }
 142 sub FETCH       { $_[0]->[$_[1]] }
 143 sub 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
 152 require overload;
 153 eleak(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:
 156 eleak(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');
 159 eleak(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
 166 leak_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 SKIP:
 218 { # broken by 304474c3, fixed by cefd5c7c, but didn't seem to cause
 219   # any other test failures
 220   # base test case from ribasushi (Peter Rabbitson)
 221   eval { require Scalar::Util; Scalar::Util->import("weaken"); 1; }
 222     or skip "no weaken", 1;
 223   my $weak;
 224   {
 225     $weak = my $in = {};
 226     weaken($weak);
 227     my $out = { in => $in, in => undef }
 228   }
 229   ok(!$weak, "hash referenced weakened SV released");
 230 }
 231
 232 # prototype() errors
 233 leak(2,0, sub { eval { prototype "CORE::fu" } }, 'prototype errors');
 234
 235 # RT #72246: rcatline memory leak on bad $/
 236
 237 leak(2, 0,
 238     sub {
 239         my $f;
 240         open CATLINE, '<', \$f;
 241         local $/ = "\x{262E}";
 242         my $str = "\x{2622}";
 243         eval { $str .= <CATLINE> };
 244     },
 245     "rcatline leak"
 246 );
 247
 248 {
 249     my $RE = qr/
 250       (?:
 251         <(?<tag>
 252           \s*
 253           [^>\s]+
 254         )>
 255       )??
 256     /xis;
 257
 258     "<html><body></body></html>" =~ m/$RE/gcs;
 259
 260     leak(5, 0, sub {
 261         my $tag = $+{tag};
 262     }, "named regexp captures");
 263 }
 264
 265 eleak(2,0,'/[:]/');
 266 eleak(2,0,'/[\xdf]/i');
 267 eleak(2,0,'s![^/]!!');
 268 eleak(2,0,'/[pp]/');
 269 eleak(2,0,'/[[:ascii:]]/');
 270 eleak(2,0,'/[[.zog.]]/');
 271 eleak(2,0,'/[.zog.]/');
 272 eleak(2,0,'/|\W/', '/|\W/ [perl #123198]');
 273 eleak(2,0,'no warnings; /(?[])/');
 274 eleak(2,0,'no warnings; /(?[[a]+[b]])/');
 275 eleak(2,0,'no warnings; /(?[[a]-[b]])/');
 276 eleak(2,0,'no warnings; /(?[[a]&[b]])/');
 277 eleak(2,0,'no warnings; /(?[[a]|[b]])/');
 278 eleak(2,0,'no warnings; /(?[[a]^[b]])/');
 279 eleak(2,0,'no warnings; /(?[![a]])/');
 280 eleak(2,0,'no warnings; /(?[\p{Word}])/');
 281 eleak(2,0,'no warnings; /(?[[a]+)])/');
 282 eleak(2,0,'no warnings; /(?[\d\d)])/');
 283
 284 # These can generate one ref count, but just  once.
 285 eleak(4,1,'chr(0x100) =~ /[[:punct:]]/');
 286 eleak(4,1,'chr(0x100) =~ /[[:^punct:]]/');
 287 eleak(4,1,'chr(0x100) =~ /[[:word:]]/');
 288 eleak(4,1,'chr(0x100) =~ /[[:^word:]]/');
 289
 290 eleak(2,0,'chr(0x100) =~ /\P{Assigned}/');
 291 leak(2,0,sub { /(??{})/ }, '/(??{})/');
 292
 293 leak(2,0,sub { !$^V }, '[perl #109762] version object in boolean context');
 294
 295
 296 # [perl #114356] run-time rexexp with unchanging pattern got
 297 # inflated refcounts
 298 eleak(2, 0, q{ my $x = "x"; "abc" =~ /$x/ for 1..5 }, '#114356');
 299
 300 eleak(2, 0, 'sub', '"sub" with nothing following');
 301 eleak(2, 0, '+sub:a{}', 'anon subs with invalid attributes');
 302 eleak(2, 0, 'no warnings; sub a{1 1}', 'sub with syntax error');
 303 eleak(2, 0, 'no warnings; sub {1 1}', 'anon sub with syntax error');
 304 eleak(2, 0, 'no warnings; use feature ":all"; my sub a{1 1}',
 305      'my sub with syntax error');
 306
 307 # Reification (or lack thereof)
 308 leak(2, 0, sub { sub { local $_[0]; shift }->(1) },
 309     'local $_[0] on surreal @_, followed by shift');
 310 leak(2, 0, sub { sub { local $_[0]; \@_ }->(1) },
 311     'local $_[0] on surreal @_, followed by reification');
 312
 313 sub recredef {}
 314 sub Recursive::Redefinition::DESTROY {
 315     *recredef = sub { CORE::state $x } # state makes it cloneable
 316 }
 317 leak(2, 0, sub {
 318     bless \&recredef, "Recursive::Redefinition"; eval "sub recredef{}"
 319 }, 'recursive sub redefinition');
 320
 321 # Syntax errors
 322 eleak(2, 0, '"${<<END}"
 323                  ', 'unterminated here-doc in quotes in multiline eval');
 324 eleak(2, 0, '"${<<END
 325                }"', 'unterminated here-doc in multiline quotes in eval');
 326 leak(2, 0, sub { eval { do './op/svleak.pl' } },
 327         'unterminated here-doc in file');
 328 eleak(2, 0, 'tr/9-0//');
 329 eleak(2, 0, 'tr/a-z-0//');
 330 eleak(2, 0, 'no warnings; nonexistent_function 33838',
 331         'bareword followed by number');
 332 eleak(2, 0, '//dd;'x20, '"too many errors" when parsing m// flags');
 333 eleak(2, 0, 's///dd;'x20, '"too many errors" when parsing s/// flags');
 334 eleak(2, 0, 'no warnings; 2 2;BEGIN{}',
 335       'BEGIN block after syntax error');
 336 {
 337     local %INC; # in case Errno is already loaded
 338     eleak(2, 0, 'no warnings; 2@!{',
 339                 'implicit "use Errno" after syntax error');
 340 }
 341 eleak(2, 0, "\"\$\0\356\"", 'qq containing $ <null> something');
 342 eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words');
 343 eleak(2, 0, "+ + +;qq|\\N{a}|"x10,'qq"\N{a}" after errors');
 344 eleak(2, 0, "qq|\\N{%}|",      'qq"\N{%}" (invalid charname)');
 345 eleak(2, 0, "qq|\\N{au}|;",    'qq"\N{invalid}"');
 346 eleak(2, 0, "qq|\\c|;"x10,     '"too many errors" from qq"\c"');
 347 eleak(2, 0, "qq|\\o|;"x10,     '"too many errors" from qq"\o"');
 348 eleak(2, 0, "qq|\\x{|;"x10,    '"too many errors" from qq"\x{"');
 349 eleak(2, 0, "qq|\\N|;"x10,     '"too many errors" from qq"\N"');
 350 eleak(2, 0, "qq|\\N{|;"x10,    '"too many errors" from qq"\N{"');
 351 eleak(2, 0, "qq|\\N{U+GETG}|;"x10,'"too many errors" from qq"\N{U+JUNK}"');
 352
 353
 354 # [perl #114764] Attributes leak scalars
 355 leak(2, 0, sub { eval 'my $x : shared' }, 'my $x :shared used to leak');
 356
 357 eleak(2, 0, 'ref: 1', 'labels');
 358
 359 # Tied hash iteration was leaking if the hash was freed before itera-
 360 # tion was over.
 361 package t {
 362     sub TIEHASH { bless [] }
 363     sub FIRSTKEY { 0 }
 364 }
 365 leak(2, 0, sub {
 366     my $h = {};
 367     tie %$h, t;
 368     each %$h;
 369     undef $h;
 370 }, 'tied hash iteration does not leak');
 371
 372 package explosive_scalar {
 373     sub TIESCALAR { my $self = shift; bless [undef, {@_}], $self  }
 374     sub FETCH     { die 'FETCH' if $_[0][1]{FETCH}; $_[0][0] }
 375     sub STORE     { die 'STORE' if $_[0][1]{STORE}; $_[0][0] = $_[1] }
 376 }
 377 tie my $die_on_fetch, 'explosive_scalar', FETCH => 1;
 378
 379 # List assignment was leaking when assigning explosive scalars to
 380 # aggregates.
 381 leak(2, 0, sub {
 382     eval {%a = ($die_on_fetch, 0)}; # key
 383     eval {%a = (0, $die_on_fetch)}; # value
 384     eval {%a = ($die_on_fetch, $die_on_fetch)}; # both
 385     eval {%a = ($die_on_fetch)}; # key, odd elements
 386 }, 'hash assignment does not leak');
 387 leak(2, 0, sub {
 388     eval {@a = ($die_on_fetch)};
 389     eval {($die_on_fetch, $b) = ($b, $die_on_fetch)};
 390     # restore
 391     tie $die_on_fetch, 'explosive_scalar', FETCH => 1;
 392 }, 'array assignment does not leak');
 393
 394 # [perl #107000]
 395 package hhtie {
 396     sub TIEHASH { bless [] }
 397     sub STORE    { $_[0][0]{$_[1]} = $_[2] }
 398     sub FETCH    { die if $explosive; $_[0][0]{$_[1]} }
 399     sub FIRSTKEY { keys %{$_[0][0]}; each %{$_[0][0]} }
 400     sub NEXTKEY  { each %{$_[0][0]} }
 401 }
 402 leak(2, 0, sub {
 403     eval q`
 404         BEGIN {
 405             $hhtie::explosive = 0;
 406             tie %^H, hhtie;
 407             $^H{foo} = bar;
 408             $hhtie::explosive = 1;
 409         }
 410         { 1; }
 411     `;
 412 }, 'hint-hash copying does not leak');
 413
 414 package explosive_array {
 415     sub TIEARRAY  { bless [[], {}], $_[0]  }
 416     sub FETCH     { die if $_[0]->[1]{FETCH}; $_[0]->[0][$_[1]]  }
 417     sub FETCHSIZE { die if $_[0]->[1]{FETCHSIZE}; scalar @{ $_[0]->[0]  }  }
 418     sub STORE     { die if $_[0]->[1]{STORE}; $_[0]->[0][$_[1]] = $_[2]  }
 419     sub CLEAR     { die if $_[0]->[1]{CLEAR}; @{$_[0]->[0]} = ()  }
 420     sub EXTEND    { die if $_[0]->[1]{EXTEND}; return  }
 421     sub explode   { my $self = shift; $self->[1] = {@_} }
 422 }
 423
 424 leak(2, 0, sub {
 425     tie my @a, 'explosive_array';
 426     tied(@a)->explode( STORE => 1 );
 427     my $x = 0;
 428     eval { @a = ($x)  };
 429 }, 'explosive array assignment does not leak');
 430
 431 leak(2, 0, sub {
 432     my ($a, $b);
 433     eval { warn $die_on_fetch };
 434 }, 'explosive warn argument');
 435
 436 leak(2, 0, sub {
 437     my $foo = sub { return $die_on_fetch };
 438     my $res = eval { $foo->() };
 439     my @res = eval { $foo->() };
 440 }, 'function returning explosive does not leak');
 441
 442 leak(2, 0, sub {
 443     my $res = eval { {$die_on_fetch, 0} };
 444     $res = eval { {0, $die_on_fetch} };
 445 }, 'building anon hash with explosives does not leak');
 446
 447 leak(2, 0, sub {
 448     my $res = eval { [$die_on_fetch] };
 449 }, 'building anon array with explosives does not leak');
 450
 451 leak(2, 0, sub {
 452     my @a;
 453     eval { push @a, $die_on_fetch };
 454 }, 'pushing exploding scalar does not leak');
 455
 456 leak(2, 0, sub {
 457     eval { push @-, '' };
 458 }, 'pushing onto read-only array does not leak');
 459
 460
 461 # Run-time regexp code blocks
 462 {
 463     use re 'eval';
 464     my @tests = ('[(?{})]','(?{})');
 465     for my $t (@tests) {
 466         leak(2, 0, sub {
 467             / $t/;
 468         }, "/ \$x/ where \$x is $t does not leak");
 469         leak(2, 0, sub {
 470             /(?{})$t/;
 471         }, "/(?{})\$x/ where \$x is $t does not leak");
 472     }
 473 }
 474
 475
 476 {
 477     use warnings FATAL => 'all';
 478     leak(2, 0, sub {
 479         no warnings 'once';
 480         eval { printf uNopened 42 };
 481     }, 'printfing to bad handle under fatal warnings does not leak');
 482     open my $fh, ">", \my $buf;
 483     leak(2, 0, sub {
 484         eval { printf $fh chr 2455 };
 485     }, 'wide fatal warning does not make printf leak');
 486     close $fh or die $!;
 487 }
 488
 489
 490 leak(2,0,sub{eval{require untohunothu}}, 'requiring nonexistent module');
 491
 492 # [perl #120939]
 493 use constant const_av_xsub_leaked => 1 .. 3;
 494 leak(5, 0, sub { scalar &const_av_xsub_leaked }, "const_av_sub in scalar context");
 495
 496 # check that OP_MULTIDEREF doesn't leak when compiled and then freed
 497
 498 eleak(2, 0, <<'EOF', 'OP_MULTIDEREF');
 499 no strict;
 500 no warnings;
 501 my ($x, @a, %h, $r, $k, $i);
 502 $x = $a[0]{foo}{$k}{$i};
 503 $x = $h[0]{foo}{$k}{$i};
 504 $x = $r->[0]{foo}{$k}{$i};
 505 $x = $mdr::a[0]{foo}{$mdr::k}{$mdr::i};
 506 $x = $mdr::h[0]{foo}{$mdr::k}{$mdr::i};
 507 $x = $mdr::r->[0]{foo}{$mdr::k}{$mdr::i};
 508 EOF
 509
 510 # un-localizing a tied (or generally magic) item could leak if the things
 511 # called by mg_set() died
 512
 513 {
 514     package MG_SET;
 515
 516     sub TIESCALAR {  bless [] }
 517     sub FETCH { 1; }
 518     my $do_die = 0;
 519     sub STORE { die if $do_die; }
 520
 521     sub f {
 522         local $s;
 523         tie $s, 'MG_SET';
 524         local $s;
 525         $do_die = 1;
 526     }
 527     sub g {
 528         eval { my $x = f(); };
 529     }
 530
 531     ::leak(5,0, \&g, "MG_SET");
 532 }
 533
 534 # check that @_ isn't leaked when dieing while goto'ing a new sub
 535
 536 {
 537     package my_goto;
 538     sub TIEARRAY { bless [] }
 539     sub FETCH { 1 }
 540     sub STORE { die if $_[0][0]; $_[0][0] = 1 }
 541
 542     sub f { eval { g() } }
 543     sub g {
 544         my @a;
 545         tie @a, "my_goto";
 546         local $a[0];
 547         goto &h;
 548     }
 549     sub h {}
 550
 551     ::leak(5, 0, \&f, q{goto shouldn't leak @_});
 552 }
 553
 554 # [perl #128313] POSIX warnings shouldn't leak
 555 {
 556     no warnings 'experimental';
 557     use re 'strict';
 558     my $a = 'aaa';
 559     my $b = 'aa';
 560     sub f { $a =~ /[^.]+$b/; }
 561     ::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings});
 562 }
 563
 564 # check that B::RHE->HASH does not leak
 565 {
 566     package BHINT;
 567     sub foo {}
 568     require B;
 569     my $op = B::svref_2object(\&foo)->ROOT->first;
 570     sub lk { { my $d = $op->hints_hash->HASH } }
 571     ::leak(3, 0, \&lk, q!B::RHE->HASH shoudln't leak!);
 572 }
 573
 574
 575 # dying while compiling a regex with codeblocks imported from an embedded
 576 # qr// could leak
 577
 578 {
 579     my sub codeblocks {
 580         my $r = qr/(?{ 1; })/;
 581         my $c = '(?{ 2; })';
 582         eval { /$r$c/ }
 583     }
 584     ::leak(2, 0, \&codeblocks, q{leaking embedded qr codeblocks});
 585 }
 586
 587 {
 588     # Perl_reg_named_buff_fetch() leaks an AV when called with an RE
 589     # with no named captures
 590     sub named {
 591         "x" =~ /x/;
 592         re::regname("foo", 1);
 593     }
 594     ::leak(2, 0, \&named, "Perl_reg_named_buff_fetch() on no-name RE");
 595 }
 596
 597 {
 598     sub N_leak { eval 'tr//\N{}-0/' }
 599     ::leak(2, 0, \&N_leak, "a bad \\N{} in a range leaks");
 600 }
 601
 602 leak 2,0,\&XS::APItest::PerlIO_stderr,'T_INOUT in default typemap';
 603 leak 2,0,\&XS::APItest::PerlIO_stdin, 'T_IN in default typemap';
 604 leak 2,0,\&XS::APItest::PerlIO_stdout,'T_OUT in default typemap';
 605 SKIP: {
 606  skip "for now; crashes";
 607  leak 2,1,sub{XS::APItest::PerlIO_exportFILE(*STDIN,"");0},
 608                                       'T_STDIO in default typemap';
 609 }