blob: 1a7679af8e4741ae1ab944ea3de390b6d902c6bc [file] [log] [blame]
Janis Danisevskis112c9cc2016-03-31 13:35:25 +01001#! /bin/sh
2
3# Script for testing regular expressions with perl to check that PCRE2 handles
Elliott Hughes9bc971b2018-07-27 13:23:14 -07004# them the same. If the first argument to this script is "-w", Perl is also
5# called with "-w", which turns on its warning mode.
6#
7# The Perl code has to have "use utf8" and "require Encode" at the start when
8# running UTF-8 tests, but *not* for non-utf8 tests. (The "require" would
9# actually be OK for non-utf8-tests, but is not always installed, so this way
10# the script will always run for these tests.)
Janis Danisevskis112c9cc2016-03-31 13:35:25 +010011#
12# The desired effect is achieved by making this a shell script that passes the
Elliott Hughes9bc971b2018-07-27 13:23:14 -070013# Perl script to Perl through a pipe. If the first argument (possibly after
14# removing "-w") is "-utf8", a suitable prefix is set up.
Janis Danisevskis112c9cc2016-03-31 13:35:25 +010015#
16# The remaining arguments, if any, are passed to Perl. They are an input file
17# and an output file. If there is one argument, the output is written to
18# STDOUT. If Perl receives no arguments, it opens /dev/tty as input, and writes
19# output to STDOUT. (I haven't found a way of getting it to use STDIN, because
20# of the contorted piping input.)
21
22perl=perl
Elliott Hughes9bc971b2018-07-27 13:23:14 -070023perlarg=''
Janis Danisevskis112c9cc2016-03-31 13:35:25 +010024prefix=''
Elliott Hughes9bc971b2018-07-27 13:23:14 -070025
26if [ $# -gt 0 -a "$1" = "-w" ] ; then
27 perlarg="-w"
28 shift
29fi
30
Janis Danisevskis112c9cc2016-03-31 13:35:25 +010031if [ $# -gt 0 -a "$1" = "-utf8" ] ; then
32 prefix="use utf8; require Encode;"
33 shift
34fi
35
36
37# The Perl script that follows has a similar specification to pcre2test, and so
38# can be given identical input, except that input patterns can be followed only
39# by Perl's lower case modifiers and certain other pcre2test modifiers that are
40# either handled or ignored:
41#
42# aftertext interpreted as "print $' afterwards"
43# afteralltext ignored
44# dupnames ignored (Perl always allows)
Elliott Hughes9bc971b2018-07-27 13:23:14 -070045# jitstack ignored
Janis Danisevskis112c9cc2016-03-31 13:35:25 +010046# mark ignored
47# no_auto_possess ignored
48# no_start_optimize ignored
Elliott Hughes9bc971b2018-07-27 13:23:14 -070049# subject_literal does not process subjects for escapes
Janis Danisevskis112c9cc2016-03-31 13:35:25 +010050# ucp sets Perl's /u modifier
51# utf invoke UTF-8 functionality
52#
Elliott Hughes9bc971b2018-07-27 13:23:14 -070053# The data lines must not have any pcre2test modifiers. Unless
54# "subject_litersl" is on the pattern, data lines are processed as
Janis Danisevskis112c9cc2016-03-31 13:35:25 +010055# Perl double-quoted strings, so if they contain " $ or @ characters, these
56# have to be escaped. For this reason, all such characters in the
57# Perl-compatible testinput1 and testinput4 files are escaped so that they can
58# be used for perltest as well as for pcre2test. The output from this script
59# should be same as from pcre2test, apart from the initial identifying banner.
60#
61# The other testinput files are not suitable for feeding to perltest.sh,
62# because they make use of the special modifiers that pcre2test uses for
63# testing features of PCRE2. Some of these files also contain malformed regular
64# expressions, in order to check that PCRE2 diagnoses them correctly.
65
66(echo "$prefix" ; cat <<'PERLEND'
67
68# Function for turning a string into a string of printing chars.
69
70sub pchars {
71my($t) = "";
72if ($utf8)
73 {
74 @p = unpack('U*', $_[0]);
75 foreach $c (@p)
76 {
77 if ($c >= 32 && $c < 127) { $t .= chr $c; }
78 else { $t .= sprintf("\\x{%02x}", $c);
79 }
80 }
81 }
82else
83 {
84 foreach $c (split(//, $_[0]))
85 {
86 if (ord $c >= 32 && ord $c < 127) { $t .= $c; }
87 else { $t .= sprintf("\\x%02x", ord $c); }
88 }
89 }
90$t;
91}
92
93
94# Read lines from a named file or stdin and write to a named file or stdout;
95# lines consist of a regular expression, in delimiters and optionally followed
96# by options, followed by a set of test data, terminated by an empty line.
97
98# Sort out the input and output files
99
100if (@ARGV > 0)
101 {
102 open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n";
103 $infile = "INFILE";
104 $interact = 0;
105 }
106else
107 {
108 open(INFILE, "</dev/tty") || die "Failed to open /dev/tty\n";
109 $infile = "INFILE";
110 $interact = 1;
111 }
112
113if (@ARGV > 1)
114 {
115 open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n";
116 $outfile = "OUTFILE";
117 }
118else { $outfile = "STDOUT"; }
119
120printf($outfile "Perl $] Regular Expressions\n\n");
121
122# Main loop
123
124NEXT_RE:
125for (;;)
126 {
127 printf " re> " if $interact;
128 last if ! ($_ = <$infile>);
129 printf $outfile "$_" if ! $interact;
130 next if ($_ =~ /^\s*$/ || $_ =~ /^#/);
131
132 $pattern = $_;
133
134 while ($pattern !~ /^\s*(.).*\1/s)
135 {
136 printf " > " if $interact;
137 last if ! ($_ = <$infile>);
138 printf $outfile "$_" if ! $interact;
139 $pattern .= $_;
140 }
141
142 chomp($pattern);
143 $pattern =~ s/\s+$//;
144
145 # Split the pattern from the modifiers and adjust them as necessary.
146
147 $pattern =~ /^\s*((.).*\2)(.*)$/s;
148 $pat = $1;
149 $mod = $3;
150
151 # The private "aftertext" modifier means "print $' afterwards".
152
153 $showrest = ($mod =~ s/aftertext,?//);
154
Elliott Hughes9bc971b2018-07-27 13:23:14 -0700155 # The "subject_literal" modifer disables escapes in subjects.
156
157 $subject_literal = ($mod =~ s/subject_literal,?//);
158
Janis Danisevskis112c9cc2016-03-31 13:35:25 +0100159 # "allaftertext" is used by pcre2test to print remainders after captures
160
161 $mod =~ s/allaftertext,?//;
162
163 # Detect utf
164
165 $utf8 = $mod =~ s/utf,?//;
166
167 # Remove "dupnames".
168
169 $mod =~ s/dupnames,?//;
170
Elliott Hughes9bc971b2018-07-27 13:23:14 -0700171 # Remove "jitstack".
172
173 $mod =~ s/jitstack=\d+,?//;
174
Janis Danisevskis112c9cc2016-03-31 13:35:25 +0100175 # Remove "mark" (asks pcre2test to check MARK data) */
176
177 $mod =~ s/mark,?//;
178
179 # "ucp" asks pcre2test to set PCRE2_UCP; change this to /u for Perl
180
181 $mod =~ s/ucp,?/u/;
182
183 # Remove "no_auto_possess" and "no_start_optimize" (disable PCRE2 optimizations)
184
185 $mod =~ s/no_auto_possess,?//;
186 $mod =~ s/no_start_optimize,?//;
187
188 # Add back retained modifiers and check that the pattern is valid.
189
190 $mod =~ s/,//g;
191 $pattern = "$pat$mod";
192 eval "\$_ =~ ${pattern}";
193 if ($@)
194 {
195 printf $outfile "Error: $@";
196 if (! $interact)
197 {
198 for (;;)
199 {
200 last if ! ($_ = <$infile>);
201 last if $_ =~ /^\s*$/;
202 }
203 }
204 next NEXT_RE;
205 }
206
207 # If the /g modifier is present, we want to put a loop round the matching;
208 # otherwise just a single "if".
209
210 $cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if";
211
212 # If the pattern is actually the null string, Perl uses the most recently
213 # executed (and successfully compiled) regex is used instead. This is a
214 # nasty trap for the unwary! The PCRE2 test suite does contain null strings
215 # in places - if they are allowed through here all sorts of weird and
216 # unexpected effects happen. To avoid this, we replace such patterns with
217 # a non-null pattern that has the same effect.
218
219 $pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/);
220
221 # Read data lines and test them
222
223 for (;;)
224 {
225 printf "data> " if $interact;
226 last NEXT_RE if ! ($_ = <$infile>);
227 chomp;
228 printf $outfile "%s", "$_\n" if ! $interact;
229
230 s/\s+$//; # Remove trailing space
231 s/^\s+//; # Remove leading space
232
233 last if ($_ eq "");
234 next if $_ =~ /^\\=(?:\s|$)/; # Comment line
235
Elliott Hughes9bc971b2018-07-27 13:23:14 -0700236 if ($subject_literal)
237 {
238 $x = $_;
239 }
240 else
241 {
242 $x = eval "\"$_\""; # To get escapes processed
243 }
Janis Danisevskis112c9cc2016-03-31 13:35:25 +0100244
245 # Empty array for holding results, ensure $REGERROR and $REGMARK are
246 # unset, then do the matching.
247
248 @subs = ();
249
250 $pushes = "push \@subs,\$&;" .
251 "push \@subs,\$1;" .
252 "push \@subs,\$2;" .
253 "push \@subs,\$3;" .
254 "push \@subs,\$4;" .
255 "push \@subs,\$5;" .
256 "push \@subs,\$6;" .
257 "push \@subs,\$7;" .
258 "push \@subs,\$8;" .
259 "push \@subs,\$9;" .
260 "push \@subs,\$10;" .
261 "push \@subs,\$11;" .
262 "push \@subs,\$12;" .
263 "push \@subs,\$13;" .
264 "push \@subs,\$14;" .
265 "push \@subs,\$15;" .
266 "push \@subs,\$16;" .
267 "push \@subs,\$'; }";
268
269 undef $REGERROR;
270 undef $REGMARK;
271
272 eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
273
274 if ($@)
275 {
276 printf $outfile "Error: $@\n";
277 next NEXT_RE;
278 }
279 elsif (scalar(@subs) == 0)
280 {
281 printf $outfile "No match";
282 if (defined $REGERROR && $REGERROR != 1)
283 { printf $outfile (", mark = %s", &pchars($REGERROR)); }
284 printf $outfile "\n";
285 }
286 else
287 {
288 while (scalar(@subs) != 0)
289 {
290 printf $outfile (" 0: %s\n", &pchars($subs[0]));
291 printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest;
292 $last_printed = 0;
293 for ($i = 1; $i <= 16; $i++)
294 {
295 if (defined $subs[$i])
296 {
297 while ($last_printed++ < $i-1)
298 { printf $outfile ("%2d: <unset>\n", $last_printed); }
299 printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i]));
300 $last_printed = $i;
301 }
302 }
303 splice(@subs, 0, 18);
304 }
305
306 # It seems that $REGMARK is not marked as UTF-8 even when use utf8 is
307 # set and the input pattern was a UTF-8 string. We can, however, force
308 # it to be so marked.
309
310 if (defined $REGMARK && $REGMARK != 1)
311 {
312 $xx = $REGMARK;
313 $xx = Encode::decode_utf8($xx) if $utf8;
314 printf $outfile ("MK: %s\n", &pchars($xx));
315 }
316 }
317 }
318 }
319
320# printf $outfile "\n";
321
322PERLEND
Elliott Hughes9bc971b2018-07-27 13:23:14 -0700323) | $perl $perlarg - $@
Janis Danisevskis112c9cc2016-03-31 13:35:25 +0100324
325# End