gmtime/localtime are busted around 2**48
[perl.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 #
7 # Column 1 contains the pattern, optionally enclosed in C<''>.
8 # Modifiers can be put after the closing C<'>.
9 #
10 # Column 2 contains the string to be matched.
11 #
12 # Column 3 contains the expected result:
13 #       y       expect a match
14 #       n       expect no match
15 #       c       expect an error
16 #       T       the test is a TODO (can be combined with y/n/c)
17 #       B       test exposes a known bug in Perl, should be skipped
18 #       b       test exposes a known bug in Perl, should be skipped if noamp
19 #       t       test exposes a bug with threading, TODO if qr_embed_thr
20 #
21 # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
22 #
23 # Column 4 contains a string, usually C<$&>.
24 #
25 # Column 5 contains the expected result of double-quote
26 # interpolating that string after the match, or start of error message.
27 #
28 # Column 6, if present, contains a reason why the test is skipped.
29 # This is printed with "skipped", for harness to pick up.
30 #
31 # \n in the tests are interpolated, as are variables of the form ${\w+}.
32 #
33 # Blanks lines are treated as PASSING tests to keep the line numbers
34 # linked to the test number.
35 #
36 # If you want to add a regular expression test that can't be expressed
37 # in this format, don't add it here: put it in re/pat.t instead.
38 #
39 # Note that columns 2,3 and 5 are all enclosed in double quotes and then
40 # evalled; so something like a\"\x{100}$1 has length 3+length($1).
41
42 my $file;
43 BEGIN {
44     $iters = shift || 1;        # Poor man performance suite, 10000 is OK.
45
46     # Do this open before any chdir
47     $file = shift;
48     if (defined $file) {
49         open TESTS, $file or die "Can't open $file";
50     }
51
52     chdir 't' if -d 't';
53     @INC = '../lib';
54
55     if ($qr_embed_thr) {
56         require Config;
57         if (!$Config::Config{useithreads}) {
58             print "1..0 # Skip: no ithreads\n";
59                 exit 0;
60         }
61         if ($ENV{PERL_CORE_MINITEST}) {
62             print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
63                 exit 0;
64         }
65         require threads;
66     }
67 }
68
69 use strict;
70 use warnings FATAL=>"all";
71 use vars qw($iters $numtests $bang $ffff $nulnul $OP);
72 use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
73
74
75 if (!defined $file) {
76     open(TESTS,'re/re_tests') || open(TESTS,'t/re/re_tests')
77         || open(TESTS,':re:re_tests') || die "Can't open re_tests";
78 }
79
80 my @tests = <TESTS>;
81
82 close TESTS;
83
84 $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
85 $ffff  = chr(0xff) x 2;
86 $nulnul = "\0" x 2;
87 $OP = $qr ? 'qr' : 'm';
88
89 $| = 1;
90 printf "1..%d\n# $iters iterations\n", scalar @tests;
91
92 my $test;
93 TEST:
94 foreach (@tests) {
95     $test++;
96     if (!/\S/ || /^\s*#/ || /^__END__$/) {
97         print "ok $test # (Blank line or comment)\n";
98         if (/#/) { print $_ };
99         next;
100     }
101     chomp;
102     s/\\n/\n/g;
103     my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
104     $reason = '' unless defined $reason;
105     my $input = join(':',$pat,$subject,$result,$repl,$expect);
106     # the double '' below keeps simple syntax highlighters from going crazy
107     $pat = "'$pat'" unless $pat =~ /^[:''\/]/; 
108     $pat =~ s/(\$\{\w+\})/$1/eeg;
109     $pat =~ s/\\n/\n/g;
110     $subject = eval qq("$subject"); die $@ if $@;
111     $expect  = eval qq("$expect"); die $@ if $@;
112     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
113     my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
114     my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
115     $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
116     $result =~ s/B//i unless $skip;
117     my $todo= $result =~ s/T// ? " # TODO" : "";
118     
119
120     for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
121                    'utf8::upgrade($subject); study $subject') {
122         # Need to make a copy, else the utf8::upgrade of an alreay studied
123         # scalar confuses things.
124         my $subject = $subject;
125         my $c = $iters;
126         my ($code, $match, $got);
127         if ($repl eq 'pos') {
128             $code= <<EOFCODE;
129                 $study;
130                 pos(\$subject)=0;
131                 \$match = ( \$subject =~ m${pat}g );
132                 \$got = pos(\$subject);
133 EOFCODE
134         }
135         elsif ($qr_embed) {
136             $code= <<EOFCODE;
137                 my \$RE = qr$pat;
138                 $study;
139                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
140                 \$got = "$repl";
141 EOFCODE
142         }
143         elsif ($qr_embed_thr) {
144             $code= <<EOFCODE;
145                 # Can't run the match in a subthread, but can do this and
146                 # clone the pattern the other way.
147                 my \$RE = threads->new(sub {qr$pat})->join();
148                 $study;
149                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
150                 \$got = "$repl";
151 EOFCODE
152         }
153         else {
154             $code= <<EOFCODE;
155                 $study;
156                 \$match = (\$subject =~ $OP$pat) while \$c--;
157                 \$got = "$repl";
158 EOFCODE
159         }
160         #$code.=qq[\n\$expect="$expect";\n];
161         #use Devel::Peek;
162         #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
163         {
164             # Probably we should annotate specific tests with which warnings
165             # categories they're known to trigger, and hence should be
166             # disabled just for that test
167             no warnings qw(uninitialized regexp);
168             eval $code;
169         }
170         chomp( my $err = $@ );
171         if ($result eq 'c') {
172             if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => `$err'\n"; next TEST }
173             last;  # no need to study a syntax error
174         }
175         elsif ( $skip ) {
176             print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
177             next TEST;
178         }
179         elsif ( $todo_qr ) {
180             print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n";
181             next TEST;
182         }
183         elsif ($@) {
184             print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST;
185         }
186         elsif ($result =~ /^n/) {
187             if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST }
188         }
189         else {
190             if (!$match || $got ne $expect) {
191                 eval { require Data::Dumper };
192                 if ($@) {
193                     print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n";
194                 }
195                 else { # better diagnostics
196                     my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
197                     my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
198                     print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n";
199                 }
200                 next TEST;
201             }
202         }
203     }
204     print "ok $test$todo\n";
205 }
206
207 1;