Commit | Line | Data |
378cc40b |
1 | #!./perl |
2 | |
ad4f75a6 |
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 |
cf93c79d |
16 | # B test exposes a known bug in Perl, should be skipped |
17 | # b test exposes a known bug in Perl, should be skipped if noamp |
ad4f75a6 |
18 | # |
1b1626e4 |
19 | # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>. |
ad4f75a6 |
20 | # |
21 | # Column 4 contains a string, usually C<$&>. |
22 | # |
23 | # Column 5 contains the expected result of double-quote |
c277df42 |
24 | # interpolating that string after the match, or start of error message. |
25 | # |
ee595aa6 |
26 | # Column 6, if present, contains a reason why the test is skipped. |
27 | # This is printed with "skipped", for harness to pick up. |
28 | # |
9d116dd7 |
29 | # \n in the tests are interpolated, as are variables of the form ${\w+}. |
83e898de |
30 | # |
b9b4dddf |
31 | # Blanks lines are treated as PASSING tests to keep the line numbers |
32 | # linked to the test number. |
33 | # |
8d37f932 |
34 | # If you want to add a regular expression test that can't be expressed |
35 | # in this format, don't add it here: put it in op/pat.t instead. |
b2a156bd |
36 | # |
37 | # Note that columns 2,3 and 5 are all enclosed in double quotes and then |
38 | # evalled; so something like a\"\x{100}$1 has length 3+length($1). |
c277df42 |
39 | |
1a610890 |
40 | my $file; |
e4d48cc9 |
41 | BEGIN { |
1a610890 |
42 | $iters = shift || 1; # Poor man performance suite, 10000 is OK. |
43 | |
44 | # Do this open before any chdir |
45 | $file = shift; |
46 | if (defined $file) { |
47 | open TESTS, $file or die "Can't open $file"; |
48 | } |
49 | |
e4d48cc9 |
50 | chdir 't' if -d 't'; |
20822f61 |
51 | @INC = '../lib'; |
e4d48cc9 |
52 | } |
1a610890 |
53 | |
1286eaeb |
54 | use strict; |
66fb63c1 |
55 | use warnings FATAL=>"all"; |
1286eaeb |
56 | use vars qw($iters $numtests $bang $ffff $nulnul $OP); |
57 | use vars qw($qr $skip_amp $qr_embed); # set by our callers |
e4d48cc9 |
58 | |
ad4f75a6 |
59 | |
1a610890 |
60 | if (!defined $file) { |
61 | open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') |
62 | || open(TESTS,':op:re_tests') || die "Can't open re_tests"; |
63 | } |
64 | |
65 | my @tests = <TESTS>; |
cfa4f241 |
66 | |
1a610890 |
67 | close TESTS; |
378cc40b |
68 | |
9d116dd7 |
69 | $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. |
b8c5462f |
70 | $ffff = chr(0xff) x 2; |
71 | $nulnul = "\0" x 2; |
7fba1cd6 |
72 | $OP = $qr ? 'qr' : 'm'; |
9d116dd7 |
73 | |
1462b684 |
74 | $| = 1; |
1a610890 |
75 | printf "1..%d\n# $iters iterations\n", scalar @tests; |
76 | my $test; |
cfa4f241 |
77 | TEST: |
1a610890 |
78 | foreach (@tests) { |
79 | $test++; |
b9b4dddf |
80 | if (!/\S/ || /^\s*#/) { |
1a610890 |
81 | print "ok $test # (Blank line or comment)\n"; |
b9b4dddf |
82 | if (/\S/) { print $_ }; |
83 | next; |
84 | } |
b85d18e9 |
85 | chomp; |
86 | s/\\n/\n/g; |
1286eaeb |
87 | my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); |
66fb63c1 |
88 | $reason = '' unless defined $reason; |
1286eaeb |
89 | my $input = join(':',$pat,$subject,$result,$repl,$expect); |
81714fb9 |
90 | $pat = "'$pat'" unless $pat =~ /^[:'\/]/; |
9d116dd7 |
91 | $pat =~ s/(\$\{\w+\})/$1/eeg; |
b8c5462f |
92 | $pat =~ s/\\n/\n/g; |
1a610890 |
93 | $subject = eval qq("$subject"); die $@ if $@; |
94 | $expect = eval qq("$expect"); die $@ if $@; |
c277df42 |
95 | $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; |
1286eaeb |
96 | my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); |
906e884f |
97 | $reason = 'skipping $&' if $reason eq '' && $skip_amp; |
cf93c79d |
98 | $result =~ s/B//i unless $skip; |
1de06328 |
99 | |
52e33015 |
100 | for my $study ('', 'study $subject', 'utf8::upgrade($subject)', |
101 | 'utf8::upgrade($subject); study $subject') { |
102 | # Need to make a copy, else the utf8::upgrade of an alreay studied |
103 | # scalar confuses things. |
104 | my $subject = $subject; |
1286eaeb |
105 | my $c = $iters; |
106 | my ($code, $match, $got); |
1de06328 |
107 | if ($repl eq 'pos') { |
108 | $code= <<EOFCODE; |
109 | $study; |
110 | pos(\$subject)=0; |
111 | \$match = ( \$subject =~ m${pat}g ); |
112 | \$got = pos(\$subject); |
113 | EOFCODE |
114 | } |
115 | elsif ($qr_embed) { |
116 | $code= <<EOFCODE; |
117 | my \$RE = qr$pat; |
118 | $study; |
119 | \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--; |
120 | \$got = "$repl"; |
121 | EOFCODE |
122 | } |
123 | else { |
124 | $code= <<EOFCODE; |
125 | $study; |
1286eaeb |
126 | \$match = (\$subject =~ $OP$pat) while \$c--; |
1de06328 |
127 | \$got = "$repl"; |
128 | EOFCODE |
129 | } |
e1d1eefb |
130 | #$code.=qq[\n\$expect="$expect";\n]; |
131 | #use Devel::Peek; |
132 | #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/; |
66fb63c1 |
133 | { |
134 | # Probably we should annotate specific tests with which warnings |
135 | # categories they're known to trigger, and hence should be |
136 | # disabled just for that test |
137 | no warnings qw(uninitialized regexp); |
138 | eval $code; |
139 | } |
1286eaeb |
140 | chomp( my $err = $@ ); |
cfa4f241 |
141 | if ($result eq 'c') { |
1a610890 |
142 | if ($err !~ m!^\Q$expect!) { print "not ok $test (compile) $input => `$err'\n"; next TEST } |
cfa4f241 |
143 | last; # no need to study a syntax error |
144 | } |
cf93c79d |
145 | elsif ( $skip ) { |
1a610890 |
146 | print "ok $test # skipped", length($reason) ? " $reason" : '', "\n"; |
ee595aa6 |
147 | next TEST; |
cf93c79d |
148 | } |
c277df42 |
149 | elsif ($@) { |
1a610890 |
150 | print "not ok $test $input => error `$err'\n$code\n$@\n"; next TEST; |
c277df42 |
151 | } |
cfa4f241 |
152 | elsif ($result eq 'n') { |
1a610890 |
153 | if ($match) { print "not ok $test ($study) $input => false positive\n"; next TEST } |
378cc40b |
154 | } |
155 | else { |
cfa4f241 |
156 | if (!$match || $got ne $expect) { |
cde0cee5 |
157 | eval { require Data::Dumper }; |
158 | if ($@) { |
1a610890 |
159 | print "not ok $test ($study) $input => `$got', match=$match\n$code\n"; |
cde0cee5 |
160 | } |
161 | else { # better diagnostics |
162 | my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump; |
163 | my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump; |
1a610890 |
164 | print "not ok $test ($study) $input => `$got', match=$match\n$s\n$g\n$code\n"; |
cde0cee5 |
165 | } |
cfa4f241 |
166 | next TEST; |
167 | } |
378cc40b |
168 | } |
169 | } |
1a610890 |
170 | print "ok $test\n"; |
378cc40b |
171 | } |
cfa4f241 |
172 | |
1a610890 |
173 | 1; |