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 | |
e4d48cc9 |
40 | BEGIN { |
41 | chdir 't' if -d 't'; |
20822f61 |
42 | @INC = '../lib'; |
e4d48cc9 |
43 | } |
44 | |
c277df42 |
45 | $iters = shift || 1; # Poor man performance suite, 10000 is OK. |
ad4f75a6 |
46 | |
95e8664e |
47 | open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || open(TESTS,':op:re_tests') || |
8d37f932 |
48 | die "Can't open re_tests"; |
cfa4f241 |
49 | |
378cc40b |
50 | while (<TESTS>) { } |
51 | $numtests = $.; |
cfa4f241 |
52 | seek(TESTS,0,0); |
53 | $. = 0; |
378cc40b |
54 | |
9d116dd7 |
55 | $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. |
b8c5462f |
56 | $ffff = chr(0xff) x 2; |
57 | $nulnul = "\0" x 2; |
7fba1cd6 |
58 | $OP = $qr ? 'qr' : 'm'; |
9d116dd7 |
59 | |
1462b684 |
60 | $| = 1; |
c277df42 |
61 | print "1..$numtests\n# $iters iterations\n"; |
cfa4f241 |
62 | TEST: |
378cc40b |
63 | while (<TESTS>) { |
b9b4dddf |
64 | if (!/\S/ || /^\s*#/) { |
65 | print "ok $. # (Blank line or comment)\n"; |
66 | if (/\S/) { print $_ }; |
67 | next; |
68 | } |
b85d18e9 |
69 | chomp; |
70 | s/\\n/\n/g; |
ee595aa6 |
71 | ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); |
378cc40b |
72 | $input = join(':',$pat,$subject,$result,$repl,$expect); |
83e898de |
73 | infty_subst(\$pat); |
74 | infty_subst(\$expect); |
81714fb9 |
75 | $pat = "'$pat'" unless $pat =~ /^[:'\/]/; |
9d116dd7 |
76 | $pat =~ s/(\$\{\w+\})/$1/eeg; |
b8c5462f |
77 | $pat =~ s/\\n/\n/g; |
b2a156bd |
78 | $subject = eval qq("$subject"); |
79 | $expect = eval qq("$expect"); |
c277df42 |
80 | $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; |
cf93c79d |
81 | $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); |
906e884f |
82 | $reason = 'skipping $&' if $reason eq '' && $skip_amp; |
cf93c79d |
83 | $result =~ s/B//i unless $skip; |
1de06328 |
84 | |
85 | for $study ('', 'study $subject') { |
c277df42 |
86 | $c = $iters; |
1de06328 |
87 | if ($repl eq 'pos') { |
88 | $code= <<EOFCODE; |
89 | $study; |
90 | pos(\$subject)=0; |
91 | \$match = ( \$subject =~ m${pat}g ); |
92 | \$got = pos(\$subject); |
93 | EOFCODE |
94 | } |
95 | elsif ($qr_embed) { |
96 | $code= <<EOFCODE; |
97 | my \$RE = qr$pat; |
98 | $study; |
99 | \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--; |
100 | \$got = "$repl"; |
101 | EOFCODE |
102 | } |
103 | else { |
104 | $code= <<EOFCODE; |
105 | $study; |
106 | \$match = (\$subject =~ $OP$pat$addg) while \$c--; |
107 | \$got = "$repl"; |
108 | EOFCODE |
109 | } |
110 | eval $code; |
c277df42 |
111 | chomp( $err = $@ ); |
cfa4f241 |
112 | if ($result eq 'c') { |
c277df42 |
113 | if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST } |
cfa4f241 |
114 | last; # no need to study a syntax error |
115 | } |
cf93c79d |
116 | elsif ( $skip ) { |
ee595aa6 |
117 | print "ok $. # skipped", length($reason) ? " $reason" : '', "\n"; |
118 | next TEST; |
cf93c79d |
119 | } |
c277df42 |
120 | elsif ($@) { |
1de06328 |
121 | print "not ok $. $input => error `$err'\n$code\n$@\n"; next TEST; |
c277df42 |
122 | } |
cfa4f241 |
123 | elsif ($result eq 'n') { |
c277df42 |
124 | if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST } |
378cc40b |
125 | } |
126 | else { |
cfa4f241 |
127 | if (!$match || $got ne $expect) { |
1de06328 |
128 | print "not ok $. ($study) $input => `$got', match=$match\n$code\n"; |
cfa4f241 |
129 | next TEST; |
130 | } |
378cc40b |
131 | } |
132 | } |
cfa4f241 |
133 | print "ok $.\n"; |
378cc40b |
134 | } |
cfa4f241 |
135 | |
378cc40b |
136 | close(TESTS); |
83e898de |
137 | |
138 | sub infty_subst # Special-case substitution |
139 | { # of $reg_infty and friends |
140 | my $tp = shift; |
141 | $$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o; |
142 | $$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o; |
143 | $$tp =~ s/,\$reg_infty}/,$reg_infty}/o; |
144 | } |