This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: enhanced(?) regex error messages
[perl5.git] / t / op / regmesg.t
CommitLineData
b45f050a
JF
1#!./perl -w
2
3BEGIN {
4 chdir 't' if -d 't';
5 unshift @INC, '../lib';
6}
7
8my $debug = 1;
9
10##
11## If the markers used are changed (search for "MARKER1" in regcomp.c),
12## update only these two variables, and leave the {#} in the @death/@warning
13## arrays below. The {#} is a meta-marker -- it marks where the marker should
14## go.
15
16my $marker1 = "<HERE<";
17my $marker2 = " <<<HERE<<< ";
18
19##
20## Key-value pairs of code/error of code that should have fatal errors.
21##
22my @death =
23(
24 '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions at {#} mark in regex m/[[=foo=]{#}]/',
25
26 '/(?<= .*)/' => 'Variable length lookbehind not implemented at {#} mark in regex m/(?<= .*){#}/',
27
28 '/(?<= x{10000})/' => 'Lookbehind longer than 255 not implemented at {#} mark in regex m/(?<= x{10000}){#}/',
29
30 '/(?@)/' => 'Sequence (?@...) not implemented at {#} mark in regex m/(?@{#})/',
31
32 '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced at {#} mark in regex m/(?{{#} 1/',
33
34 '/(?(1x))/' => 'Switch condition not recognized at {#} mark in regex m/(?(1x{#}))/',
35
36 '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches at {#} mark in regex m/(?(1)x|y|{#}z)/',
37
38 '/(?(x)y|x)/' => 'Unknown switch condition (?(x) at {#} mark in regex m/(?({#}x)y|x)/',
39
40 '/(?/' => 'Sequence (? incomplete at {#} mark in regex m/(?{#}/',
41
42 '/(?;x/' => 'Sequence (?;...) not recognized at {#} mark in regex m/(?;{#}x/',
43 '/(?<;x/' => 'Sequence (?<;...) not recognized at {#} mark in regex m/(?<;{#}x/',
44
45 '/((x)/' => 'Unmatched ( at {#} mark in regex m/({#}(x)/',
46
47 '/x{99999}/' => 'Quantifier in {,} bigger than 32766 at {#} mark in regex m/x{{#}99999}/',
48
49 '/x{3,1}/' => 'Can\'t do {n,m} with n > m at {#} mark in regex m/x{3,1}{#}/',
50
51 '/x**/' => 'Nested quantifiers at {#} mark in regex m/x**{#}/',
52
53 '/x[/' => 'Unmatched [ at {#} mark in regex m/x[{#}/',
54
55 '/*/', => 'Quantifier follows nothing at {#} mark in regex m/*{#}/',
56
57 '/\p{x/' => 'Missing right brace on \p{} at {#} mark in regex m/\p{{#}x/',
58
59 'use utf8; /[\p{x]/' => 'Missing right brace on \p{} at {#} mark in regex m/[\p{{#}x]/',
60
61 '/(x)\2/' => 'Reference to nonexistent group at {#} mark in regex m/(x)\2{#}/',
62
63 'my $m = chr(92); $m =~ $m', => 'Trailing \ in regex m/\/',
64
65 '/\x{1/' => 'Missing right brace on \x{} at {#} mark in regex m/\x{{#}1/',
66
67 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} at {#} mark in regex m/[\x{{#}X]/',
68
69 '/\x{x}/' => 'Can\'t use \x{} without \'use utf8\' declaration at {#} mark in regex m/\x{x}{#}/',
70
71 '/[[:barf:]]/' => 'POSIX class [:barf:] unknown at {#} mark in regex m/[[:barf:]{#}]/',
72
73 '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions at {#} mark in regex m/[[=barf=]{#}]/',
74
75 '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions at {#} mark in regex m/[[.barf.]{#}]/',
76
77 '/[z-a]/' => 'Invalid [] range "z-a" at {#} mark in regex m/[z-a{#}]/',
78);
79
80##
81## Key-value pairs of code/error of code that should have non-fatal warnings.
82##
83@warning = (
84 "m/(?p{ 'a' })/" => "(?p{}) is deprecated - use (??{}) at {#} mark in regex m/(?p{#}{ 'a' })/",
85
86 'm/\b*/' => '\b* matches null string many times at {#} mark in regex m/\b*{#}/',
87
88 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes at {#} mark in regex m/[:blank:]{#}/',
89
90 "m'[\\y]'" => 'Unrecognized escape \y in character class passed through at {#} mark in regex m/[\y{#}]/',
91
92 'm/[a-\d]/' => 'False [] range "a-\d" at {#} mark in regex m/[a-\d{#}]/',
93 'm/[\w-x]/' => 'False [] range "\w-" at {#} mark in regex m/[\w-{#}x]/',
94 "m'\\y'" => 'Unrecognized escape \y passed through at {#} mark in regex m/\y{#}/',
95);
96
97my $total = (@death + @warning)/2;
98
99print "1..$total\n";
100
101my $count = 0;
102
103while (@death)
104{
105 $count++;
106 my $regex = shift @death;
107 my $result = shift @death;
108
109 undef $@;
110 $_ = "x";
111 eval $regex;
112 if (not $@) {
113 if ($debug) {
114 print "oops, $regex didn't die\n"
115 } else {
116 print "not ok $count\n";
117 }
118 next;
119 }
120 chomp $@;
121 $@ =~ s/ at \(.*?\) line \d+\.$//;
122 $result =~ s/{\#}/$marker1/;
123 $result =~ s/{\#}/$marker2/;
124 if ($@ ne $result) {
125 if ($debug) {
126 print "For $regex, expected:\n $result\nGot:\n $@\n\n";
127 } else {
128 print "not ok $count\n";
129 }
130 next;
131 }
132 print "ok $count\n";
133}
134
135
136our $warning;
137$SIG{__WARN__} = sub { $warning = shift };
138
139while (@warning)
140{
141 $count++;
142 my $regex = shift @warning;
143 my $result = shift @warning;
144
145 undef $warning;
146 $_ = "x";
147 eval $regex;
148
149 if ($@)
150 {
151 if ($debug) {
152 print "oops, $regex died with:\n\t$@\n";
153 } else {
154 print "not ok $count\n";
155 }
156 next;
157 }
158
159 if (not $warning)
160 {
161 if ($debug) {
162 print "oops, $regex didn't generate a warning\n";
163 } else {
164 print "not ok $count\n";
165 }
166 next;
167 }
168 chomp $warning;
169 $warning =~ s/ at \(.*?\) line \d+\.$//;
170 $result =~ s/{\#}/$marker1/;
171 $result =~ s/{\#}/$marker2/;
172 if ($warning ne $result)
173 {
174 if ($debug) {
175 print "For $regex, expected:\n $result\nGot:\n $warning\n\n";
176 } else {
177 print "not ok $count\n";
178 }
179 next;
180 }
181 print "ok $count\n";
182}
183
184
185