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