This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
717d5a1957435b231bc1954d78c0cd07984d972d
[perl5.git] / 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 => 18;
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 }