This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
preserve code blocks in interpolated qr//s
[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';
7 @INC = qw(lib ../lib);
8 require './test.pl';
9 skip_all_if_miniperl("no dynamic loading on miniperl, no re");
10}
d6faba0b 11
55b5114f 12plan 18;
d6faba0b
FC
13
14# Functions for turning to-do-ness on and off (as there are so many
15# to-do tests)
16sub on { $::TODO = "(?{}) implementation is screwy" }
17sub off { undef $::TODO }
18
d6faba0b 19
daaf7acc
DM
20fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
21 my $x = 7; my $a = 4; my $b = 5;
22 print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })a/;
23 print $x,$a,$b;
d6faba0b
FC
24CODE
25
26fresh_perl_is <<'CODE',
27 for my $x("a".."c") {
28 $y = 1;
29 print scalar
30 "abcabc" =~
31 /
32 (
33 a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
34 b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
35 c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
36 ){2}
37 /x;
38 print "$x ";
39 }
40CODE
41 '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ',
42 {},
43 'multiple (?{})s in loop with lexicals';
44
daaf7acc
DM
45fresh_perl_is <<'CODE', '781745', {}, 'run-time re-eval has its own scope';
46 use re qw(eval);
47 my $x = 7; my $a = 4; my $b = 5;
48 my $rest = 'a';
49 print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })$rest/;
50 print $x,$a,$b;
d6faba0b
FC
51CODE
52
daaf7acc 53fresh_perl_is <<'CODE', '178279371047857967101745', {},
d6faba0b
FC
54 use re "eval";
55 my $x = 7; $y = 1;
daaf7acc 56 my $a = 4; my $b = 5;
d6faba0b
FC
57 print scalar
58 "abcabc"
59 =~ ${\'(?x)
60 (
61 a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
62 b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
63 c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
64 ){2}
65 '};
daaf7acc 66 print $x,$a,$b
d6faba0b
FC
67CODE
68 'multiple (?{})s in "foo" =~ $string';
69
daaf7acc 70fresh_perl_is <<'CODE', '178279371047857967101745', {},
d6faba0b
FC
71 use re "eval";
72 my $x = 7; $y = 1;
daaf7acc 73 my $a = 4; my $b = 5;
d6faba0b
FC
74 print scalar
75 "abcabc" =~
76 /${\'
77 (
78 a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
79 b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
80 c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
81 ){2}
82 '}/x;
daaf7acc 83 print $x,$a,$b
d6faba0b
FC
84CODE
85 'multiple (?{})s in "foo" =~ /$string/x';
86
9e103e26
DM
87on;
88
d6faba0b
FC
89fresh_perl_is <<'CODE', '123123', {},
90 for my $x(1..3) {
b30fcab9 91 push @regexps, qr/(?{ print $x })a/;
d6faba0b
FC
92 }
93 "a" =~ $_ for @regexps;
94 "ba" =~ /b$_/ for @regexps;
95CODE
96 'qr/(?{})/ is a closure';
97
98off;
99
100"a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
101is $pack, 'foo', 'qr// inherits package';
102"a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
103is $re, '(?^x:)', 'qr// inherits pragmata';
104
b30fcab9 105$::pack = '';
d6faba0b
FC
106"ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
107is $pack, 'baz', '/text$qr/ inherits package';
108"ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
109is $re, '(?^i:)', '/text$qr/ inherits pragmata';
110
111off;
112{
113 use re 'eval';
114 package bar;
115 "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/;
116}
117is $pack, 'bar', '/$text/ containing (?{}) inherits package';
d6faba0b
FC
118{
119 use re 'eval', "/m";
120 "ba" =~ /${\'(?{ $::re = qr -- })a'}/;
121}
122is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
6c375d8b 123
558b4424
FC
124on;
125
daaf7acc
DM
126fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
127 eval { my $a=4; my $b=5; "a" =~ /(?{die})a/ }; print $a,$b"
6c375d8b 128CODE
c65895fd
JD
129
130SKIP: {
131 # The remaining TODO tests crash, which will display an error dialog
132 # on Windows that has to be manually dismissed. We don't want this
133 # to happen for release builds: 5.14.x, 5.16.x etc.
90803c37
DM
134 # On UNIX, they produce ugly 'Aborted' shell output mixed in with the
135 # test harness output, so skip on all platforms.
c65895fd 136 skip "Don't run crashing TODO test on release build", 3
90803c37 137 if $::TODO && (int($]*1000) & 1) == 0;
c65895fd
JD
138
139 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{last})';
140 { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
6c375d8b 141CODE
c65895fd
JD
142 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{next})';
143 { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
6c375d8b 144CODE
c65895fd
JD
145 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{return})';
146 print sub { my $a=4; my $b=5; "a" =~ /(?{return $a.$b})a/ }->();
6c375d8b 147CODE
c65895fd
JD
148}
149
daaf7acc
DM
150fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{goto})';
151 my $a=4; my $b=5; "a" =~ /(?{goto _})a/; die; _: print $a,$b
6c375d8b 152CODE
55b5114f
FC
153
154off;
155
156# [perl #92256]
157{ my $y = "a"; $y =~ /a(?{ undef *_ })/ }
158pass "undef *_ in a re-eval does not cause a double free";