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