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