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     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
  10 }
  11
  12 plan 34;
  13
  14 fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
  15  my $x = 7; my $a = 4; my $b = 5;
  16  print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })a/;
  17  print $x,$a,$b;
  18 CODE
  19
  20 fresh_perl_is <<'CODE',
  21  for my $x("a".."c") {
  22   $y = 1;
  23   print scalar
  24    "abcabc" =~
  25        /
  26         (
  27          a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
  28          b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
  29          c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
  30         ){2}
  31        /x;
  32   print "$x ";
  33  }
  34 CODE
  35  '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ',
  36   {},
  37  'multiple (?{})s in loop with lexicals';
  38
  39 fresh_perl_is <<'CODE', '781745', {}, 'run-time re-eval has its own scope';
  40  use re qw(eval);
  41  my $x = 7;  my $a = 4; my $b = 5;
  42  my $rest = 'a';
  43  print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })$rest/;
  44  print $x,$a,$b;
  45 CODE
  46
  47 fresh_perl_is <<'CODE', '178279371047857967101745', {},
  48  use re "eval";
  49  my $x = 7; $y = 1;
  50  my $a = 4; my $b = 5;
  51  print scalar
  52   "abcabc"
  53     =~ ${\'(?x)
  54         (
  55          a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
  56          b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
  57          c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
  58         ){2}
  59        '};
  60  print $x,$a,$b
  61 CODE
  62  'multiple (?{})s in "foo" =~ $string';
  63
  64 fresh_perl_is <<'CODE', '178279371047857967101745', {},
  65  use re "eval";
  66  my $x = 7; $y = 1;
  67  my $a = 4; my $b = 5;
  68  print scalar
  69   "abcabc" =~
  70       /${\'
  71         (
  72          a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
  73          b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
  74          c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
  75         ){2}
  76       '}/x;
  77  print $x,$a,$b
  78 CODE
  79  'multiple (?{})s in "foo" =~ /$string/x';
  80
  81 fresh_perl_is <<'CODE', '123123', {},
  82   for my $x(1..3) {
  83    push @regexps, qr/(?{ print $x })a/;
  84   }
  85  "a" =~ $_ for @regexps;
  86  "ba" =~ /b$_/ for @regexps;
  87 CODE
  88  'qr/(?{})/ is a closure';
  89
  90 "a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
  91 is $pack, 'foo', 'qr// inherits package';
  92 "a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
  93 is $re, '(?^x:)', 'qr// inherits pragmata';
  94
  95 $::pack = '';
  96 "ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
  97 is $pack, 'baz', '/text$qr/ inherits package';
  98 "ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
  99 is $re, '(?^i:)', '/text$qr/ inherits pragmata';
 100
 101 {
 102   use re 'eval';
 103   package bar;
 104   "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/;
 105 }
 106 is $pack, 'bar', '/$text/ containing (?{}) inherits package';
 107 {
 108   use re 'eval', "/m";
 109   "ba" =~ /${\'(?{ $::re = qr -- })a'}/;
 110 }
 111 is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
 112
 113 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
 114 my $a=4; my $b=5;  eval { "a" =~ /(?{die})a/ }; print $a,$b;
 115 CODE
 116
 117 fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})';
 118 my $a=4; my $b=5;
 119 "a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b;
 120 CODE
 121
 122 fresh_perl_is <<'CODE',
 123     my $a=4; my $b=5;
 124     sub f { "a" =~ /(?{print((caller(0))[3], "\n");})a/ };
 125     f();
 126     print $a,$b;
 127 CODE
 128     "main::f\n45",
 129     { stderr => 1 }, 'sub f {(?{caller})}';
 130
 131
 132 fresh_perl_is <<'CODE',
 133     my $a=4; my $b=5;
 134     sub f { print ((caller(0))[3], "-", (caller(1))[3], "\n") };
 135     "a" =~ /(?{f()})a/;
 136     print $a,$b;
 137 CODE
 138     "main::f-(unknown)\n45",
 139     { stderr => 1 }, 'sub f {caller} /(?{f()})/';
 140
 141
 142 fresh_perl_is <<'CODE',
 143     my $a=4; my $b=5;
 144     sub f {
 145         "a" =~ /(?{print "X"; return; print "Y"; })a/;
 146         print "Z";
 147     };
 148     f();
 149     print $a,$b;
 150 CODE
 151     "XZ45",
 152     { stderr => 1 }, 'sub f {(?{return})}';
 153
 154
 155 fresh_perl_is <<'CODE',
 156 my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b
 157 CODE
 158     q{Can't "last" outside a loop block at - line 1.},
 159     { stderr => 1 }, '(?{last})';
 160
 161
 162 fresh_perl_is <<'CODE',
 163 my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b
 164 CODE
 165     '45',
 166     { stderr => 1 }, '(?{for {last}})';
 167
 168
 169 fresh_perl_is <<'CODE',
 170 for (1) {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
 171 CODE
 172     q{Can't "last" outside a loop block at - line 1.},
 173     { stderr => 1 }, 'for (1) {(?{last})}';
 174
 175
 176 fresh_perl_is <<'CODE',
 177 my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b
 178 CODE
 179     '45',
 180     { stderr => 1 }, 'eval {(?{last})}';
 181
 182
 183 fresh_perl_is <<'CODE',
 184 my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b
 185 CODE
 186     q{Can't "next" outside a loop block at - line 1.},
 187     { stderr => 1 }, '(?{next})';
 188
 189
 190 fresh_perl_is <<'CODE',
 191 my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b
 192 CODE
 193     '45',
 194     { stderr => 1 }, '(?{for {next}})';
 195
 196
 197 fresh_perl_is <<'CODE',
 198 for (1) {  my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b
 199 CODE
 200     q{Can't "next" outside a loop block at - line 1.},
 201     { stderr => 1 }, 'for (1) {(?{next})}';
 202
 203
 204 fresh_perl_is <<'CODE',
 205 my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b
 206 CODE
 207     '45',
 208     { stderr => 1 }, 'eval {(?{next})}';
 209
 210
 211 fresh_perl_is <<'CODE',
 212 my $a=4; my $b=5;
 213 "a" =~ /(?{ goto FOO; print "X"; })a/;
 214 print "Y";
 215 FOO:
 216 print $a,$b
 217 CODE
 218     q{Can't "goto" out of a pseudo block at - line 2.},
 219     { stderr => 1 }, '{(?{goto})}';
 220
 221
 222 {
 223     local $::TODO = "goto doesn't yet work in pseduo blocks";
 224 fresh_perl_is <<'CODE',
 225 my $a=4; my $b=5;
 226 "a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/;
 227 print "Z";
 228 FOO;
 229 print $a,$b
 230 CODE
 231     "YZ45",
 232     { stderr => 1 }, '{(?{goto FOO; FOO:})}';
 233 }
 234
 235 # [perl #3590]
 236 fresh_perl_is <<'CODE', '', { stderr => 1 }, '(?{eval{die}})';
 237 "$_$_$_"; my $foo; # these consume pad entries and ensure a SEGV on opd perls
 238 "" =~ m{(?{exit(0)})};
 239 CODE
 240
 241
 242 # [perl #92256]
 243 { my $y = "a"; $y =~ /a(?{ undef *_ })/ }
 244 pass "undef *_ in a re-eval does not cause a double free";
 245
 246 # make sure regexp warnings are reported on the right line
 247 # (we don't care what warning; the 32768 limit is just one
 248 # that was easy to reproduce) */
 249 {
 250     use warnings;
 251     my $w;
 252     local $SIG{__WARN__} = sub { $w = "@_" };
 253     my $qr = qr/(??{'a'})/;
 254     my $filler = 1;
 255     ("a" x 40_000) =~ /^$qr(ab*)+/; my $line = __LINE__;
 256     like($w, qr/recursion limit.* line $line\b/, "warning on right line");
 257 }
 258
 259 # on immediate exit from pattern with code blocks, make sure PL_curcop is
 260 # restored
 261
 262 {
 263     use re 'eval';
 264
 265     my $c = '(?{"1"})';
 266     my $w = '';
 267     my $l;
 268
 269     local $SIG{__WARN__} = sub { $w .= "@_" };
 270     $l = __LINE__; "1" =~ /^1$c/x and warn "foo";
 271     like($w, qr/foo.+line $l/, 'curcop 1');
 272
 273     $w = '';
 274     $l = __LINE__; "4" =~ /^1$c/x or warn "foo";
 275     like($w, qr/foo.+line $l/, 'curcop 2');
 276
 277     $c = '(??{"1"})';
 278     $l = __LINE__; "1" =~ /^$c/x and warn "foo";
 279     like($w, qr/foo.+line $l/, 'curcop 3');
 280
 281     $w = '';
 282     $l = __LINE__; "4" =~ /^$c/x or warn "foo";
 283     like($w, qr/foo.+line $l/, 'curcop 4');
 284 }