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