Commit | Line | Data |
---|---|---|
378cc40b LW |
1 | #!./perl |
2 | ||
ad4f75a6 HM |
3 | # The tests are in a separate file 't/op/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 | |
24d786f4 | 16 | # T the test is a TODO (can be combined with y/n/c) |
cf93c79d IZ |
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 | |
e3faa678 | 19 | # t test exposes a bug with threading, TODO if qr_embed_thr |
ad4f75a6 | 20 | # |
1b1626e4 | 21 | # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>. |
ad4f75a6 HM |
22 | # |
23 | # Column 4 contains a string, usually C<$&>. | |
24 | # | |
25 | # Column 5 contains the expected result of double-quote | |
c277df42 IZ |
26 | # interpolating that string after the match, or start of error message. |
27 | # | |
ee595aa6 LC |
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 | # | |
9d116dd7 | 31 | # \n in the tests are interpolated, as are variables of the form ${\w+}. |
83e898de | 32 | # |
b9b4dddf YO |
33 | # Blanks lines are treated as PASSING tests to keep the line numbers |
34 | # linked to the test number. | |
35 | # | |
8d37f932 DD |
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 op/pat.t instead. | |
b2a156bd DM |
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). | |
c277df42 | 41 | |
1a610890 | 42 | my $file; |
e4d48cc9 | 43 | BEGIN { |
1a610890 NC |
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 | ||
e4d48cc9 | 52 | chdir 't' if -d 't'; |
20822f61 | 53 | @INC = '../lib'; |
e3faa678 NC |
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 | } | |
e4d48cc9 | 67 | } |
1a610890 | 68 | |
1286eaeb | 69 | use strict; |
66fb63c1 | 70 | use warnings FATAL=>"all"; |
1286eaeb | 71 | use vars qw($iters $numtests $bang $ffff $nulnul $OP); |
e3faa678 | 72 | use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers |
e4d48cc9 | 73 | |
ad4f75a6 | 74 | |
1a610890 NC |
75 | if (!defined $file) { |
76 | open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') | |
77 | || open(TESTS,':op:re_tests') || die "Can't open re_tests"; | |
78 | } | |
79 | ||
80 | my @tests = <TESTS>; | |
cfa4f241 | 81 | |
1a610890 | 82 | close TESTS; |
378cc40b | 83 | |
9d116dd7 | 84 | $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. |
b8c5462f JH |
85 | $ffff = chr(0xff) x 2; |
86 | $nulnul = "\0" x 2; | |
7fba1cd6 | 87 | $OP = $qr ? 'qr' : 'm'; |
9d116dd7 | 88 | |
1462b684 | 89 | $| = 1; |
1a610890 | 90 | printf "1..%d\n# $iters iterations\n", scalar @tests; |
e3faa678 | 91 | |
1a610890 | 92 | my $test; |
cfa4f241 | 93 | TEST: |
1a610890 NC |
94 | foreach (@tests) { |
95 | $test++; | |
5a51db05 | 96 | if (!/\S/ || /^\s*#/ || /^__END__$/) { |
1a610890 | 97 | print "ok $test # (Blank line or comment)\n"; |
5a51db05 | 98 | if (/#/) { print $_ }; |
b9b4dddf YO |
99 | next; |
100 | } | |
b85d18e9 IZ |
101 | chomp; |
102 | s/\\n/\n/g; | |
1286eaeb | 103 | my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); |
66fb63c1 | 104 | $reason = '' unless defined $reason; |
1286eaeb | 105 | my $input = join(':',$pat,$subject,$result,$repl,$expect); |
24d786f4 YO |
106 | # the double '' below keeps simple syntax highlighters from going crazy |
107 | $pat = "'$pat'" unless $pat =~ /^[:''\/]/; | |
9d116dd7 | 108 | $pat =~ s/(\$\{\w+\})/$1/eeg; |
b8c5462f | 109 | $pat =~ s/\\n/\n/g; |
1a610890 NC |
110 | $subject = eval qq("$subject"); die $@ if $@; |
111 | $expect = eval qq("$expect"); die $@ if $@; | |
c277df42 | 112 | $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; |
24d786f4 | 113 | my $todo_qr = $qr_embed_thr && ($result =~ s/t//); |
1286eaeb | 114 | my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); |
906e884f | 115 | $reason = 'skipping $&' if $reason eq '' && $skip_amp; |
cf93c79d | 116 | $result =~ s/B//i unless $skip; |
24d786f4 YO |
117 | my $todo= $result =~ s/T// ? " # TODO" : ""; |
118 | ||
1de06328 | 119 | |
52e33015 NC |
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; | |
1286eaeb NC |
125 | my $c = $iters; |
126 | my ($code, $match, $got); | |
1de06328 YO |
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 | } | |
e3faa678 NC |
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 | } | |
1de06328 YO |
153 | else { |
154 | $code= <<EOFCODE; | |
155 | $study; | |
1286eaeb | 156 | \$match = (\$subject =~ $OP$pat) while \$c--; |
1de06328 YO |
157 | \$got = "$repl"; |
158 | EOFCODE | |
159 | } | |
e1d1eefb YO |
160 | #$code.=qq[\n\$expect="$expect";\n]; |
161 | #use Devel::Peek; | |
162 | #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/; | |
66fb63c1 NC |
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 | } | |
1286eaeb | 170 | chomp( my $err = $@ ); |
cfa4f241 | 171 | if ($result eq 'c') { |
24d786f4 | 172 | if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => `$err'\n"; next TEST } |
cfa4f241 CS |
173 | last; # no need to study a syntax error |
174 | } | |
cf93c79d | 175 | elsif ( $skip ) { |
1a610890 | 176 | print "ok $test # skipped", length($reason) ? " $reason" : '', "\n"; |
ee595aa6 | 177 | next TEST; |
cf93c79d | 178 | } |
24d786f4 | 179 | elsif ( $todo_qr ) { |
e0892690 | 180 | print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n"; |
e3faa678 NC |
181 | next TEST; |
182 | } | |
c277df42 | 183 | elsif ($@) { |
24d786f4 | 184 | print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST; |
c277df42 | 185 | } |
e3faa678 | 186 | elsif ($result =~ /^n/) { |
24d786f4 | 187 | if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST } |
378cc40b LW |
188 | } |
189 | else { | |
cfa4f241 | 190 | if (!$match || $got ne $expect) { |
cde0cee5 YO |
191 | eval { require Data::Dumper }; |
192 | if ($@) { | |
24d786f4 | 193 | print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n"; |
cde0cee5 YO |
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; | |
24d786f4 | 198 | print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n"; |
cde0cee5 | 199 | } |
cfa4f241 CS |
200 | next TEST; |
201 | } | |
378cc40b LW |
202 | } |
203 | } | |
24d786f4 | 204 | print "ok $test$todo\n"; |
378cc40b | 205 | } |
cfa4f241 | 206 | |
1a610890 | 207 | 1; |