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 a 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 => 5;
  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");