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 | |
16 | # | |
1b1626e4 | 17 | # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>. |
ad4f75a6 HM |
18 | # |
19 | # Column 4 contains a string, usually C<$&>. | |
20 | # | |
21 | # Column 5 contains the expected result of double-quote | |
c277df42 IZ |
22 | # interpolating that string after the match, or start of error message. |
23 | # | |
b85d18e9 | 24 | # \n in the tests are interpolated. |
83e898de | 25 | # |
8d37f932 DD |
26 | # If you want to add a regular expression test that can't be expressed |
27 | # in this format, don't add it here: put it in op/pat.t instead. | |
c277df42 IZ |
28 | |
29 | $iters = shift || 1; # Poor man performance suite, 10000 is OK. | |
ad4f75a6 | 30 | |
8d37f932 DD |
31 | open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || |
32 | die "Can't open re_tests"; | |
cfa4f241 | 33 | |
378cc40b LW |
34 | while (<TESTS>) { } |
35 | $numtests = $.; | |
cfa4f241 CS |
36 | seek(TESTS,0,0); |
37 | $. = 0; | |
378cc40b | 38 | |
1462b684 | 39 | $| = 1; |
c277df42 | 40 | print "1..$numtests\n# $iters iterations\n"; |
cfa4f241 | 41 | TEST: |
378cc40b | 42 | while (<TESTS>) { |
b85d18e9 IZ |
43 | chomp; |
44 | s/\\n/\n/g; | |
45 | ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_); | |
378cc40b | 46 | $input = join(':',$pat,$subject,$result,$repl,$expect); |
83e898de DD |
47 | infty_subst(\$pat); |
48 | infty_subst(\$expect); | |
1b1626e4 | 49 | $pat = "'$pat'" unless $pat =~ /^[:']/; |
c277df42 IZ |
50 | $pat =~ s/\\n/\n/g; |
51 | $subject =~ s/\\n/\n/g; | |
52 | $expect =~ s/\\n/\n/g; | |
53 | $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; | |
ad4f75a6 | 54 | for $study ("", "study \$subject") { |
c277df42 IZ |
55 | $c = $iters; |
56 | eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";"; | |
57 | chomp( $err = $@ ); | |
cfa4f241 | 58 | if ($result eq 'c') { |
c277df42 | 59 | if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST } |
cfa4f241 CS |
60 | last; # no need to study a syntax error |
61 | } | |
c277df42 IZ |
62 | elsif ($@) { |
63 | print "not ok $. $input => error `$err'\n"; next TEST; | |
64 | } | |
cfa4f241 | 65 | elsif ($result eq 'n') { |
c277df42 | 66 | if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST } |
378cc40b LW |
67 | } |
68 | else { | |
cfa4f241 | 69 | if (!$match || $got ne $expect) { |
c277df42 | 70 | print "not ok $. ($study) $input => `$got', match=$match\n"; |
cfa4f241 CS |
71 | next TEST; |
72 | } | |
378cc40b LW |
73 | } |
74 | } | |
cfa4f241 | 75 | print "ok $.\n"; |
378cc40b | 76 | } |
cfa4f241 | 77 | |
378cc40b | 78 | close(TESTS); |
83e898de DD |
79 | |
80 | sub infty_subst # Special-case substitution | |
81 | { # of $reg_infty and friends | |
82 | my $tp = shift; | |
83 | $$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o; | |
84 | $$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o; | |
85 | $$tp =~ s/,\$reg_infty}/,$reg_infty}/o; | |
86 | } |