Commit | Line | Data |
378cc40b |
1 | #!./perl |
2 | |
9c63abab |
3 | # XXX known to leak scalars |
4 | $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; |
eec2d3df |
5 | |
ad4f75a6 |
6 | # The tests are in a separate file 't/op/re_tests'. |
7 | # Each line in that file is a separate test. |
8 | # There are five columns, separated by tabs. |
9 | # |
10 | # Column 1 contains the pattern, optionally enclosed in C<''>. |
11 | # Modifiers can be put after the closing C<'>. |
12 | # |
13 | # Column 2 contains the string to be matched. |
14 | # |
15 | # Column 3 contains the expected result: |
16 | # y expect a match |
17 | # n expect no match |
18 | # c expect an error |
cf93c79d |
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 |
ad4f75a6 |
21 | # |
1b1626e4 |
22 | # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>. |
ad4f75a6 |
23 | # |
24 | # Column 4 contains a string, usually C<$&>. |
25 | # |
26 | # Column 5 contains the expected result of double-quote |
c277df42 |
27 | # interpolating that string after the match, or start of error message. |
28 | # |
9d116dd7 |
29 | # \n in the tests are interpolated, as are variables of the form ${\w+}. |
83e898de |
30 | # |
8d37f932 |
31 | # If you want to add a regular expression test that can't be expressed |
32 | # in this format, don't add it here: put it in op/pat.t instead. |
c277df42 |
33 | |
e4d48cc9 |
34 | BEGIN { |
35 | chdir 't' if -d 't'; |
93430cb4 |
36 | unshift @INC, '../lib' if -d '../lib'; |
e4d48cc9 |
37 | } |
38 | |
c277df42 |
39 | $iters = shift || 1; # Poor man performance suite, 10000 is OK. |
ad4f75a6 |
40 | |
8d37f932 |
41 | open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || |
42 | die "Can't open re_tests"; |
cfa4f241 |
43 | |
378cc40b |
44 | while (<TESTS>) { } |
45 | $numtests = $.; |
cfa4f241 |
46 | seek(TESTS,0,0); |
47 | $. = 0; |
378cc40b |
48 | |
9d116dd7 |
49 | $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. |
50 | |
1462b684 |
51 | $| = 1; |
c277df42 |
52 | print "1..$numtests\n# $iters iterations\n"; |
cfa4f241 |
53 | TEST: |
378cc40b |
54 | while (<TESTS>) { |
b85d18e9 |
55 | chomp; |
56 | s/\\n/\n/g; |
57 | ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_); |
378cc40b |
58 | $input = join(':',$pat,$subject,$result,$repl,$expect); |
83e898de |
59 | infty_subst(\$pat); |
60 | infty_subst(\$expect); |
1b1626e4 |
61 | $pat = "'$pat'" unless $pat =~ /^[:']/; |
c277df42 |
62 | $pat =~ s/\\n/\n/g; |
9d116dd7 |
63 | $pat =~ s/(\$\{\w+\})/$1/eeg; |
c277df42 |
64 | $subject =~ s/\\n/\n/g; |
65 | $expect =~ s/\\n/\n/g; |
66 | $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; |
cf93c79d |
67 | $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); |
68 | $result =~ s/B//i unless $skip; |
69 | for $study ('', 'study \$subject') { |
c277df42 |
70 | $c = $iters; |
71 | eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";"; |
72 | chomp( $err = $@ ); |
cfa4f241 |
73 | if ($result eq 'c') { |
c277df42 |
74 | if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST } |
cfa4f241 |
75 | last; # no need to study a syntax error |
76 | } |
cf93c79d |
77 | elsif ( $skip ) { |
78 | print "ok $. # Skipped: not fixed yet\n"; next TEST; |
79 | } |
c277df42 |
80 | elsif ($@) { |
81 | print "not ok $. $input => error `$err'\n"; next TEST; |
82 | } |
cfa4f241 |
83 | elsif ($result eq 'n') { |
c277df42 |
84 | if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST } |
378cc40b |
85 | } |
86 | else { |
cfa4f241 |
87 | if (!$match || $got ne $expect) { |
c277df42 |
88 | print "not ok $. ($study) $input => `$got', match=$match\n"; |
cfa4f241 |
89 | next TEST; |
90 | } |
378cc40b |
91 | } |
92 | } |
cfa4f241 |
93 | print "ok $.\n"; |
378cc40b |
94 | } |
cfa4f241 |
95 | |
378cc40b |
96 | close(TESTS); |
83e898de |
97 | |
98 | sub infty_subst # Special-case substitution |
99 | { # of $reg_infty and friends |
100 | my $tp = shift; |
101 | $$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o; |
102 | $$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o; |
103 | $$tp =~ s/,\$reg_infty}/,$reg_infty}/o; |
104 | } |