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