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 pseduo 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