This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
remove an EXTEND from XS_re_regexp_pattern
[perl5.git] / t / op / svleak.t
CommitLineData
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
7BEGIN {
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
ef09a500
DM
16use Config;
17
4aca0fe6 18plan tests => 77;
d97c33b5
DM
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#
23sub 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
1cac5c33
FC
35# Like leak, but run a string eval instead.
36# The code is used instead of the test name
2e880be7
FC
37# if the name is absent.
38sub eleak {
39 my ($n,$delta,$code,@rest) = @_;
1cac5c33 40 leak $n, $delta, sub { eval $code },
2e880be7
FC
41 @rest ? @rest : $code
42}
43
8bd05d90
DM
44# run some expression N times. The expr is concatenated N times and then
45# evaled, ensuring that that there are no scope exits between executions.
46# If the number of SVs at the end of expr N is greater than (N-1)*delta at
47# the end of expr 1, we've got a leak
48#
49sub leak_expr {
50 my ($n, $delta, $expr, @rest) = @_;
51 my $sv0 = 0;
52 my $sv1 = 0;
53 my $true = 1; # avoid stuff being optimised away
54 my $code1 = "($expr || \$true)";
55 my $code = "$code1 && (\$sv0 = sv_count())" . ("&& $code1" x 4)
56 . " && (\$sv1 = sv_count())";
57 if (eval $code) {
58 cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, @rest);
59 }
60 else {
61 fail("eval @rest: $@");
62 }
63}
64
65
d97c33b5
DM
66my @a;
67
68leak(5, 0, sub {}, "basic check 1 of leak test infrastructure");
69leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure");
70leak(5, 1, sub {push @a,1;}, "basic check 3 of leak test infrastructure");
459defa1 71
e88567f2
FC
72eleak(2, 0, 'sub{<*>}');
73
110af908
FC
74eleak(2, 0, 'goto sub {}', 'goto &sub in eval');
75eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort');
76eleak(2, 0, '/(?{ goto sub {} })/', 'goto &sub in regexp');
77
459defa1
DM
78sub TIEARRAY { bless [], $_[0] }
79sub FETCH { $_[0]->[$_[1]] }
80sub STORE { $_[0]->[$_[1]] = $_[2] }
81
82# local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>"
83{
84 tie my @a, 'main';
85 leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
86}
87
8bd05d90
DM
88# [perl #74484] repeated tries leaked SVs on the tmps stack
89
2e64971a 90leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak");
b2a2a901
DM
91
92# [perl #48004] map/grep didn't free tmps till the end
93
94{
95 # qr/1/ just creates tmps that are hopefully freed per iteration
96
97 my $s;
98 my @a;
99 my @count = (0) x 4; # pre-allocate
100
101 grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
102 is(@count[3] - @count[0], 0, "void grep expr: no new tmps per iter");
103 grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
104 is(@count[3] - @count[0], 0, "void grep block: no new tmps per iter");
105
106 $s = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
107 is(@count[3] - @count[0], 0, "scalar grep expr: no new tmps per iter");
108 $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
109 is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter");
110
111 @a = grep qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
112 is(@count[3] - @count[0], 0, "list grep expr: no new tmps per iter");
113 @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
114 is(@count[3] - @count[0], 0, "list grep block: no new tmps per iter");
115
116
117 map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
118 is(@count[3] - @count[0], 0, "void map expr: no new tmps per iter");
119 map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
120 is(@count[3] - @count[0], 0, "void map block: no new tmps per iter");
121
122 $s = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
123 is(@count[3] - @count[0], 0, "scalar map expr: no new tmps per iter");
124 $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
125 is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter");
126
127 @a = map qr/1/ && ($count[$_] = sv_count()) && 99, 0..3;
128 is(@count[3] - @count[0], 3, "list map expr: one new tmp per iter");
129 @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 } 0..3;
130 is(@count[3] - @count[0], 3, "list map block: one new tmp per iter");
131
132}
a50d6ed0
TC
133
134SKIP:
135{ # broken by 304474c3, fixed by cefd5c7c, but didn't seem to cause
136 # any other test failures
137 # base test case from ribasushi (Peter Rabbitson)
138 eval { require Scalar::Util; Scalar::Util->import("weaken"); 1; }
139 or skip "no weaken", 1;
140 my $weak;
141 {
142 $weak = my $in = {};
143 weaken($weak);
144 my $out = { in => $in, in => undef }
145 }
146 ok(!$weak, "hash referenced weakened SV released");
147}
64dc9714 148
c9af70d5
FC
149# prototype() errors
150leak(2,0, sub { eval { prototype "CORE::fu" } }, 'prototype errors');
151
64dc9714
DM
152# RT #72246: rcatline memory leak on bad $/
153
154leak(2, 0,
155 sub {
156 my $f;
157 open CATLINE, '<', \$f;
158 local $/ = "\x{262E}";
159 my $str = "\x{2622}";
160 eval { $str .= <CATLINE> };
161 },
162 "rcatline leak"
163);
a17b8556
JP
164
165{
166 my $RE = qr/
167 (?:
168 <(?<tag>
169 \s*
170 [^>\s]+
171 )>
172 )??
173 /xis;
174
175 "<html><body></body></html>" =~ m/$RE/gcs;
176
177 leak(5, 0, sub {
178 my $tag = $+{tag};
179 }, "named regexp captures");
180}
bcb2959f 181
2e880be7
FC
182eleak(2,0,'/[:]/');
183eleak(2,0,'/[\xdf]/i');
f248b511 184eleak(2,0,'s![^/]!!');
3451022d
FC
185eleak(2,0,'/[pp]/');
186eleak(2,0,'/[[:ascii:]]/');
e5fcdda9
FC
187eleak(2,0,'/[[.zog.]]/');
188eleak(2,0,'/[.zog.]/');
02c85471
FC
189eleak(2,0,'chr(0x100) =~ /[[:punct:]]/');
190eleak(2,0,'chr(0x100) =~ /[[:^punct:]]/');
4aca0fe6 191eleak(2,0,'chr(0x100) =~ /\P{Assigned}/');
e1ff3a88 192leak(2,0,sub { /(??{})/ }, '/(??{})/');
2e880be7 193
bcb2959f 194leak(2,0,sub { !$^V }, '[perl #109762] version object in boolean context');
d97935e0
DM
195
196
197# [perl #114356] run-time rexexp with unchanging pattern got
198# inflated refcounts
1cac5c33 199eleak(2, 0, q{ my $x = "x"; "abc" =~ /$x/ for 1..5 }, '#114356');
d97935e0 200
1cac5c33 201eleak(2, 0, 'sub', '"sub" with nothing following');
12d3c230 202eleak(2, 0, '+sub:a{}', 'anon subs with invalid attributes');
9ffcdca1 203eleak(2, 0, 'no warnings; sub a{1 1}', 'sub with syntax error');
4d2dfd15 204eleak(2, 0, 'no warnings; sub {1 1}', 'anon sub with syntax error');
8ca8859f
FC
205eleak(2, 0, 'no warnings; use feature ":all"; my sub a{1 1}',
206 'my sub with syntax error');
12d3c230 207
1cdc9186
FC
208# Reification (or lack thereof)
209leak(2, 0, sub { sub { local $_[0]; shift }->(1) },
210 'local $_[0] on surreal @_, followed by shift');
211leak(2, 0, sub { sub { local $_[0]; \@_ }->(1) },
212 'local $_[0] on surreal @_, followed by reification');
213
47c8e7fe
FC
214# Syntax errors
215eleak(2, 0, '"${<<END}"
216 ', 'unterminated here-doc in quotes in multiline eval');
217eleak(2, 0, '"${<<END
218 }"', 'unterminated here-doc in multiline quotes in eval');
1cac5c33 219leak(2, 0, sub { eval { do './op/svleak.pl' } },
2d85e411 220 'unterminated here-doc in file');
47c8e7fe
FC
221eleak(2, 0, 'tr/9-0//');
222eleak(2, 0, 'tr/a-z-0//');
223eleak(2, 0, 'no warnings; nonexistent_function 33838',
a577af66 224 'bareword followed by number');
10002bc1
FC
225eleak(2, 0, '//dd;'x20, '"too many errors" when parsing m// flags');
226eleak(2, 0, 's///dd;'x20, '"too many errors" when parsing s/// flags');
1cac5c33 227eleak(2, 0, 'no warnings; 2 2;BEGIN{}',
9eb48717 228 'BEGIN block after syntax error');
600beb2e
FC
229{
230 local %INC; # in case Errno is already loaded
231 eleak(2, 0, 'no warnings; 2@!{',
232 'implicit "use Errno" after syntax error');
233}
3ce3dcd9 234eleak(2, 0, "\"\$\0\356\"", 'qq containing $ <null> something');
3ac7ff8f 235eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words');
9e942bf5 236
9fa29fa7
FC
237
238# [perl #114764] Attributes leak scalars
239leak(2, 0, sub { eval 'my $x : shared' }, 'my $x :shared used to leak');
895cdc83 240
c25611d5
FC
241eleak(2, 0, 'ref: 1', 'labels');
242
895cdc83
FC
243# Tied hash iteration was leaking if the hash was freed before itera-
244# tion was over.
245package t {
246 sub TIEHASH { bless [] }
247 sub FIRSTKEY { 0 }
248}
249leak(2, 0, sub {
250 my $h = {};
251 tie %$h, t;
252 each %$h;
253 undef $h;
254}, 'tied hash iteration does not leak');
9c744f4f 255
33b889b0
RZ
256package explosive_scalar {
257 sub TIESCALAR { my $self = shift; bless [undef, {@_}], $self }
258 sub FETCH { die 'FETCH' if $_[0][1]{FETCH}; $_[0][0] }
259 sub STORE { die 'STORE' if $_[0][1]{STORE}; $_[0][0] = $_[1] }
260}
261tie my $die_on_fetch, 'explosive_scalar', FETCH => 1;
262
39984de3
FC
263# List assignment was leaking when assigning explosive scalars to
264# aggregates.
9c744f4f 265leak(2, 0, sub {
33b889b0
RZ
266 eval {%a = ($die_on_fetch, 0)}; # key
267 eval {%a = (0, $die_on_fetch)}; # value
268 eval {%a = ($die_on_fetch, $die_on_fetch)}; # both
9c744f4f 269}, 'hash assignment does not leak');
39984de3 270leak(2, 0, sub {
33b889b0
RZ
271 eval {@a = ($die_on_fetch)};
272 eval {($die_on_fetch, $b) = ($b, $die_on_fetch)};
273 # restore
274 tie $die_on_fetch, 'explosive_scalar', FETCH => 1;
39984de3 275}, 'array assignment does not leak');
9c744f4f 276
0db511c0
FC
277# [perl #107000]
278package hhtie {
279 sub TIEHASH { bless [] }
280 sub STORE { $_[0][0]{$_[1]} = $_[2] }
281 sub FETCH { die if $explosive; $_[0][0]{$_[1]} }
282 sub FIRSTKEY { keys %{$_[0][0]}; each %{$_[0][0]} }
283 sub NEXTKEY { each %{$_[0][0]} }
284}
1cac5c33 285leak(2, 0, sub {
0db511c0
FC
286 eval q`
287 BEGIN {
288 $hhtie::explosive = 0;
289 tie %^H, hhtie;
290 $^H{foo} = bar;
291 $hhtie::explosive = 1;
292 }
293 { 1; }
294 `;
295}, 'hint-hash copying does not leak');
33b889b0
RZ
296
297package explosive_array {
298 sub TIEARRAY { bless [[], {}], $_[0] }
299 sub FETCH { die if $_[0]->[1]{FETCH}; $_[0]->[0][$_[1]] }
300 sub FETCHSIZE { die if $_[0]->[1]{FETCHSIZE}; scalar @{ $_[0]->[0] } }
301 sub STORE { die if $_[0]->[1]{STORE}; $_[0]->[0][$_[1]] = $_[2] }
302 sub CLEAR { die if $_[0]->[1]{CLEAR}; @{$_[0]->[0]} = () }
303 sub EXTEND { die if $_[0]->[1]{EXTEND}; return }
304 sub explode { my $self = shift; $self->[1] = {@_} }
305}
306
307leak(2, 0, sub {
308 tie my @a, 'explosive_array';
309 tied(@a)->explode( STORE => 1 );
310 my $x = 0;
311 eval { @a = ($x) };
312}, 'explosive array assignment does not leak');
313
314leak(2, 0, sub {
315 my ($a, $b);
316 eval { warn $die_on_fetch };
317}, 'explosive warn argument');
318
319leak(2, 0, sub {
320 my $foo = sub { return $die_on_fetch };
321 my $res = eval { $foo->() };
322 my @res = eval { $foo->() };
323}, 'function returning explosive does not leak');
324
325leak(2, 0, sub {
326 my $res = eval { {$die_on_fetch, 0} };
327 $res = eval { {0, $die_on_fetch} };
328}, 'building anon hash with explosives does not leak');
329
330leak(2, 0, sub {
3ed356df
FC
331 my $res = eval { [$die_on_fetch] };
332}, 'building anon array with explosives does not leak');
333
334leak(2, 0, sub {
33b889b0
RZ
335 my @a;
336 eval { push @a, $die_on_fetch };
337}, 'pushing exploding scalar does not leak');
ddac780e 338
644ac3a8
FC
339leak(2, 0, sub {
340 eval { push @-, '' };
341}, 'pushing onto read-only array does not leak');
342
ddac780e
FC
343
344# Run-time regexp code blocks
345{
2ac13048
FC
346 use re 'eval';
347 my @tests = ('[(?{})]','(?{})');
ddac780e 348 for my $t (@tests) {
1cac5c33 349 leak(2, 0, sub {
ddac780e
FC
350 / $t/;
351 }, "/ \$x/ where \$x is $t does not leak");
1cac5c33 352 leak(2, 0, sub {
ddac780e
FC
353 /(?{})$t/;
354 }, "/(?{})\$x/ where \$x is $t does not leak");
355 }
356}
104c40b0
FC
357
358
359{
360 use warnings FATAL => 'all';
361 leak(2, 0, sub {
d861347e 362 no warnings 'once';
104c40b0
FC
363 eval { printf uNopened 42 };
364 }, 'printfing to bad handle under fatal warnings does not leak');
c7bd8b84
FC
365 open my $fh, ">", \my $buf;
366 leak(2, 0, sub {
367 eval { printf $fh chr 2455 };
368 }, 'wide fatal warning does not make printf leak');
369 close $fh or die $!;
104c40b0 370}
1e5f02b3
FC
371
372
373leak(2,0,sub{eval{require untohunothu}}, 'requiring nonexistent module');