Commit | Line | Data |
---|---|---|
d97c33b5 DM |
1 | #!./perl |
2 | ||
3 | # A place to put some simple leak tests. Uses XS::APItest to make | |
64dc9714 | 4 | # PL_sv_count available, allowing us to run a bit of code multiple times and |
d97c33b5 DM |
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 | ||
64dc9714 | 16 | plan tests => 19; |
d97c33b5 DM |
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 | ||
8bd05d90 DM |
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 | ||
d97c33b5 DM |
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"); | |
459defa1 DM |
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 | ||
8bd05d90 DM |
71 | # [perl #74484] repeated tries leaked SVs on the tmps stack |
72 | ||
2e64971a | 73 | leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak"); |
b2a2a901 DM |
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 | } | |
a50d6ed0 TC |
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 | } | |
64dc9714 DM |
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 | ); |