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