1#! /bin/sh
2
3# Script for testing regular expressions with perl to check that PCRE2 handles
4# them the same. For testing with different versions of Perl, if the first
5# argument is -perl then the second is taken as the Perl command to use, and
6# both are then removed. If the next argument is "-w", Perl is called with
7# "-w", which turns on its warning mode.
8#
9# The Perl code has to have "use utf8" and "require Encode" at the start when
10# running UTF-8 tests, but *not* for non-utf8 tests. (The "require" would
11# actually be OK for non-utf8-tests, but is not always installed, so this way
12# the script will always run for these tests.)
13#
14# The desired effect is achieved by making this a shell script that passes the
15# Perl script to Perl through a pipe. If the next argument is "-utf8", a
16# suitable prefix is set up.
17#
18# The remaining arguments, if any, are passed to Perl. They are an input file
19# and an output file. If there is one argument, the output is written to
20# STDOUT. If Perl receives no arguments, it opens /dev/tty as input, and writes
21# output to STDOUT. (I haven't found a way of getting it to use STDIN, because
22# of the contorted piping input.)
23
24perl=perl
25perlarg=''
26prefix=''
27
28if [ $# -gt 1 -a "$1" = "-perl" ] ; then
29  shift
30  perl=$1
31  shift
32fi
33
34if [ $# -gt 0 -a "$1" = "-w" ] ; then
35  perlarg="-w"
36  shift
37fi
38
39if [ $# -gt 0 -a "$1" = "-utf8" ] ; then
40  prefix="use utf8; require Encode;"
41  shift
42fi
43
44
45# The Perl script that follows has a similar specification to pcre2test, and so
46# can be given identical input, except that input patterns can be followed only
47# by Perl's lower case modifiers and certain other pcre2test modifiers that are
48# either handled or ignored:
49#
50#   aftertext          interpreted as "print $' afterwards"
51#   afteralltext       ignored
52#   dupnames           ignored (Perl always allows)
53#   jitstack           ignored
54#   mark               show mark information
55#   no_auto_possess    ignored
56#   no_start_optimize  insert (??{""}) at pattern start (disables optimizing)
57#  -no_start_optimize  ignored
58#   subject_literal    does not process subjects for escapes
59#   ucp                sets Perl's /u modifier
60#   utf                invoke UTF-8 functionality
61#
62# Comment lines are ignored. The #pattern command can be used to set modifiers
63# that will be added to each subsequent pattern, after any modifiers it may
64# already have. NOTE: this is different to pcre2test where #pattern sets
65# defaults which can be overridden on individual patterns. The #subject command
66# may be used to set or unset a default "mark" modifier for data lines. This is
67# the only use of #subject that is supported. The #perltest, #forbid_utf, and
68# #newline_default commands, which are needed in the relevant pcre2test files,
69# are ignored. Any other #-command is ignored, with a warning message.
70#
71# The pattern lines should use only / as the delimiter. The other characters
72# that pcre2test supports cause problems with this script.
73#
74# The data lines must not have any pcre2test modifiers. Unless
75# "subject_literal" is on the pattern, data lines are processed as
76# Perl double-quoted strings, so if they contain " $ or @ characters, these
77# have to be escaped. For this reason, all such characters in the
78# Perl-compatible testinput1 and testinput4 files are escaped so that they can
79# be used for perltest as well as for pcre2test. The output from this script
80# should be same as from pcre2test, apart from the initial identifying banner.
81#
82# The other testinput files are not suitable for feeding to perltest.sh,
83# because they make use of the special modifiers that pcre2test uses for
84# testing features of PCRE2. Some of these files also contain malformed regular
85# expressions, in order to check that PCRE2 diagnoses them correctly.
86
87(echo "$prefix" ; cat <<'PERLEND'
88
89# The alpha assertions currently give warnings even when -w is not specified.
90
91no warnings "experimental::alpha_assertions";
92no warnings "experimental::script_run";
93
94# Function for turning a string into a string of printing chars.
95
96sub pchars {
97my($t) = "";
98if ($utf8)
99  {
100  @p = unpack('U*', $_[0]);
101  foreach $c (@p)
102    {
103    if ($c >= 32 && $c < 127) { $t .= chr $c; }
104      else { $t .= sprintf("\\x{%02x}", $c);
105      }
106    }
107  }
108else
109  {
110  foreach $c (split(//, $_[0]))
111    {
112    if (ord $c >= 32 && ord $c < 127) { $t .= $c; }
113      else { $t .= sprintf("\\x%02x", ord $c); }
114    }
115  }
116$t;
117}
118
119
120# Read lines from a named file or stdin and write to a named file or stdout;
121# lines consist of a regular expression, in delimiters and optionally followed
122# by options, followed by a set of test data, terminated by an empty line.
123
124# Sort out the input and output files
125
126if (@ARGV > 0)
127  {
128  open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n";
129  $infile = "INFILE";
130  $interact = 0;
131  }
132else
133  {
134  open(INFILE, "</dev/tty") || die "Failed to open /dev/tty\n";
135  $infile = "INFILE";
136  $interact = 1;
137  }
138
139if (@ARGV > 1)
140  {
141  open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n";
142  $outfile = "OUTFILE";
143  }
144else { $outfile = "STDOUT"; }
145
146printf($outfile "Perl $^V\n\n");
147
148$extra_modifiers = "";
149$default_show_mark = 0;
150
151# Main loop
152
153NEXT_RE:
154for (;;)
155  {
156  printf "  re> " if $interact;
157  last if ! ($_ = <$infile>);
158  printf $outfile "$_" if ! $interact;
159  next if ($_ =~ /^\s*$/ || $_ =~ /^#[\s!]/);
160
161  # A few of pcre2test's #-commands are supported, or just ignored. Any others
162  # cause an error.
163
164  if ($_ =~ /^#pattern(.*)/)
165    {
166    $extra_modifiers = $1;
167    chomp($extra_modifiers);
168    $extra_modifiers =~ s/\s+$//;
169    next;
170    }
171  elsif ($_ =~ /^#subject(.*)/)
172    {
173    $mod = $1;
174    chomp($mod);
175    $mod =~ s/\s+$//;
176    if ($mod =~ s/(-?)mark,?//)
177      {
178      $minus = $1;
179      $default_show_mark = ($minus =~ /^$/);
180      }
181    if ($mod !~ /^\s*$/)
182      {
183      printf $outfile "** Warning: \"$mod\" in #subject ignored\n";
184      }
185    next;
186    }
187  elsif ($_ =~ /^#/)
188    {
189    if ($_ !~ /^#newline_default|^#perltest|^#forbid_utf/)
190      {
191      printf $outfile "** Warning: #-command ignored: %s", $_;
192      }
193    next;
194    }
195
196  $pattern = $_;
197
198  while ($pattern !~ /^\s*(.).*\1/s)
199    {
200    printf "    > " if $interact;
201    last if ! ($_ = <$infile>);
202    printf $outfile "$_" if ! $interact;
203    $pattern .= $_;
204    }
205
206  chomp($pattern);
207  $pattern =~ s/\s+$//;
208
209  # Split the pattern from the modifiers and adjust them as necessary.
210
211  $pattern =~ /^\s*((.).*\2)(.*)$/s;
212  $pat = $1;
213  $del = $2;
214  $mod = "$3,$extra_modifiers";
215  $mod =~ s/^,\s*//;
216
217  # The private "aftertext" modifier means "print $' afterwards".
218
219  $showrest = ($mod =~ s/aftertext,?//);
220
221  # The "subject_literal" modifer disables escapes in subjects.
222
223  $subject_literal = ($mod =~ s/subject_literal,?//);
224
225  # "allaftertext" is used by pcre2test to print remainders after captures
226
227  $mod =~ s/allaftertext,?//;
228
229  # Detect utf
230
231  $utf8 = $mod =~ s/utf,?//;
232
233  # Remove "dupnames".
234
235  $mod =~ s/dupnames,?//;
236
237  # Remove "jitstack".
238
239  $mod =~ s/jitstack=\d+,?//;
240
241  # The "mark" modifier requests checking of MARK data */
242
243  $show_mark = $default_show_mark | ($mod =~ s/mark,?//);
244
245  # "ucp" asks pcre2test to set PCRE2_UCP; change this to /u for Perl
246
247  $mod =~ s/ucp,?/u/;
248
249  # Remove "no_auto_possess".
250
251  $mod =~ s/no_auto_possess,?//;
252
253  # Use no_start_optimize (disable PCRE2 start-up optimization) to disable Perl
254  # optimization by inserting (??{""}) at the start of the pattern. We may
255  # also encounter -no_start_optimize from a #pattern setting.
256
257  $mod =~ s/-no_start_optimize,?//;
258  if ($mod =~ s/no_start_optimize,?//) { $pat =~ s/$del/$del(??{""})/; }
259
260  # Add back retained modifiers and check that the pattern is valid.
261
262  $mod =~ s/,//g;
263  $pattern = "$pat$mod";
264  eval "\$_ =~ ${pattern}";
265  if ($@)
266    {
267    printf $outfile "Error: $@";
268    if (! $interact)
269      {
270      for (;;)
271        {
272        last if ! ($_ = <$infile>);
273        last if $_ =~ /^\s*$/;
274        }
275      }
276    next NEXT_RE;
277    }
278
279  # If the /g modifier is present, we want to put a loop round the matching;
280  # otherwise just a single "if".
281
282  $cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if";
283
284  # If the pattern is actually the null string, Perl uses the most recently
285  # executed (and successfully compiled) regex is used instead. This is a
286  # nasty trap for the unwary! The PCRE2 test suite does contain null strings
287  # in places - if they are allowed through here all sorts of weird and
288  # unexpected effects happen. To avoid this, we replace such patterns with
289  # a non-null pattern that has the same effect.
290
291  $pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/);
292
293  # Read data lines and test them
294
295  for (;;)
296    {
297    printf "data> " if $interact;
298    last NEXT_RE if ! ($_ = <$infile>);
299    chomp;
300    printf $outfile "%s", "$_\n" if ! $interact;
301
302    s/\s+$//;  # Remove trailing space
303    s/^\s+//;  # Remove leading space
304
305    last if ($_ eq "");
306    next if $_ =~ /^\\=(?:\s|$)/;   # Comment line
307
308    if ($subject_literal)
309      {
310      $x = $_;
311      }
312    else
313      {
314      $x = eval "\"$_\"";   # To get escapes processed
315      }
316
317    # Empty array for holding results, ensure $REGERROR and $REGMARK are
318    # unset, then do the matching.
319
320    @subs = ();
321
322    $pushes = "push \@subs,\$&;" .
323         "push \@subs,\$1;" .
324         "push \@subs,\$2;" .
325         "push \@subs,\$3;" .
326         "push \@subs,\$4;" .
327         "push \@subs,\$5;" .
328         "push \@subs,\$6;" .
329         "push \@subs,\$7;" .
330         "push \@subs,\$8;" .
331         "push \@subs,\$9;" .
332         "push \@subs,\$10;" .
333         "push \@subs,\$11;" .
334         "push \@subs,\$12;" .
335         "push \@subs,\$13;" .
336         "push \@subs,\$14;" .
337         "push \@subs,\$15;" .
338         "push \@subs,\$16;" .
339         "push \@subs,\$'; }";
340
341    undef $REGERROR;
342    undef $REGMARK;
343
344    eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
345
346    if ($@)
347      {
348      printf $outfile "Error: $@\n";
349      next NEXT_RE;
350      }
351    elsif (scalar(@subs) == 0)
352      {
353      printf $outfile "No match";
354      if ($show_mark && defined $REGERROR && $REGERROR != 1)
355        { printf $outfile (", mark = %s", &pchars($REGERROR)); }
356      printf $outfile "\n";
357      }
358    else
359      {
360      while (scalar(@subs) != 0)
361        {
362        printf $outfile (" 0: %s\n", &pchars($subs[0]));
363        printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest;
364        $last_printed = 0;
365        for ($i = 1; $i <= 16; $i++)
366          {
367          if (defined $subs[$i])
368            {
369            while ($last_printed++ < $i-1)
370              { printf $outfile ("%2d: <unset>\n", $last_printed); }
371            printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i]));
372            $last_printed = $i;
373            }
374          }
375        splice(@subs, 0, 18);
376        }
377
378      # It seems that $REGMARK is not marked as UTF-8 even when use utf8 is
379      # set and the input pattern was a UTF-8 string. We can, however, force
380      # it to be so marked.
381
382      if ($show_mark && defined $REGMARK && $REGMARK != 1)
383        {
384        $xx = $REGMARK;
385        $xx = Encode::decode_utf8($xx) if $utf8;
386        printf $outfile ("MK: %s\n", &pchars($xx));
387        }
388      }
389    }
390  }
391
392# By closing OUTFILE explicitly, we avoid a Perl warning in -w mode
393# "main::OUTFILE" used only once".
394
395close(OUTFILE) if $outfile eq "OUTFILE";
396
397PERLEND
398) | $perl $perlarg - $@
399
400# End
401