t/re/reg_eval_scope.t

   1 #!perl
   2
   3 # Test scoping issues with embedded code in regexps.
   4
   5 BEGIN {
   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
  15 plan 49;
  16
  17 fresh_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;
  21 CODE
  22
  23 fresh_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  }
  37 CODE
  38  '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ',
  39   {},
  40  'multiple (?{})s in loop with lexicals';
  41
  42 fresh_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;
  48 CODE
  49
  50 fresh_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
  64 CODE
  65  'multiple (?{})s in "foo" =~ $string';
  66
  67 fresh_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
  81 CODE
  82  'multiple (?{})s in "foo" =~ /$string/x';
  83
  84 fresh_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;
  90 CODE
  91  'qr/(?{})/ is a closure';
  92
  93 "a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
  94 is $pack, 'foo', 'qr// inherits package';
  95 "a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
  96 is $re, '(?^x:)', 'qr// inherits pragmata';
  97
  98 $::pack = '';
  99 "ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
 100 is $pack, 'baz', '/text$qr/ inherits package';
 101 "ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
 102 is $re, '(?^i:)', '/text$qr/ inherits pragmata';
 103
 104 {
 105   use re 'eval';
 106   package bar;
 107   "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/;
 108 }
 109 is $pack, 'bar', '/$text/ containing (?{}) inherits package';
 110 {
 111   use re 'eval', "/m";
 112   "ba" =~ /${\'(?{ $::re = qr -- })a'}/;
 113 }
 114 is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
 115
 116 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
 117 my $a=4; my $b=5;  eval { "a" =~ /(?{die})a/ }; print $a,$b;
 118 CODE
 119
 120 fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})';
 121 my $a=4; my $b=5;
 122 "a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b;
 123 CODE
 124
 125 fresh_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;
 130 CODE
 131     "main::f\n45",
 132     { stderr => 1 }, 'sub f {(?{caller})}';
 133
 134
 135 fresh_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;
 140 CODE
 141     "main::f--\n45",
 142     { stderr => 1 }, 'sub f {caller} /(?{f()})/';
 143
 144
 145 fresh_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;
 153 CODE
 154     "XZ45",
 155     { stderr => 1 }, 'sub f {(?{return})}';
 156
 157
 158 fresh_perl_is <<'CODE',
 159 my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b
 160 CODE
 161     q{Can't "last" outside a loop block at - line 1.},
 162     { stderr => 1 }, '(?{last})';
 163
 164
 165 fresh_perl_is <<'CODE',
 166 my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b
 167 CODE
 168     '45',
 169     { stderr => 1 }, '(?{for {last}})';
 170
 171
 172 fresh_perl_is <<'CODE',
 173 for (1) {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
 174 CODE
 175     q{Can't "last" outside a loop block at - line 1.},
 176     { stderr => 1 }, 'for (1) {(?{last})}';
 177
 178
 179 fresh_perl_is <<'CODE',
 180 my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b
 181 CODE
 182     '45',
 183     { stderr => 1 }, 'eval {(?{last})}';
 184
 185
 186 fresh_perl_is <<'CODE',
 187 my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b
 188 CODE
 189     q{Can't "next" outside a loop block at - line 1.},
 190     { stderr => 1 }, '(?{next})';
 191
 192
 193 fresh_perl_is <<'CODE',
 194 my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b
 195 CODE
 196     '45',
 197     { stderr => 1 }, '(?{for {next}})';
 198
 199
 200 fresh_perl_is <<'CODE',
 201 for (1) {  my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b
 202 CODE
 203     q{Can't "next" outside a loop block at - line 1.},
 204     { stderr => 1 }, 'for (1) {(?{next})}';
 205
 206
 207 fresh_perl_is <<'CODE',
 208 my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b
 209 CODE
 210     '45',
 211     { stderr => 1 }, 'eval {(?{next})}';
 212
 213
 214 fresh_perl_is <<'CODE',
 215 my $a=4; my $b=5;
 216 "a" =~ /(?{ goto FOO; print "X"; })a/;
 217 print "Y";
 218 FOO:
 219 print $a,$b
 220 CODE
 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 pseudo blocks";
 227 fresh_perl_is <<'CODE',
 228 my $a=4; my $b=5;
 229 "a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/;
 230 print "Z";
 231 FOO;
 232 print $a,$b
 233 CODE
 234     "YZ45",
 235     { stderr => 1 }, '{(?{goto FOO; FOO:})}';
 236 }
 237
 238 # [perl #3590]
 239 fresh_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)})};
 242 CODE
 243
 244
 245 # [perl #92256]
 246 { my $y = "a"; $y =~ /a(?{ undef *_ })/ }
 247 pass "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 */
 251 SKIP: {
 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
 379 fresh_perl_like <<'CODE',
 380     BEGIN {$^H = 0x10000 }; # HINT_NEW_RE
 381     qr/\(?{/
 382 CODE
 383     qr/Constant\(qq\) unknown/,
 384     { stderr => 1 },
 385     'qr/\(?{';