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
1 #!perl
2
3 # Test scoping issues with embedded code in regexps.
4
5 BEGIN {
6     chdir 't';
7     require './test.pl';
8     @INC = () unless is_miniperl();
9     unshift @INC, qw(lib ../lib);
10 }
11
12 plan 48;
13
14 fresh_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;
18 CODE
19
20 fresh_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  }
34 CODE
35  '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ',
36   {},
37  'multiple (?{})s in loop with lexicals';
38
39 fresh_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;
45 CODE
46
47 fresh_perl_is <<'CODE', '178279371047857967101745', {},
48  use re "eval";
49  my $x = 7; $y = 1;
50  my $a = 4; my $b = 5;
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        '};
60  print $x,$a,$b
61 CODE
62  'multiple (?{})s in "foo" =~ $string';
63
64 fresh_perl_is <<'CODE', '178279371047857967101745', {},
65  use re "eval";
66  my $x = 7; $y = 1;
67  my $a = 4; my $b = 5;
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;
77  print $x,$a,$b
78 CODE
79  'multiple (?{})s in "foo" =~ /$string/x';
80
81 fresh_perl_is <<'CODE', '123123', {},
82   for my $x(1..3) {
83    push @regexps, qr/(?{ print $x })a/;
84   }
85  "a" =~ $_ for @regexps;
86  "ba" =~ /b$_/ for @regexps;
87 CODE
88  'qr/(?{})/ is a closure';
89
90 "a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
91 is $pack, 'foo', 'qr// inherits package';
92 "a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
93 is $re, '(?^x:)', 'qr// inherits pragmata';
94
95 $::pack = '';
96 "ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
97 is $pack, 'baz', '/text$qr/ inherits package';
98 "ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
99 is $re, '(?^i:)', '/text$qr/ inherits pragmata';
100
101 {
102   use re 'eval';
103   package bar;
104   "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/;
105 }
106 is $pack, 'bar', '/$text/ containing (?{}) inherits package';
107 {
108   use re 'eval', "/m";
109   "ba" =~ /${\'(?{ $::re = qr -- })a'}/;
110 }
111 is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
112
113 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
114 my $a=4; my $b=5;  eval { "a" =~ /(?{die})a/ }; print $a,$b;
115 CODE
116
117 fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})';
118 my $a=4; my $b=5;
119 "a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b;
120 CODE
121
122 fresh_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;
127 CODE
128     "main::f\n45",
129     { stderr => 1 }, 'sub f {(?{caller})}';
130
131
132 fresh_perl_is <<'CODE',
133     my $a=4; my $b=5;
134     sub f { print ((caller(0))[3], "-", (caller(1))[3], "-\n") };
135     "a" =~ /(?{f()})a/;
136     print $a,$b;
137 CODE
138     "main::f--\n45",
139     { stderr => 1 }, 'sub f {caller} /(?{f()})/';
140
141
142 fresh_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;
150 CODE
151     "XZ45",
152     { stderr => 1 }, 'sub f {(?{return})}';
153
154
155 fresh_perl_is <<'CODE',
156 my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b
157 CODE
158     q{Can't "last" outside a loop block at - line 1.},
159     { stderr => 1 }, '(?{last})';
160
161
162 fresh_perl_is <<'CODE',
163 my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b
164 CODE
165     '45',
166     { stderr => 1 }, '(?{for {last}})';
167
168
169 fresh_perl_is <<'CODE',
170 for (1) {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
171 CODE
172     q{Can't "last" outside a loop block at - line 1.},
173     { stderr => 1 }, 'for (1) {(?{last})}';
174
175
176 fresh_perl_is <<'CODE',
177 my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b
178 CODE
179     '45',
180     { stderr => 1 }, 'eval {(?{last})}';
181
182
183 fresh_perl_is <<'CODE',
184 my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b
185 CODE
186     q{Can't "next" outside a loop block at - line 1.},
187     { stderr => 1 }, '(?{next})';
188
189
190 fresh_perl_is <<'CODE',
191 my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b
192 CODE
193     '45',
194     { stderr => 1 }, '(?{for {next}})';
195
196
197 fresh_perl_is <<'CODE',
198 for (1) {  my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b
199 CODE
200     q{Can't "next" outside a loop block at - line 1.},
201     { stderr => 1 }, 'for (1) {(?{next})}';
202
203
204 fresh_perl_is <<'CODE',
205 my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b
206 CODE
207     '45',
208     { stderr => 1 }, 'eval {(?{next})}';
209
210
211 fresh_perl_is <<'CODE',
212 my $a=4; my $b=5;
213 "a" =~ /(?{ goto FOO; print "X"; })a/;
214 print "Y";
215 FOO:
216 print $a,$b
217 CODE
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";
224 fresh_perl_is <<'CODE',
225 my $a=4; my $b=5;
226 "a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/;
227 print "Z";
228 FOO;
229 print $a,$b
230 CODE
231     "YZ45",
232     { stderr => 1 }, '{(?{goto FOO; FOO:})}';
233 }
234
235 # [perl #3590]
236 fresh_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)})};
239 CODE
240
241
242 # [perl #92256]
243 { my $y = "a"; $y =~ /a(?{ undef *_ })/ }
244 pass "undef *_ in a re-eval does not cause a double free";
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 }
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 }
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 }
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 }