This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2a3be2162868444ee532ecd360f094a16418e3c4
[perl5.git] / t / re / regexp.t
1 #!./perl
2
3 # The tests are in a separate file 't/re/re_tests'.
4 # Each line in that file is a separate test.
5 # There are five columns, separated by tabs.
6 # An optional sixth column is used to give a reason, only when skipping tests
7 #
8 # Column 1 contains the pattern, optionally enclosed in C<''> C<::> or
9 # C<//>.  Modifiers can be put after the closing delimiter.  C<''> will
10 # automatically be added to any other patterns.
11 #
12 # Column 2 contains the string to be matched.
13 #
14 # Column 3 contains the expected result:
15 #       y       expect a match
16 #       n       expect no match
17 #       c       expect an error
18 #       T       the test is a TODO (can be combined with y/n/c)
19 #       M       skip test on miniperl (combine with y/n/c/T)
20 #       B       test exposes a known bug in Perl, should be skipped
21 #       b       test exposes a known bug in Perl, should be skipped if noamp
22 #       t       test exposes a bug with threading, TODO if qr_embed_thr
23 #       s       test should only be run for regex_sets_compat.t
24 #       S       test should not be run for regex_sets_compat.t
25 #       a       test should only be run on ASCII platforms
26 #       e       test should only be run on EBCDIC platforms
27 #
28 # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
29 #
30 # Column 4 contains a string, usually C<$&>.
31 #
32 # Column 5 contains the expected result of double-quote
33 # interpolating that string after the match, or start of error message.
34 #
35 # Column 6, if present, contains a reason why the test is skipped.
36 # This is printed with "skipped", for harness to pick up.
37 #
38 # Column 7 can be used for comments
39 #
40 # \n in the tests are interpolated, as are variables of the form ${\w+}.
41 #
42 # Blanks lines are treated as PASSING tests to keep the line numbers
43 # linked to the test number.
44 #
45 # If you want to add a regular expression test that can't be expressed
46 # in this format, don't add it here: put it in re/pat.t instead.
47 #
48 # Note that the inputs get passed on as "m're'", so the re bypasses the lexer.
49 # This means this file cannot be used for testing anything that the lexer
50 # handles; in 5.12 this means just \N{NAME} and \N{U+...}.
51 #
52 # Note that columns 2,3 and 5 are all enclosed in double quotes and then
53 # evalled; so something like a\"\x{100}$1 has length 3+length($1).
54 #
55 # \x... and \o{...} constants are automatically converted to the native
56 # character set if necessary.  \[0-7] constants aren't
57
58 my ($file, $iters);
59 BEGIN {
60     $iters = shift || 1;        # Poor man performance suite, 10000 is OK.
61
62     # Do this open before any chdir
63     $file = shift;
64     if (defined $file) {
65         open TESTS, $file or die "Can't open $file";
66     }
67
68     chdir 't' if -d 't';
69     @INC = qw '../lib ../ext/re';
70     if (!defined &DynaLoader::boot_DynaLoader) { # miniperl
71         print("1..0 # Skip Unicode tables not built yet\n"), exit
72             unless eval 'require "unicore/UCD.pl"';
73     }
74
75     # Some of the tests need a locale; which one doesn't much matter, except
76     # that it be valid.  Make sure of that
77     eval { require POSIX;
78             POSIX->import(qw(LC_ALL setlocale));
79             POSIX::setlocale(&LC_ALL, "C");
80     };
81 }
82
83 sub _comment {
84     return map { /^#/ ? "$_\n" : "# $_\n" }
85            map { split /\n/ } @_;
86 }
87
88 use strict;
89 use warnings FATAL=>"all";
90 no warnings 'experimental::vlb';
91 our ($bang, $ffff, $nulnul); # used by the tests
92 our ($qr, $skip_amp, $qr_embed, $qr_embed_thr, $regex_sets, $alpha_assertions, $no_null); # set by our callers
93
94 my $expanded_text = "expanded name from original test number";
95 my $expanded_text_re = qr/$expanded_text/;
96
97 if (!defined $file) {
98     open TESTS, 're/re_tests' or die "Can't open re/re_tests: $!";
99 }
100
101 my @tests = <TESTS>;
102
103 close TESTS;
104
105 my $test_num = 0;
106
107 # Some scenarios add extra tests to those just read in.  For those where there
108 # is a character set translation, the added test will already have been
109 # translated, so any test number beginning with this one shouldn't be
110 # translated again.
111 my $first_already_converted_test_num = @tests + 1;
112
113 sub convert_from_ascii {
114     my $string = shift;
115
116     return $string if ord("A") == 65;
117     return $string if $test_num >= $first_already_converted_test_num;
118
119     #my $save = $string;
120     # Convert \x{...}, \o{...}
121     $string =~ s/ (?<! \\ ) \\x\{ ( .*? ) } / "\\x{" . sprintf("%X", utf8::unicode_to_native(hex $1)) .  "}" /gex;
122     $string =~ s/ (?<! \\ ) \\o\{ ( .*? ) } / "\\o{" . sprintf("%o", utf8::unicode_to_native(oct $1)) .  "}" /gex;
123
124     # Convert \xAB
125     $string =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9]{2} ) / "\\x" . sprintf("%02X", utf8::unicode_to_native(hex $1)) /gex;
126
127     # Convert \xA
128     $string =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9] ) (?! [A-Fa-f0-9] ) / "\\x" . sprintf("%X", utf8::unicode_to_native(hex $1)) /gex;
129
130     #print STDERR __LINE__, ": $save\n$string\n" if $save ne $string;
131     return $string;
132 }
133
134 $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
135 $ffff  = chr(0xff) x 2;
136 $nulnul = "\0" x 2;
137 my $OP = $qr ? 'qr' : 'm';
138
139 $| = 1;
140
141 TEST:
142 foreach (@tests) {
143     $test_num++;
144     if (!/\S/ || /^\s*#/ || /^__END__$/) {
145         chomp;
146         my ($not,$comment)= split /\s*#\s*/, $_, 2;
147         $comment ||= "(blank line)";
148         print "ok $test_num # $comment\n";
149         next;
150     }
151     chomp;
152     s/\\n/\n/g unless $regex_sets;
153     my ($pat, $subject, $result, $repl, $expect, $reason, $comment) = split(/\t/,$_,7);
154     $comment = "" unless defined $comment;
155     if (!defined $subject) {
156         die "Bad test definition on line $test_num: $_\n";
157     }
158     $reason = '' unless defined $reason;
159     my $input = join(':',$pat,$subject,$result,$repl,$expect);
160
161     # the double '' below keeps simple syntax highlighters from going crazy
162     $pat = "'$pat'" unless $pat =~ /^[:''\/]/; 
163     $pat =~ s/(\$\{\w+\})/$1/eeg;
164     $pat =~ s/\\n/\n/g unless $regex_sets;
165     $pat = convert_from_ascii($pat);
166
167     my $no_null_pat;
168     if ($no_null && $pat =~ /^'(.*)'\z/) {
169        $no_null_pat = XS::APItest::string_without_null($1);
170     }
171
172     $subject = convert_from_ascii($subject);
173     $subject = eval qq("$subject"); die $@ if $@;
174
175     $expect = convert_from_ascii($expect);
176     $expect  = eval qq("$expect"); die $@ if $@;
177     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
178
179     my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
180     my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
181     ++$skip if $result =~ s/M// && !defined &DynaLoader::boot_DynaLoader;
182     if ($result =~ s/ ( [Ss] ) //x) {
183         if (($1 eq 'S' && $regex_sets) || ($1 eq 's' && ! $regex_sets)) {
184             $skip++;
185             $reason = "Test not valid for $0";
186         }
187     }
188     if ($result =~ s/a// && ord("A") != 65) {
189         $skip++;
190         $reason = "Test is only valid for ASCII platforms.  $reason";
191     }
192     if ($result =~ s/e// && ord("A") != 193) {
193         $skip++;
194         $reason = "Test is only valid for EBCDIC platforms.  $reason";
195     }
196     $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
197     $result =~ s/B//i unless $skip;
198     my $todo= $result =~ s/T// ? " # TODO" : "";
199     my $testname= $test_num;
200     if ($comment) {
201         $comment=~s/^\s*(?:#\s*)?//;
202         $testname .= " - $comment" if $comment;
203     }
204     if (! $skip && $alpha_assertions) {
205         my $assertions_re = qr/ (?: \Q(?\E (?: > | <? [=>] ) ) /x;
206         if ($pat !~ $assertions_re && $comment !~ $expanded_text_re) {
207             $skip++;
208             $reason = "Pattern doesn't contain assertions";
209         }
210         elsif ($comment !~ $expanded_text_re) {
211             my $expanded_pat = $pat;
212
213             $pat =~ s/\( \? > /(*atomic:/xg;
214
215             if ($pat =~ s/\( \? = /(*pla:/xg) {
216                 $expanded_pat =~ s//(*positive_lookahead:/g;
217             }
218             if ($pat =~ s/\( \? ! /(*nla:/xg) {
219                 $expanded_pat =~ s//(*negative_lookahead:/g;
220             }
221             if ($pat =~ s/\( \? <= /(*plb:/xg) {
222                 $expanded_pat =~ s//(*positive_lookbehind:/g;
223             }
224             if ($pat =~ s/\( \? <! /(*nlb:/xg) {
225                 $expanded_pat =~ s//(*negative_lookbehind:/g;
226             }
227             if ($expanded_pat ne $pat) {
228                 $comment .= " $expanded_text $test_num";
229                 push @tests, join "\t", $expanded_pat,
230                                         $subject // "",
231                                         $result // "",
232                                         $repl // "",
233                                         $expect // "",
234                                         $reason // "",
235                                         $comment;
236             }
237         }
238     }
239     elsif (! $skip && $regex_sets) {
240
241         # If testing regex sets, change the [bracketed] classes into
242         # (?[bracketed]).  But note that '\[' and '\c[' don't introduce such a
243         # class.  (We don't bother looking for an odd number of backslashes,
244         # as this hasn't been needed so far.)
245         if ($pat !~ / (?<!\\c) (?<!\\) \[ /x) {
246             $skip++;
247             $reason = "Pattern doesn't contain [brackets]";
248         }
249         else { # Use non-regex features of Perl to accomplish this.
250             my $modified = "";
251             my $in_brackets = 0;
252
253             # Go through the pattern character-by-character.  We also add
254             # blanks around each token to test the /x parts of (?[ ])
255             my $pat_len = length($pat);
256       CHAR: for (my $i = 0; $i < $pat_len; $i++) {
257                 my $curchar = substr($pat, $i, 1);
258                 if ($curchar eq '\\') {
259                     $modified .= " " if $in_brackets;
260                     $modified .= $curchar;
261                     $i++;
262
263                     # Get the character the backslash is escaping
264                     $curchar = substr($pat, $i, 1);
265                     $modified .= $curchar;
266
267                     # If the character following that is a '{}', treat the
268                     # entire amount as a single token
269                     if ($i < $pat_len -1 && substr($pat, $i+1, 1) eq '{') {
270                         my $j = index($pat, '}', $i+2);
271                         if ($j < 0) {
272                             last unless $in_brackets;
273                             if ($result eq 'c') {
274                                 $skip++;
275                                 $reason = "Can't handle compilation errors with unmatched '{'";
276                             }
277                             else {
278                                 print "not ok $testname # Problem in $0; original = '$pat'; mod = '$modified'\n";
279                                 next TEST;
280                             }
281                         }
282                         $modified .= substr($pat, $i+1, $j - $i);
283                         $i = $j;
284                     }
285                     elsif ($curchar eq 'x') {
286
287                         # \x without brackets is supposed to be followed by 2
288                         # hex digits.  Take up to 2, and then add a blank
289                         # after the last one.  This avoids getting errors from
290                         # (?[ ]) for run-ons, like \xabc
291                         my $j = $i + 1;
292                         for (; $j < $i + 3 && $j < $pat_len; $j++) {
293                             my $curord = ord(substr($pat, $j, 1));
294                             if (!(($curord >= ord("A") && $curord <= ord("F"))
295                                  || ($curord >= ord("a") && $curord <= ord("f"))
296                                  || ($curord >= ord("0") && $curord <= ord("9"))))
297                             {
298                                 $j++;
299                                 last;
300                             }
301                         }
302                         $j--;
303                         $modified .= substr($pat, $i + 1, $j - $i);
304                         $modified .= " " if $in_brackets;
305                         $i = $j;
306                     }
307                     elsif (ord($curchar) >= ord('0')
308                            && (ord($curchar) <= ord('7')))
309                     {
310                         # Similarly, octal constants have up to 3 digits.
311                         my $j = $i + 1;
312                         for (; $j < $i + 3 && $j < $pat_len; $j++) {
313                             my $curord = ord(substr($pat, $j, 1));
314                             if (! ($curord >= ord("0") &&  $curord <= ord("7"))) {
315                                 $j++;
316                                 last;
317                             }
318                         }
319                         $j--;
320                         $modified .= substr($pat, $i + 1, $j - $i);
321                         $i = $j;
322                     }
323
324                     next;
325                 } # End of processing a backslash sequence
326
327                 if (! $in_brackets  # Skip (?{ })
328                     && $curchar eq '('
329                     && $i < $pat_len - 2
330                     && substr($pat, $i+1, 1) eq '?'
331                     && substr($pat, $i+2, 1) eq '{')
332                 {
333                     $skip++;
334                     $reason = "Pattern contains '(?{'";
335                     last;
336                 }
337
338                 # Closing ']'
339                 if ($curchar eq ']' && $in_brackets) {
340                     $modified .= " ] ])";
341                     $in_brackets = 0;
342                     next;
343                 }
344
345                 # A regular character.
346                 if ($curchar ne '[') {
347                     $modified .= " " if  $in_brackets;
348                     $modified .= $curchar;
349                     next;
350                 }
351
352                 # Here is a '['; If not in a bracketed class, treat as the
353                 # beginning of one.
354                 if (! $in_brackets) {
355                     $in_brackets = 1;
356                     $modified .= "(?[ [ ";
357
358                     # An immediately following ']' or '^]' is not the ending
359                     # of the class, but is to be treated literally.
360                     if ($i < $pat_len - 1
361                         && substr($pat, $i+1, 1) eq ']')
362                     {
363                         $i ++;
364                         $modified .= " ] ";
365                     }
366                     elsif ($i < $pat_len - 2
367                             && substr($pat, $i+1, 1) eq '^'
368                             && substr($pat, $i+2, 1) eq ']')
369                     {
370                         $i += 2;
371                         $modified .= " ^ ] ";
372                     }
373                     next;
374                 }
375
376                 # Here is a plain '[' within [ ].  Could mean wants to
377                 # match a '[', or it could be a posix class that has a
378                 # corresponding ']'.  Absorb either
379
380                 $modified .= ' [';
381                 last if $i >= $pat_len - 1;
382
383                 $i++;
384                 $curchar = substr($pat, $i, 1);
385                 if ($curchar =~ /[:=.]/) {
386                     for (my $j = $i + 1; $j < $pat_len; $j++) {
387                         next unless substr($pat, $j, 1) eq ']';
388                         last if $j - $i < 2;
389                         if (substr($pat, $j - 1, 1) eq $curchar) {
390                             # Here, is a posix class
391                             $modified .= substr($pat, $i, $j - $i + 1) . " ";
392                             $i = $j;
393                             next CHAR;
394                         }
395                     }
396                 }
397
398                 # Here wasn't a posix class, just process normally
399                 $modified .= " $curchar ";
400             }
401
402             if ($in_brackets && ! $skip) {
403                 if ($result eq 'c') {
404                     $skip++;
405                     $reason = "Can't figure out where to put the (?[ and ]) since is a compilation error";
406                 }
407                 else {
408                     print "not ok $testname # Problem in $0; original = '$pat'; mod = '$modified'\n";
409                     next TEST;
410                 }
411             }
412
413             # Use our modified pattern instead of the original
414             $pat = $modified;
415         }
416     }
417
418     for my $study ('', 'study $subject;', 'utf8::upgrade($subject);',
419                    'utf8::upgrade($subject); study $subject;') {
420         # Need to make a copy, else the utf8::upgrade of an already studied
421         # scalar confuses things.
422         my $subject = $subject;
423         $subject = XS::APItest::string_without_null($subject) if $no_null;
424         my $c = $iters;
425         my ($code, $match, $got);
426         if ($repl eq 'pos') {
427             my $patcode = defined $no_null_pat ? '/$no_null_pat/g'
428                                                : "m${pat}g";
429             $code= <<EOFCODE;
430                 $study
431                 pos(\$subject)=0;
432                 \$match = ( \$subject =~ $patcode );
433                 \$got = pos(\$subject);
434 EOFCODE
435         }
436         elsif ($qr_embed) {
437             $code= <<EOFCODE;
438                 my \$RE = qr$pat;
439                 $study
440                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
441                 \$got = "$repl";
442 EOFCODE
443         }
444         elsif ($qr_embed_thr) {
445             $code= <<EOFCODE;
446                 # Can't run the match in a subthread, but can do this and
447                 # clone the pattern the other way.
448                 my \$RE = threads->new(sub {qr$pat})->join();
449                 $study
450                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
451                 \$got = "$repl";
452 EOFCODE
453         }
454         elsif ($no_null) {
455             my $patcode = defined $no_null_pat ? '/$no_null_pat/'
456                                                :  $pat;
457             $code= <<EOFCODE;
458                 $study
459                 \$match = (\$subject =~ $OP$pat) while \$c--;
460                 \$got = "$repl";
461 EOFCODE
462         }
463         else {
464             $code= <<EOFCODE;
465                 $study
466                 \$match = (\$subject =~ $OP$pat) while \$c--;
467                 \$got = "$repl";
468 EOFCODE
469         }
470         $code = "no warnings 'experimental::regex_sets';$code" if $regex_sets;
471         #$code.=qq[\n\$expect="$expect";\n];
472         #use Devel::Peek;
473         #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
474         {
475             # Probably we should annotate specific tests with which warnings
476             # categories they're known to trigger, and hence should be
477             # disabled just for that test
478             no warnings qw(uninitialized regexp deprecated);
479             eval $code;
480         }
481         chomp( my $err = $@ );
482         if ( $skip ) {
483             print "ok $testname # skipped", length($reason) ? ".  $reason" : '', "\n";
484             next TEST;
485         }
486         elsif ($result eq 'c') {
487             if ($err !~ m!^\Q$expect!) { print "not ok $testname$todo (compile) $input => '$err'\n"; next TEST }
488             last;  # no need to study a syntax error
489         }
490         elsif ( $todo_qr ) {
491             print "not ok $testname # TODO", length($reason) ? " - $reason" : '', "\n";
492             next TEST;
493         }
494         elsif ($@) {
495             print "not ok $testname$todo $input => error '$err'\n", _comment("$code\n$@\n"); next TEST;
496         }
497         elsif ($result =~ /^n/) {
498             if ($match) { print "not ok $testname$todo ($study) $input => false positive\n"; next TEST }
499         }
500         else {
501             if (!$match || $got ne $expect) {
502                 eval { require Data::Dumper };
503                 no warnings "utf8"; # But handle should be utf8
504                 if ($@ || !defined &DynaLoader::boot_DynaLoader) {
505                     # Data::Dumper will load on miniperl, but fail when used in
506                     # anger as it tries to load B. I'd prefer to keep the
507                     # regular calls below outside of an eval so that real
508                     # (unknown) failures get spotted, not ignored.
509                     print "not ok $testname$todo ($study) $input => '$got', match=$match\n", _comment("$code\n");
510                 }
511                 else { # better diagnostics
512                     my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
513                     my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
514                     my $e = Data::Dumper->new([$expect],['expected'])->Useqq(1)->Dump;
515                     print "not ok $testname$todo ($study) $input => '$got', match=$match\n", _comment("$s\n$code\n$g\n$e\n");
516                 }
517                 next TEST;
518             }
519         }
520     }
521     print "ok $testname$todo\n";
522 }
523
524 printf "1..%d\n# $iters iterations\n", scalar @tests;
525
526 1;