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';
   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 plan tests => 19;
  17
  18 # run some code N times. If the number of SVs at the end of loop N is
  19 # greater than (N-1)*delta at the end of loop 1, we've got a leak
  20 #
  21 sub leak {
  22     my ($n, $delta, $code, @rest) = @_;
  23     my $sv0 = 0;
  24     my $sv1 = 0;
  25     for my $i (1..$n) {
  26         &$code();
  27         $sv1 = sv_count();
  28         $sv0 = $sv1 if $i == 1;
  29     }
  30     cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest);
  31 }
  32
  33 # run some expression N times. The expr is concatenated N times and then
  34 # evaled, ensuring that that there are no scope exits between executions.
  35 # If the number of SVs at the end of expr N is greater than (N-1)*delta at
  36 # the end of expr 1, we've got a leak
  37 #
  38 sub leak_expr {
  39     my ($n, $delta, $expr, @rest) = @_;
  40     my $sv0 = 0;
  41     my $sv1 = 0;
  42     my $true = 1; # avoid stuff being optimised away
  43     my $code1 = "($expr || \$true)";
  44     my $code = "$code1 && (\$sv0 = sv_count())" . ("&& $code1" x 4)
  45                 . " && (\$sv1 = sv_count())";
  46     if (eval $code) {
  47         cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest);
  48     }
  49     else {
  50         fail("eval @rest: $@");
  51     }
  52 }
  53
  54
  55 my @a;
  56
  57 leak(5, 0, sub {},                 "basic check 1 of leak test infrastructure");
  58 leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure");
  59 leak(5, 1, sub {push @a,1;},       "basic check 3 of leak test infrastructure");
  60
  61 sub TIEARRAY    { bless [], $_[0] }
  62 sub FETCH       { $_[0]->[$_[1]] }
  63 sub STORE       { $_[0]->[$_[1]] = $_[2] }
  64
  65 # local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>"
  66 {
  67     tie my @a, 'main';
  68     leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
  69 }
  70
  71 # [perl #74484]  repeated tries leaked SVs on the tmps stack
  72
  73 leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak");
  74
  75 # [perl #48004] map/grep didn't free tmps till the end
  76
  77 {
  78     # qr/1/ just creates tmps that are hopefully freed per iteration
  79
  80     my $s;
  81     my @a;
  82     my @count = (0) x 4; # pre-allocate
  83
  84     grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
  85     is(@count[3] - @count[0], 0, "void   grep expr:  no new tmps per iter");
  86     grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
  87     is(@count[3] - @count[0], 0, "void   grep block: no new tmps per iter");
  88
  89     $s = grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
  90     is(@count[3] - @count[0], 0, "scalar grep expr:  no new tmps per iter");
  91     $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
  92     is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter");
  93
  94     @a = grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
  95     is(@count[3] - @count[0], 0, "list   grep expr:  no new tmps per iter");
  96     @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
  97     is(@count[3] - @count[0], 0, "list   grep block: no new tmps per iter");
  98
  99
 100     map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
 101     is(@count[3] - @count[0], 0, "void   map expr:  no new tmps per iter");
 102     map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
 103     is(@count[3] - @count[0], 0, "void   map block: no new tmps per iter");
 104
 105     $s = map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
 106     is(@count[3] - @count[0], 0, "scalar map expr:  no new tmps per iter");
 107     $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
 108     is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter");
 109
 110     @a = map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
 111     is(@count[3] - @count[0], 3, "list   map expr:  one new tmp per iter");
 112     @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
 113     is(@count[3] - @count[0], 3, "list   map block: one new tmp per iter");
 114
 115 }
 116
 117 SKIP:
 118 { # broken by 304474c3, fixed by cefd5c7c, but didn't seem to cause
 119   # any other test failures
 120   # base test case from ribasushi (Peter Rabbitson)
 121   eval { require Scalar::Util; Scalar::Util->import("weaken"); 1; }
 122     or skip "no weaken", 1;
 123   my $weak;
 124   {
 125     $weak = my $in = {};
 126     weaken($weak);
 127     my $out = { in => $in, in => undef }
 128   }
 129   ok(!$weak, "hash referenced weakened SV released");
 130 }
 131
 132 # RT #72246: rcatline memory leak on bad $/
 133
 134 leak(2, 0,
 135     sub {
 136         my $f;
 137         open CATLINE, '<', \$f;
 138         local $/ = "\x{262E}";
 139         my $str = "\x{2622}";
 140         eval { $str .= <CATLINE> };
 141     },
 142     "rcatline leak"
 143 );