This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Get reg_eval_scope.t working under minitest
[perl5.git] / t / re / reg_eval_scope.t
CommitLineData
d6faba0b
FC
1#!perl
2
3# Test scoping issues with embedded code in regexps.
4
14f86f07
NC
5BEGIN {
6 chdir 't';
14f86f07 7 require './test.pl';
669c551e
FC
8 @INC = () unless is_miniperl();
9 unshift @INC, qw(lib ../lib);
14f86f07 10}
d6faba0b 11
a453e28a 12plan 48;
d6faba0b 13
daaf7acc
DM
14fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
15 my $x = 7; my $a = 4; my $b = 5;
16 print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })a/;
17 print $x,$a,$b;
d6faba0b
FC
18CODE
19
20fresh_perl_is <<'CODE',
21 for my $x("a".."c") {
22 $y = 1;
23 print scalar
24 "abcabc" =~
25 /
26 (
27 a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
28 b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
29 c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
30 ){2}
31 /x;
32 print "$x ";
33 }
34CODE
35 '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ',
36 {},
37 'multiple (?{})s in loop with lexicals';
38
daaf7acc
DM
39fresh_perl_is <<'CODE', '781745', {}, 'run-time re-eval has its own scope';
40 use re qw(eval);
41 my $x = 7; my $a = 4; my $b = 5;
42 my $rest = 'a';
43 print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })$rest/;
44 print $x,$a,$b;
d6faba0b
FC
45CODE
46
daaf7acc 47fresh_perl_is <<'CODE', '178279371047857967101745', {},
d6faba0b
FC
48 use re "eval";
49 my $x = 7; $y = 1;
daaf7acc 50 my $a = 4; my $b = 5;
d6faba0b
FC
51 print scalar
52 "abcabc"
53 =~ ${\'(?x)
54 (
55 a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
56 b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
57 c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
58 ){2}
59 '};
daaf7acc 60 print $x,$a,$b
d6faba0b
FC
61CODE
62 'multiple (?{})s in "foo" =~ $string';
63
daaf7acc 64fresh_perl_is <<'CODE', '178279371047857967101745', {},
d6faba0b
FC
65 use re "eval";
66 my $x = 7; $y = 1;
daaf7acc 67 my $a = 4; my $b = 5;
d6faba0b
FC
68 print scalar
69 "abcabc" =~
70 /${\'
71 (
72 a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
73 b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
74 c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
75 ){2}
76 '}/x;
daaf7acc 77 print $x,$a,$b
d6faba0b
FC
78CODE
79 'multiple (?{})s in "foo" =~ /$string/x';
80
81fresh_perl_is <<'CODE', '123123', {},
82 for my $x(1..3) {
b30fcab9 83 push @regexps, qr/(?{ print $x })a/;
d6faba0b
FC
84 }
85 "a" =~ $_ for @regexps;
86 "ba" =~ /b$_/ for @regexps;
87CODE
88 'qr/(?{})/ is a closure';
89
d6faba0b
FC
90"a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
91is $pack, 'foo', 'qr// inherits package';
92"a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
93is $re, '(?^x:)', 'qr// inherits pragmata';
94
b30fcab9 95$::pack = '';
d6faba0b
FC
96"ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
97is $pack, 'baz', '/text$qr/ inherits package';
98"ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
99is $re, '(?^i:)', '/text$qr/ inherits pragmata';
100
d6faba0b
FC
101{
102 use re 'eval';
103 package bar;
104 "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/;
105}
106is $pack, 'bar', '/$text/ containing (?{}) inherits package';
d6faba0b
FC
107{
108 use re 'eval', "/m";
109 "ba" =~ /${\'(?{ $::re = qr -- })a'}/;
110}
111is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
6c375d8b 112
daaf7acc 113fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
81ed78b2 114my $a=4; my $b=5; eval { "a" =~ /(?{die})a/ }; print $a,$b;
6c375d8b 115CODE
c65895fd 116
81ed78b2
DM
117fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})';
118my $a=4; my $b=5;
119"a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b;
120CODE
c65895fd 121
81ed78b2
DM
122fresh_perl_is <<'CODE',
123 my $a=4; my $b=5;
124 sub f { "a" =~ /(?{print((caller(0))[3], "\n");})a/ };
125 f();
126 print $a,$b;
6c375d8b 127CODE
81ed78b2
DM
128 "main::f\n45",
129 { stderr => 1 }, 'sub f {(?{caller})}';
130
131
132fresh_perl_is <<'CODE',
133 my $a=4; my $b=5;
5fbe8311 134 sub f { print ((caller(0))[3], "-", (caller(1))[3], "-\n") };
81ed78b2
DM
135 "a" =~ /(?{f()})a/;
136 print $a,$b;
6c375d8b 137CODE
5fbe8311 138 "main::f--\n45",
81ed78b2
DM
139 { stderr => 1 }, 'sub f {caller} /(?{f()})/';
140
141
142fresh_perl_is <<'CODE',
143 my $a=4; my $b=5;
144 sub f {
145 "a" =~ /(?{print "X"; return; print "Y"; })a/;
146 print "Z";
147 };
148 f();
149 print $a,$b;
6c375d8b 150CODE
81ed78b2
DM
151 "XZ45",
152 { stderr => 1 }, 'sub f {(?{return})}';
153
154
155fresh_perl_is <<'CODE',
156my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b
157CODE
158 q{Can't "last" outside a loop block at - line 1.},
159 { stderr => 1 }, '(?{last})';
160
161
162fresh_perl_is <<'CODE',
163my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b
164CODE
165 '45',
166 { stderr => 1 }, '(?{for {last}})';
167
c65895fd 168
81ed78b2
DM
169fresh_perl_is <<'CODE',
170for (1) { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
6c375d8b 171CODE
81ed78b2
DM
172 q{Can't "last" outside a loop block at - line 1.},
173 { stderr => 1 }, 'for (1) {(?{last})}';
174
175
176fresh_perl_is <<'CODE',
177my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b
178CODE
179 '45',
180 { stderr => 1 }, 'eval {(?{last})}';
181
182
183fresh_perl_is <<'CODE',
184my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b
185CODE
186 q{Can't "next" outside a loop block at - line 1.},
187 { stderr => 1 }, '(?{next})';
188
189
190fresh_perl_is <<'CODE',
191my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b
192CODE
193 '45',
194 { stderr => 1 }, '(?{for {next}})';
195
196
197fresh_perl_is <<'CODE',
198for (1) { my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b
199CODE
200 q{Can't "next" outside a loop block at - line 1.},
201 { stderr => 1 }, 'for (1) {(?{next})}';
202
203
204fresh_perl_is <<'CODE',
205my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b
206CODE
207 '45',
208 { stderr => 1 }, 'eval {(?{next})}';
209
210
211fresh_perl_is <<'CODE',
212my $a=4; my $b=5;
213"a" =~ /(?{ goto FOO; print "X"; })a/;
214print "Y";
215FOO:
216print $a,$b
217CODE
218 q{Can't "goto" out of a pseudo block at - line 2.},
219 { stderr => 1 }, '{(?{goto})}';
220
221
222{
223 local $::TODO = "goto doesn't yet work in pseduo blocks";
224fresh_perl_is <<'CODE',
225my $a=4; my $b=5;
226"a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/;
227print "Z";
228FOO;
229print $a,$b
230CODE
231 "YZ45",
232 { stderr => 1 }, '{(?{goto FOO; FOO:})}';
233}
55b5114f 234
b4cc4f1f
DM
235# [perl #3590]
236fresh_perl_is <<'CODE', '', { stderr => 1 }, '(?{eval{die}})';
237"$_$_$_"; my $foo; # these consume pad entries and ensure a SEGV on opd perls
238"" =~ m{(?{exit(0)})};
239CODE
240
55b5114f
FC
241
242# [perl #92256]
243{ my $y = "a"; $y =~ /a(?{ undef *_ })/ }
244pass "undef *_ in a re-eval does not cause a double free";
81ed78b2
DM
245
246# make sure regexp warnings are reported on the right line
247# (we don't care what warning; the 32768 limit is just one
248# that was easy to reproduce) */
249{
250 use warnings;
251 my $w;
252 local $SIG{__WARN__} = sub { $w = "@_" };
253 my $qr = qr/(??{'a'})/;
254 my $filler = 1;
255 ("a" x 40_000) =~ /^$qr(ab*)+/; my $line = __LINE__;
256 like($w, qr/recursion limit.* line $line\b/, "warning on right line");
257}
0e458318
DM
258
259# on immediate exit from pattern with code blocks, make sure PL_curcop is
260# restored
261
262{
263 use re 'eval';
264
265 my $c = '(?{"1"})';
266 my $w = '';
267 my $l;
268
269 local $SIG{__WARN__} = sub { $w .= "@_" };
270 $l = __LINE__; "1" =~ /^1$c/x and warn "foo";
271 like($w, qr/foo.+line $l/, 'curcop 1');
272
273 $w = '';
274 $l = __LINE__; "4" =~ /^1$c/x or warn "foo";
275 like($w, qr/foo.+line $l/, 'curcop 2');
276
277 $c = '(??{"1"})';
278 $l = __LINE__; "1" =~ /^$c/x and warn "foo";
279 like($w, qr/foo.+line $l/, 'curcop 3');
280
281 $w = '';
282 $l = __LINE__; "4" =~ /^$c/x or warn "foo";
283 like($w, qr/foo.+line $l/, 'curcop 4');
284}
5fbe8311
DM
285
286# [perl #113928] caller behaving unexpectedly in re-evals
287#
288# /(?{...})/ should be in the same caller scope as the surrounding code;
289# qr/(?{...})/ should be in an anon sub
290
291{
292
293 my $l;
294
295 sub callers {
296 my @c;
297 my $stack = '';
298 my $i = 1;
299 while (@c = caller($i++)) {
300 $stack .= "($c[3]:" . ($c[2] - $l) . ')';
301 }
302 $stack;
303 }
304
305 $l = __LINE__;
306 my $c;
307 is (callers(), '', 'callers() null');
308 "" =~ /(?{ $c = callers() })/;
309 is ($c, '', 'callers() //');
310
311 $l = __LINE__;
312 sub m1 { "" =~ /(?{ $c = callers() })/; }
313 m1();
314 is ($c, '(main::m1:2)', 'callers() m1');
315
316 $l = __LINE__;
317 my $r1 = qr/(?{ $c = callers() })/;
318 "" =~ /$r1/;
319 is ($c, '(main::__ANON__:2)', 'callers() r1');
320
321 $l = __LINE__;
322 sub r1 { "" =~ /$r1/; }
323 r1();
324 is ($c, '(main::__ANON__:1)(main::r1:2)', 'callers() r1/r1');
325
326 $l = __LINE__;
327 sub c2 { $c = callers() }
328 my $r2 = qr/(?{ c2 })/;
329 "" =~ /$r2/;
330 is ($c, '(main::c2:2)(main::__ANON__:3)', 'callers() r2/c2');
331 sub r2 { "" =~ /$r2/; }
332 r2();
333 is ($c, '(main::c2:2)(main::__ANON__:5)(main::r2:6)', 'callers() r2/r2/c2');
334
335 $l = __LINE__;
336 sub c3 { $c = callers() }
337 my $r3 = qr/(?{ c3 })/;
338 my $c1;
339 "ABC" =~ /A(?{ $c1 = callers() })B${r3}C/;
340 is ($c, '(main::c3:2)(main::__ANON__:4)', 'callers() r3/c3');
341 is ($c1,'', 'callers() r3/c3 part 2');
342 sub r3 { "ABC" =~ /A(?{ $c1 = callers() })B${r3}C/; }
343 r3();
344 is ($c, '(main::c3:2)(main::__ANON__:7)(main::r3:8)', 'callers() r3/r3/c3');
345 is ($c1,'(main::r3:8)', 'callers() r3/r3/c3 part 2');
346
347}
a453e28a
DM
348
349# [perl #113928] caller behaving unexpectedly in re-evals
350#
351# make sure __SUB__ within a code block returns something safe.
352# NB waht it actually returns is subject to change
353
354{
355
356 my $s;
357
358 sub f1 { /(?{ $s = CORE::__SUB__; })/ }
359 f1();
360 is ($s, \&f1, '__SUB__ direct');
361
362 my $r = qr/(?{ $s = CORE::__SUB__; })/;
363 sub f2 { "" =~ $r }
364 f2();
365 is ($s, \&f2, '__SUB__ qr');
366
367 sub f3 { "AB" =~ /A${r}B/ }
368 f3();
369 is ($s, \&f3, '__SUB__ qr multi');
370}