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 17;
  13
  14 # Functions for turning to-do-ness on and off (as there are so many
  15 # to-do tests)
  16 sub on { $::TODO = "(?{}) implementation is screwy" }
  17 sub off { undef $::TODO }
  18
  19
  20 fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
  21  my $x = 7; my $a = 4; my $b = 5;
  22  print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })a/;
  23  print $x,$a,$b;
  24 CODE
  25
  26 on;
  27
  28 fresh_perl_is <<'CODE',
  29  for my $x("a".."c") {
  30   $y = 1;
  31   print scalar
  32    "abcabc" =~
  33        /
  34         (
  35          a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
  36          b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
  37          c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
  38         ){2}
  39        /x;
  40   print "$x ";
  41  }
  42 CODE
  43  '1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ',
  44   {},
  45  'multiple (?{})s in loop with lexicals';
  46
  47 off;
  48
  49 fresh_perl_is <<'CODE', '781745', {}, 'run-time re-eval has its own scope';
  50  use re qw(eval);
  51  my $x = 7;  my $a = 4; my $b = 5;
  52  my $rest = 'a';
  53  print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })$rest/;
  54  print $x,$a,$b;
  55 CODE
  56
  57 fresh_perl_is <<'CODE', '178279371047857967101745', {},
  58  use re "eval";
  59  my $x = 7; $y = 1;
  60  my $a = 4; my $b = 5;
  61  print scalar
  62   "abcabc"
  63     =~ ${\'(?x)
  64         (
  65          a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
  66          b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
  67          c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
  68         ){2}
  69        '};
  70  print $x,$a,$b
  71 CODE
  72  'multiple (?{})s in "foo" =~ $string';
  73
  74 fresh_perl_is <<'CODE', '178279371047857967101745', {},
  75  use re "eval";
  76  my $x = 7; $y = 1;
  77  my $a = 4; my $b = 5;
  78  print scalar
  79   "abcabc" =~
  80       /${\'
  81         (
  82          a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
  83          b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
  84          c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
  85         ){2}
  86       '}/x;
  87  print $x,$a,$b
  88 CODE
  89  'multiple (?{})s in "foo" =~ /$string/x';
  90
  91 on;
  92
  93 fresh_perl_is <<'CODE', '123123', {},
  94   for my $x(1..3) {
  95    push @regexps = qr/(?{ print $x })a/;
  96   }
  97  "a" =~ $_ for @regexps;
  98  "ba" =~ /b$_/ for @regexps;
  99 CODE
 100  'qr/(?{})/ is a closure';
 101
 102 off;
 103
 104 "a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
 105 is $pack, 'foo', 'qr// inherits package';
 106 "a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
 107 is $re, '(?^x:)', 'qr// inherits pragmata';
 108
 109 on;
 110
 111 "ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
 112 is $pack, 'baz', '/text$qr/ inherits package';
 113 "ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
 114 is $re, '(?^i:)', '/text$qr/ inherits pragmata';
 115
 116 off;
 117 {
 118   use re 'eval';
 119   package bar;
 120   "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/;
 121 }
 122 is $pack, 'bar', '/$text/ containing (?{}) inherits package';
 123 {
 124   use re 'eval', "/m";
 125   "ba" =~ /${\'(?{ $::re = qr -- })a'}/;
 126 }
 127 is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
 128
 129 on;
 130
 131 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
 132  eval { my $a=4; my $b=5; "a" =~ /(?{die})a/ }; print $a,$b"
 133 CODE
 134
 135 SKIP: {
 136     # The remaining TODO tests crash, which will display an error dialog
 137     # on Windows that has to be manually dismissed.  We don't want this
 138     # to happen for release builds: 5.14.x, 5.16.x etc.
 139     # On UNIX, they produce ugly 'Aborted' shell output mixed in with the
 140     # test harness output, so skip on all platforms.
 141     skip "Don't run crashing TODO test on release build", 3
 142         if $::TODO && (int($]*1000) & 1) == 0;
 143
 144     fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{last})';
 145      {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
 146 CODE
 147     fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{next})';
 148      {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
 149 CODE
 150     fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{return})';
 151      print sub {  my $a=4; my $b=5; "a" =~ /(?{return $a.$b})a/ }->();
 152 CODE
 153 }
 154
 155 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{goto})';
 156   my $a=4; my $b=5; "a" =~ /(?{goto _})a/; die; _: print $a,$b
 157 CODE