1#!perl 2 3# Test scoping issues with embedded code in regexps. 4 5BEGIN { 6 chdir 't'; 7 @INC = qw(lib ../lib); 8 require './test.pl'; 9} 10 11plan 48; 12 13fresh_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; 17CODE 18 19fresh_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 } 33CODE 34 '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ', 35 {}, 36 'multiple (?{})s in loop with lexicals'; 37 38fresh_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; 44CODE 45 46fresh_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 60CODE 61 'multiple (?{})s in "foo" =~ $string'; 62 63fresh_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 77CODE 78 'multiple (?{})s in "foo" =~ /$string/x'; 79 80fresh_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; 86CODE 87 'qr/(?{})/ is a closure'; 88 89"a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ }; 90is $pack, 'foo', 'qr// inherits package'; 91"a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ }; 92is $re, '(?^x:)', 'qr// inherits pragmata'; 93 94$::pack = ''; 95"ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/; 96is $pack, 'baz', '/text$qr/ inherits package'; 97"ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+; 98is $re, '(?^i:)', '/text$qr/ inherits pragmata'; 99 100{ 101 use re 'eval'; 102 package bar; 103 "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/; 104} 105is $pack, 'bar', '/$text/ containing (?{}) inherits package'; 106{ 107 use re 'eval', "/m"; 108 "ba" =~ /${\'(?{ $::re = qr -- })a'}/; 109} 110is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata'; 111 112fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})'; 113my $a=4; my $b=5; eval { "a" =~ /(?{die})a/ }; print $a,$b; 114CODE 115 116fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})'; 117my $a=4; my $b=5; 118"a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b; 119CODE 120 121fresh_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; 126CODE 127 "main::f\n45", 128 { stderr => 1 }, 'sub f {(?{caller})}'; 129 130 131fresh_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; 136CODE 137 "main::f--\n45", 138 { stderr => 1 }, 'sub f {caller} /(?{f()})/'; 139 140 141fresh_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; 149CODE 150 "XZ45", 151 { stderr => 1 }, 'sub f {(?{return})}'; 152 153 154fresh_perl_is <<'CODE', 155my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b 156CODE 157 q{Can't "last" outside a loop block at - line 1.}, 158 { stderr => 1 }, '(?{last})'; 159 160 161fresh_perl_is <<'CODE', 162my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b 163CODE 164 '45', 165 { stderr => 1 }, '(?{for {last}})'; 166 167 168fresh_perl_is <<'CODE', 169for (1) { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b 170CODE 171 q{Can't "last" outside a loop block at - line 1.}, 172 { stderr => 1 }, 'for (1) {(?{last})}'; 173 174 175fresh_perl_is <<'CODE', 176my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b 177CODE 178 '45', 179 { stderr => 1 }, 'eval {(?{last})}'; 180 181 182fresh_perl_is <<'CODE', 183my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b 184CODE 185 q{Can't "next" outside a loop block at - line 1.}, 186 { stderr => 1 }, '(?{next})'; 187 188 189fresh_perl_is <<'CODE', 190my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b 191CODE 192 '45', 193 { stderr => 1 }, '(?{for {next}})'; 194 195 196fresh_perl_is <<'CODE', 197for (1) { my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b 198CODE 199 q{Can't "next" outside a loop block at - line 1.}, 200 { stderr => 1 }, 'for (1) {(?{next})}'; 201 202 203fresh_perl_is <<'CODE', 204my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b 205CODE 206 '45', 207 { stderr => 1 }, 'eval {(?{next})}'; 208 209 210fresh_perl_is <<'CODE', 211my $a=4; my $b=5; 212"a" =~ /(?{ goto FOO; print "X"; })a/; 213print "Y"; 214FOO: 215print $a,$b 216CODE 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"; 223fresh_perl_is <<'CODE', 224my $a=4; my $b=5; 225"a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/; 226print "Z"; 227FOO; 228print $a,$b 229CODE 230 "YZ45", 231 { stderr => 1 }, '{(?{goto FOO; FOO:})}'; 232} 233 234# [perl #3590] 235fresh_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)})}; 238CODE 239 240 241# [perl #92256] 242{ my $y = "a"; $y =~ /a(?{ undef *_ })/ } 243pass "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} 370