t/re/reg_eval_scope.t

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