This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
disable lexing of (?{}) within \Q, \U etc
[perl5.git] / t / re / pat_re_eval.t
1 #!./perl
2 #
3 # This is a home for regular expression tests that don't fit into
4 # the format supported by re/regexp.t.  If you want to add a test
5 # that does fit that format, add it to re/re_tests, not here.
6
7 use strict;
8 use warnings;
9 use 5.010;
10
11
12 sub run_tests;
13
14 $| = 1;
15
16
17 BEGIN {
18     chdir 't' if -d 't';
19     @INC = ('../lib','.');
20     require './test.pl';
21     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
22 }
23
24
25 plan tests => 127;  # Update this when adding/deleting tests.
26
27 run_tests() unless caller;
28
29 #
30 # Tests start here.
31 #
32 sub run_tests {
33     {
34         my $message =  "Call code from qr //";
35         local $_ = 'var="foo"';
36         $a = qr/(?{++$b})/;
37         $b = 7;
38         ok(/$a$a/ && $b eq '9', $message);
39
40         my $c="$a";
41         ok(/$a$a/ && $b eq '11', $message);
42
43         undef $@;
44         eval {/$c/};
45         like($@, qr/not allowed at runtime/, $message);
46
47         use re "eval";
48         /$a$c$a/;
49         is($b, '14', $message);
50
51         our $lex_a = 43;
52         our $lex_b = 17;
53         our $lex_c = 27;
54         my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
55
56         is($lex_res, 1, $message);
57         is($lex_a, 44, $message);
58         is($lex_c, 43, $message);
59
60         no re "eval";
61         undef $@;
62         my $match = eval { /$a$c$a/ };
63         ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
64         is($b, '14', $message);
65
66         $lex_a = 2;
67         $lex_a = 43;
68         $lex_b = 17;
69         $lex_c = 27;
70         $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
71
72         is($lex_res, 1, $message);
73         is($lex_a, 44, $message);
74         is($lex_c, 43, $message);
75
76     }
77
78     {
79         our $a = bless qr /foo/ => 'Foo';
80         ok 'goodfood' =~ $a,     "Reblessed qr // matches";
81         is($a, '(?^:foo)', "Reblessed qr // stringifies");
82         my $x = "\x{3fe}";
83         my $z = my $y = "\317\276";  # Byte representation of $x
84         $a = qr /$x/;
85         ok $x =~ $a, "UTF-8 interpolation in qr //";
86         ok "a$a" =~ $x, "Stringified qr // preserves UTF-8";
87         ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8";
88         ok "a$x" =~ /^a(??{$a})\z/,
89                         "Postponed interpolation of qr // preserves UTF-8";
90
91
92         is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
93
94         {
95             use re 'eval';
96             ok "$x$x" =~ /^$x(??{$x})\z/,
97                "Postponed UTF-8 string in UTF-8 re matches UTF-8";
98             ok "$y$x" =~ /^$y(??{$x})\z/,
99                "Postponed UTF-8 string in non-UTF-8 re matches UTF-8";
100             ok "$y$x" !~ /^$y(??{$y})\z/,
101                "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8";
102             ok "$x$x" !~ /^$x(??{$y})\z/,
103                "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8";
104             ok "$y$y" =~ /^$y(??{$y})\z/,
105                "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8";
106             ok "$x$y" =~ /^$x(??{$y})\z/,
107                "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8";
108
109             $y = $z;  # Reset $y after upgrade.
110             ok "$x$y" !~ /^$x(??{$x})\z/,
111                "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8";
112             ok "$y$y" !~ /^$y(??{$x})\z/,
113                "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8";
114         }
115     }
116
117
118     {
119         use re 'eval';
120         # Test if $^N and $+ work in (?{{})
121         our @ctl_n = ();
122         our @plus = ();
123         our $nested_tags;
124         $nested_tags = qr{
125             <
126                ((\w)+)
127                (?{
128                        push @ctl_n, (defined $^N ? $^N : "undef");
129                        push @plus, (defined $+ ? $+ : "undef");
130                })
131             >
132             (??{$nested_tags})*
133             </\s* \w+ \s*>
134         }x;
135
136
137         my $c = 0;
138         for my $test (
139             # Test structure:
140             #  [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ]
141             [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ],
142             [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ],
143             [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ],
144             [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ],
145             [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ],
146             [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
147             [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
148             [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ],
149             [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ],
150             [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
151             [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
152             [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ],
153             [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ],
154
155         ) { #"#silence vim highlighting
156             $c++;
157             @ctl_n = ();
158             @plus = ();
159             my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0);
160             push @ctl_n, (defined $^N ? $^N : "undef");
161             push @plus, (defined $+ ? $+ : "undef");
162             ok($test->[0] == $match, "match $c");
163             if ($test->[0] != $match) {
164               # unset @ctl_n and @plus
165               @ctl_n = @plus = ();
166             }
167             is("@ctl_n", $test->[2], "ctl_n $c");
168             is("@plus", $test->[3], "plus $c");
169         }
170     }
171
172     {
173         use re 'eval';
174
175
176         our $f;
177         local $f;
178         $f = sub {
179             defined $_[0] ? $_[0] : "undef";
180         };
181
182         like("123", qr/^(\d)(((??{1 + $^N})))+$/, 'Bug 56194');
183
184         our @ctl_n;
185         our @plus;
186
187         my $re  = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#;
188         my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#;
189         my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#;
190         our $re5;
191         local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#;
192         my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
193         my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#;
194         my $re8 = qr/(\d+)/;
195         my $c = 0;
196         for my $test (
197              # Test structure:
198              #  [
199              #    String to match
200              #    Regex too match
201              #    Expected values of $^N
202              #    Expected values of $+
203              #    Expected values of $1, $2, $3, $4 and $5
204              #  ]
205              [
206                   "1233",
207                   qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#,
208                   "1 2 3 3",
209                   "1 2 3 3",
210                   "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
211              ],
212              [
213                   "1233",
214                   qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#,
215                   "1 2 3 3",
216                   "1 2 3 3",
217                   "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
218              ],
219              [
220                   "1233",
221                   qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#,
222                   "1 2 3 3",
223                   "1 2 3 3",
224                   "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
225              ],
226              [
227                   "1233",
228                   qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#,
229                   "1 2 3 3",
230                   "1 2 3 3",
231                   "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
232              ],
233              [
234                   "1233",
235                   qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#,
236                   "1 2 3 3",
237                   "1 2 3 3",
238                   "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef",
239               ],
240               [
241                   "123abc3",
242                    qr#^($re)(|a(b)c|def)(??{$^R})$#,
243                    "1 2 3 abc",
244                    "1 2 3 b",
245                    "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
246               ],
247               [
248                   "123abc3",
249                    qr#^($re2)$#,
250                    "1 2 3 123abc3",
251                    "1 2 3 b",
252                    "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
253               ],
254               [
255                   "123abc3",
256                    qr#^($re3)$#,
257                    "1 2 123abc3",
258                    "1 2 b",
259                    "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b",
260               ],
261               [
262                   "123abc3",
263                    qr#^(??{$re5})(|abc|def)(??{"$^R"})$#,
264                    "1 2 abc",
265                    "1 2 abc",
266                    "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef",
267               ],
268               [
269                   "123abc3",
270                    qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#,
271                    "1 2 abc",
272                    "1 2 b",
273                    "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef",
274               ],
275               [
276                   "1234",
277                    qr#^((\d+)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})))$#,
278                    "1234 123 12 1 2 3 1234",
279                    "1234 123 12 1 2 3 4",
280                    "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4",
281               ],
282               [
283                    "1234556",
284                    qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#,
285                    "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56",
286                    "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5",
287                    "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56",
288               ],
289               [
290                   "12345562",
291                    qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#,
292                    "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62",
293                    "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2",
294                    "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5",
295               ],
296         ) {
297             $c++;
298             @ctl_n = ();
299             @plus = ();
300             undef $^R;
301             my $match = $test->[0] =~ $test->[1];
302             my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5));
303             push @ctl_n, $f->($^N);
304             push @plus, $f->($+);
305             ok($match, "match $c; Bug 56194");
306             if (not $match) {
307                 # unset $str, @ctl_n and @plus
308                 $str = "";
309                 @ctl_n = @plus = ();
310             }
311             is("@ctl_n", $test->[2], "ctl_n $c; Bug 56194");
312             is("@plus", $test->[3], "plus $c; Bug 56194");
313             is($str, $test->[4], "str $c; Bug 56194");
314         }
315         SKIP: {
316             if ($] le '5.010') {
317                 skip "test segfaults on perl < 5.10", 4;
318             }
319
320             @ctl_n = ();
321             @plus = ();
322
323             our $re4;
324             local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#;
325             undef $^R;
326             my $match = "123abc3" =~ m/^(??{$re4})$/;
327             my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R));
328             push @ctl_n, $f->($^N);
329             push @plus, $f->($+);
330             ok($match, 'Bug 56194');
331             if (not $match) {
332                 # unset $str
333                 @ctl_n = ();
334                 @plus = ();
335                 $str = "";
336             }
337             is("@ctl_n", "1 2 undef", 'Bug 56194');
338             is("@plus", "1 2 undef", 'Bug 56194');
339             is($str,
340                "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef",
341                'Bug 56194');
342        }
343     }
344
345     {
346         # re evals within \U, \Q etc shouldn't be seen by the lexer
347         local our $a  = "i";
348         local our $B  = "J";
349         ok('(?{1})' =~ /^\Q(?{1})\E$/,   '\Q(?{1})\E');
350         ok('(?{1})' =~ /^\Q(?{\E1\}\)$/, '\Q(?{\E1\}\)');
351         use re 'eval';
352         ok('Ia' =~ /^\U(??{"$a\Ea"})$/,  '^\U(??{"$a\Ea"})$');
353         ok('ja' =~ /^\L(??{"$B\Ea"})$/,  '^\L(??{"$B\Ea"})$');
354     }
355
356 } # End of sub run_tests
357
358 1;