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