This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Properly restore PL_curcop after /(?{})/
[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     @INC = qw(lib ../lib);
8     require './test.pl';
9     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
10 }
11
12 plan 34;
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-(unknown)\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 }