This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8134b56293f47f3bfc95b0e04e7857d56da11de7
[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 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 use Config;
17
18 plan tests => 64;
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; takes into account existing
36 # string eval leaks under -Dmad (except when -Dmad leaks two or
37 # more SVs). The code is used instead of the test name
38 # if the name is absent.
39 sub eleak {
40     my ($n,$delta,$code,@rest) = @_;
41     leak $n, $delta + !!$Config{mad}, 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 eleak(2, 0, 'sub{<*>}');
74
75 eleak(2, 0, 'goto sub {}', 'goto &sub in eval');
76 eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort');
77 eleak(2, 0, '/(?{ goto sub {} })/', 'goto &sub in regexp');
78
79 sub TIEARRAY    { bless [], $_[0] }
80 sub FETCH       { $_[0]->[$_[1]] }
81 sub STORE       { $_[0]->[$_[1]] = $_[2] }
82
83 # local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>"
84 {
85     tie my @a, 'main';
86     leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
87 }
88
89 # [perl #74484]  repeated tries leaked SVs on the tmps stack
90
91 leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak");
92
93 # [perl #48004] map/grep didn't free tmps till the end
94
95 {
96     # qr/1/ just creates tmps that are hopefully freed per iteration
97
98     my $s;
99     my @a;
100     my @count = (0) x 4; # pre-allocate
101
102     grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
103     is(@count[3] - @count[0], 0, "void   grep expr:  no new tmps per iter");
104     grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
105     is(@count[3] - @count[0], 0, "void   grep block: no new tmps per iter");
106
107     $s = grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
108     is(@count[3] - @count[0], 0, "scalar grep expr:  no new tmps per iter");
109     $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
110     is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter");
111
112     @a = grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
113     is(@count[3] - @count[0], 0, "list   grep expr:  no new tmps per iter");
114     @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
115     is(@count[3] - @count[0], 0, "list   grep block: no new tmps per iter");
116
117
118     map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
119     is(@count[3] - @count[0], 0, "void   map expr:  no new tmps per iter");
120     map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
121     is(@count[3] - @count[0], 0, "void   map block: no new tmps per iter");
122
123     $s = map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
124     is(@count[3] - @count[0], 0, "scalar map expr:  no new tmps per iter");
125     $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
126     is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter");
127
128     @a = map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
129     is(@count[3] - @count[0], 3, "list   map expr:  one new tmp per iter");
130     @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
131     is(@count[3] - @count[0], 3, "list   map block: one new tmp per iter");
132
133 }
134
135 SKIP:
136 { # broken by 304474c3, fixed by cefd5c7c, but didn't seem to cause
137   # any other test failures
138   # base test case from ribasushi (Peter Rabbitson)
139   eval { require Scalar::Util; Scalar::Util->import("weaken"); 1; }
140     or skip "no weaken", 1;
141   my $weak;
142   {
143     $weak = my $in = {};
144     weaken($weak);
145     my $out = { in => $in, in => undef }
146   }
147   ok(!$weak, "hash referenced weakened SV released");
148 }
149
150 # RT #72246: rcatline memory leak on bad $/
151
152 leak(2, 0,
153     sub {
154         my $f;
155         open CATLINE, '<', \$f;
156         local $/ = "\x{262E}";
157         my $str = "\x{2622}";
158         eval { $str .= <CATLINE> };
159     },
160     "rcatline leak"
161 );
162
163 {
164     my $RE = qr/
165       (?:
166         <(?<tag>
167           \s*
168           [^>\s]+
169         )>
170       )??
171     /xis;
172
173     "<html><body></body></html>" =~ m/$RE/gcs;
174
175     leak(5, 0, sub {
176         my $tag = $+{tag};
177     }, "named regexp captures");
178 }
179
180 eleak(2,0,'/[:]/');
181 eleak(2,0,'/[\xdf]/i');
182 eleak(2,0,'s![^/]!!');
183 eleak(2,0,'/[pp]/');
184 eleak(2,0,'/[[:ascii:]]/');
185
186 leak(2,0,sub { !$^V }, '[perl #109762] version object in boolean context');
187
188
189 # [perl #114356] run-time rexexp with unchanging pattern got
190 # inflated refcounts
191
192 SKIP: {
193     skip "disabled under -Dmad (eval leaks)" if $Config{mad};
194     leak(2, 0, sub { eval q{ my $x = "x"; "abc" =~ /$x/ for 1..5 } }, '#114356');
195 }
196
197 eleak(2, 0, '+sub:a{}', 'anon subs with invalid attributes');
198
199 # Syntax errors
200 eleak(2, 0, '"${<<END}"
201                  ', 'unterminated here-doc in quotes in multiline eval');
202 eleak(2, 0, '"${<<END
203                }"', 'unterminated here-doc in multiline quotes in eval');
204 leak(2, !!$Config{mad}, sub { eval { do './op/svleak.pl' } },
205         'unterminated here-doc in file');
206 eleak(2, 0, 'tr/9-0//');
207 eleak(2, 0, 'tr/a-z-0//');
208 eleak(2, 0, 'no warnings; nonexistent_function 33838',
209         'bareword followed by number');
210 eleak(2, 0, '//dd;'x20, '"too many errors" when parsing m// flags');
211 eleak(2, 0, 's///dd;'x20, '"too many errors" when parsing s/// flags');
212 eleak(2, !!$Config{mad}, 'no warnings; 2 2;BEGIN{}',
213       'BEGIN block after syntax error');
214 {
215     local %INC; # in case Errno is already loaded
216     eleak(2, 0, 'no warnings; 2@!{',
217                 'implicit "use Errno" after syntax error');
218 }
219 eleak(2, 0, "\"\$\0\356\"", 'qq containing $ <null> something');
220 {
221     local $::TODO = 'eval "END blah blah" still leaks';
222     eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words');
223 }
224
225
226 # [perl #114764] Attributes leak scalars
227 leak(2, 0, sub { eval 'my $x : shared' }, 'my $x :shared used to leak');
228
229 eleak(2, 0, 'ref: 1', 'labels');
230
231 # Tied hash iteration was leaking if the hash was freed before itera-
232 # tion was over.
233 package t {
234     sub TIEHASH { bless [] }
235     sub FIRSTKEY { 0 }
236 }
237 leak(2, 0, sub {
238     my $h = {};
239     tie %$h, t;
240     each %$h;
241     undef $h;
242 }, 'tied hash iteration does not leak');
243
244 package explosive_scalar {
245     sub TIESCALAR { my $self = shift; bless [undef, {@_}], $self  }
246     sub FETCH     { die 'FETCH' if $_[0][1]{FETCH}; $_[0][0] }
247     sub STORE     { die 'STORE' if $_[0][1]{STORE}; $_[0][0] = $_[1] }
248 }
249 tie my $die_on_fetch, 'explosive_scalar', FETCH => 1;
250
251 # List assignment was leaking when assigning explosive scalars to
252 # aggregates.
253 leak(2, 0, sub {
254     eval {%a = ($die_on_fetch, 0)}; # key
255     eval {%a = (0, $die_on_fetch)}; # value
256     eval {%a = ($die_on_fetch, $die_on_fetch)}; # both
257 }, 'hash assignment does not leak');
258 leak(2, 0, sub {
259     eval {@a = ($die_on_fetch)};
260     eval {($die_on_fetch, $b) = ($b, $die_on_fetch)};
261     # restore
262     tie $die_on_fetch, 'explosive_scalar', FETCH => 1;
263 }, 'array assignment does not leak');
264
265 # [perl #107000]
266 package hhtie {
267     sub TIEHASH { bless [] }
268     sub STORE    { $_[0][0]{$_[1]} = $_[2] }
269     sub FETCH    { die if $explosive; $_[0][0]{$_[1]} }
270     sub FIRSTKEY { keys %{$_[0][0]}; each %{$_[0][0]} }
271     sub NEXTKEY  { each %{$_[0][0]} }
272 }
273 leak(2,!!$Config{mad}, sub {
274     eval q`
275         BEGIN {
276             $hhtie::explosive = 0;
277             tie %^H, hhtie;
278             $^H{foo} = bar;
279             $hhtie::explosive = 1;
280         }
281         { 1; }
282     `;
283 }, 'hint-hash copying does not leak');
284
285 package explosive_array {
286     sub TIEARRAY  { bless [[], {}], $_[0]  }
287     sub FETCH     { die if $_[0]->[1]{FETCH}; $_[0]->[0][$_[1]]  }
288     sub FETCHSIZE { die if $_[0]->[1]{FETCHSIZE}; scalar @{ $_[0]->[0]  }  }
289     sub STORE     { die if $_[0]->[1]{STORE}; $_[0]->[0][$_[1]] = $_[2]  }
290     sub CLEAR     { die if $_[0]->[1]{CLEAR}; @{$_[0]->[0]} = ()  }
291     sub EXTEND    { die if $_[0]->[1]{EXTEND}; return  }
292     sub explode   { my $self = shift; $self->[1] = {@_} }
293 }
294
295 leak(2, 0, sub {
296     tie my @a, 'explosive_array';
297     tied(@a)->explode( STORE => 1 );
298     my $x = 0;
299     eval { @a = ($x)  };
300 }, 'explosive array assignment does not leak');
301
302 leak(2, 0, sub {
303     my ($a, $b);
304     eval { warn $die_on_fetch };
305 }, 'explosive warn argument');
306
307 leak(2, 0, sub {
308     my $foo = sub { return $die_on_fetch };
309     my $res = eval { $foo->() };
310     my @res = eval { $foo->() };
311 }, 'function returning explosive does not leak');
312
313 leak(2, 0, sub {
314     my $res = eval { {$die_on_fetch, 0} };
315     $res = eval { {0, $die_on_fetch} };
316 }, 'building anon hash with explosives does not leak');
317
318 leak(2, 0, sub {
319     my $res = eval { [$die_on_fetch] };
320 }, 'building anon array with explosives does not leak');
321
322 leak(2, 0, sub {
323     my @a;
324     eval { push @a, $die_on_fetch };
325 }, 'pushing exploding scalar does not leak');
326
327 leak(2, 0, sub {
328     eval { push @-, '' };
329 }, 'pushing onto read-only array does not leak');
330
331
332 # Run-time regexp code blocks
333 {
334     use re 'eval';
335     my $madness = !!$Config{mad};
336     my @tests = ('[(?{})]','(?{})');
337     for my $t (@tests) {
338         leak(2, $madness, sub {
339             / $t/;
340         }, "/ \$x/ where \$x is $t does not leak");
341         leak(2, $madness, sub {
342             /(?{})$t/;
343         }, "/(?{})\$x/ where \$x is $t does not leak");
344     }
345 }
346
347
348 {
349     use warnings FATAL => 'all';
350     leak(2, 0, sub {
351         no warnings 'once';
352         eval { printf uNopened 42 };
353     }, 'printfing to bad handle under fatal warnings does not leak');
354     open my $fh, ">", \my $buf;
355     leak(2, 0, sub {
356         eval { printf $fh chr 2455 };
357     }, 'wide fatal warning does not make printf leak');
358     close $fh or die $!;
359 }
360
361
362 leak(2,0,sub{eval{require untohunothu}}, 'requiring nonexistent module');