|
Packit |
78a954 |
#! /usr/bin/env perl
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Program for testing regular expressions with perl to check that PCRE handles
|
|
Packit |
78a954 |
# them the same. This version needs to have "use utf8" at the start for running
|
|
Packit |
78a954 |
# the UTF-8 tests, but *not* for the other tests. The only way I've found for
|
|
Packit |
78a954 |
# doing this is to cat this line in explicitly in the RunPerlTest script. I've
|
|
Packit |
78a954 |
# also used this method to supply "require Encode" for the UTF-8 tests, so that
|
|
Packit |
78a954 |
# the main test will still run where Encode is not installed.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
#use utf8;
|
|
Packit |
78a954 |
#require Encode;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Function for turning a string into a string of printing chars.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
sub pchars {
|
|
Packit |
78a954 |
my($t) = "";
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
if ($utf8)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
@p = unpack('U*', $_[0]);
|
|
Packit |
78a954 |
foreach $c (@p)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
if ($c >= 32 && $c < 127) { $t .= chr $c; }
|
|
Packit |
78a954 |
else { $t .= sprintf("\\x{%02x}", $c);
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
else
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
foreach $c (split(//, $_[0]))
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
if (ord $c >= 32 && ord $c < 127) { $t .= $c; }
|
|
Packit |
78a954 |
else { $t .= sprintf("\\x%02x", ord $c); }
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$t;
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Read lines from named file or stdin and write to named file or stdout; lines
|
|
Packit |
78a954 |
# consist of a regular expression, in delimiters and optionally followed by
|
|
Packit |
78a954 |
# options, followed by a set of test data, terminated by an empty line.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Sort out the input and output files
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
if (@ARGV > 0)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n";
|
|
Packit |
78a954 |
$infile = "INFILE";
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
else { $infile = "STDIN"; }
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
if (@ARGV > 1)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n";
|
|
Packit |
78a954 |
$outfile = "OUTFILE";
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
else { $outfile = "STDOUT"; }
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
printf($outfile "Perl $] Regular Expressions\n\n");
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Main loop
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
NEXT_RE:
|
|
Packit |
78a954 |
for (;;)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
printf " re> " if $infile eq "STDIN";
|
|
Packit |
78a954 |
last if ! ($_ = <$infile>);
|
|
Packit |
78a954 |
printf $outfile "$_" if $infile ne "STDIN";
|
|
Packit |
78a954 |
next if ($_ =~ /^\s*$/ || $_ =~ /^< forbid/);
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern = $_;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
while ($pattern !~ /^\s*(.).*\1/s)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
printf " > " if $infile eq "STDIN";
|
|
Packit |
78a954 |
last if ! ($_ = <$infile>);
|
|
Packit |
78a954 |
printf $outfile "$_" if $infile ne "STDIN";
|
|
Packit |
78a954 |
$pattern .= $_;
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
chomp($pattern);
|
|
Packit |
78a954 |
$pattern =~ s/\s+$//;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# The private /+ modifier means "print $' afterwards".
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$showrest = ($pattern =~ s/\+(?=[a-zA-Z]*$)//);
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# A doubled version is used by pcretest to print remainders after captures
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern =~ s/\+(?=[a-zA-Z]*$)//;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Remove /8 from a UTF-8 pattern.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$utf8 = $pattern =~ s/8(?=[a-zA-Z]*$)//;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Remove /J from a pattern with duplicate names.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern =~ s/J(?=[a-zA-Z]*$)//;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Remove /K from a pattern (asks pcretest to check MARK data) */
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern =~ s/K(?=[a-zA-Z]*$)//;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# /W asks pcretest to set PCRE_UCP; change this to /u for Perl
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern =~ s/W(?=[a-zA-Z]*$)/u/;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Remove /S or /SS from a pattern (asks pcretest to study or not to study)
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern =~ s/S(?=[a-zA-Z]*$)//g;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Remove /Y and /O from a pattern (disable PCRE optimizations)
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern =~ s/[YO](?=[a-zA-Z]*$)//;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Check that the pattern is valid
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
eval "\$_ =~ ${pattern}";
|
|
Packit |
78a954 |
if ($@)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
printf $outfile "Error: $@";
|
|
Packit |
78a954 |
if ($infile != "STDIN")
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
for (;;)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
last if ! ($_ = <$infile>);
|
|
Packit |
78a954 |
last if $_ =~ /^\s*$/;
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
next NEXT_RE;
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# If the /g modifier is present, we want to put a loop round the matching;
|
|
Packit |
78a954 |
# otherwise just a single "if".
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if";
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# If the pattern is actually the null string, Perl uses the most recently
|
|
Packit |
78a954 |
# executed (and successfully compiled) regex is used instead. This is a
|
|
Packit |
78a954 |
# nasty trap for the unwary! The PCRE test suite does contain null strings
|
|
Packit |
78a954 |
# in places - if they are allowed through here all sorts of weird and
|
|
Packit |
78a954 |
# unexpected effects happen. To avoid this, we replace such patterns with
|
|
Packit |
78a954 |
# a non-null pattern that has the same effect.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/);
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Read data lines and test them
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
for (;;)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
printf "data> " if $infile eq "STDIN";
|
|
Packit |
78a954 |
last NEXT_RE if ! ($_ = <$infile>);
|
|
Packit |
78a954 |
chomp;
|
|
Packit |
78a954 |
printf $outfile "$_\n" if $infile ne "STDIN";
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
s/\s+$//; # Remove trailing space
|
|
Packit |
78a954 |
s/^\s+//; # Remove leading space
|
|
Packit |
78a954 |
s/\\Y//g; # Remove \Y (pcretest flag to set PCRE_NO_START_OPTIMIZE)
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
last if ($_ eq "");
|
|
Packit |
78a954 |
$x = eval "\"$_\""; # To get escapes processed
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# Empty array for holding results, ensure $REGERROR and $REGMARK are
|
|
Packit |
78a954 |
# unset, then do the matching.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
@subs = ();
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
$pushes = "push \@subs,\$&;" .
|
|
Packit |
78a954 |
"push \@subs,\$1;" .
|
|
Packit |
78a954 |
"push \@subs,\$2;" .
|
|
Packit |
78a954 |
"push \@subs,\$3;" .
|
|
Packit |
78a954 |
"push \@subs,\$4;" .
|
|
Packit |
78a954 |
"push \@subs,\$5;" .
|
|
Packit |
78a954 |
"push \@subs,\$6;" .
|
|
Packit |
78a954 |
"push \@subs,\$7;" .
|
|
Packit |
78a954 |
"push \@subs,\$8;" .
|
|
Packit |
78a954 |
"push \@subs,\$9;" .
|
|
Packit |
78a954 |
"push \@subs,\$10;" .
|
|
Packit |
78a954 |
"push \@subs,\$11;" .
|
|
Packit |
78a954 |
"push \@subs,\$12;" .
|
|
Packit |
78a954 |
"push \@subs,\$13;" .
|
|
Packit |
78a954 |
"push \@subs,\$14;" .
|
|
Packit |
78a954 |
"push \@subs,\$15;" .
|
|
Packit |
78a954 |
"push \@subs,\$16;" .
|
|
Packit |
78a954 |
"push \@subs,\$'; }";
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
undef $REGERROR;
|
|
Packit |
78a954 |
undef $REGMARK;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
if ($@)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
printf $outfile "Error: $@\n";
|
|
Packit |
78a954 |
next NEXT_RE;
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
elsif (scalar(@subs) == 0)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
printf $outfile "No match";
|
|
Packit |
78a954 |
if (defined $REGERROR && $REGERROR != 1)
|
|
Packit |
78a954 |
{ printf $outfile (", mark = %s", &pchars($REGERROR)); }
|
|
Packit |
78a954 |
printf $outfile "\n";
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
else
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
while (scalar(@subs) != 0)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
printf $outfile (" 0: %s\n", &pchars($subs[0]));
|
|
Packit |
78a954 |
printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest;
|
|
Packit |
78a954 |
$last_printed = 0;
|
|
Packit |
78a954 |
for ($i = 1; $i <= 16; $i++)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
if (defined $subs[$i])
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
while ($last_printed++ < $i-1)
|
|
Packit |
78a954 |
{ printf $outfile ("%2d: <unset>\n", $last_printed); }
|
|
Packit |
78a954 |
printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i]));
|
|
Packit |
78a954 |
$last_printed = $i;
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
splice(@subs, 0, 18);
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# It seems that $REGMARK is not marked as UTF-8 even when use utf8 is
|
|
Packit |
78a954 |
# set and the input pattern was a UTF-8 string. We can, however, force
|
|
Packit |
78a954 |
# it to be so marked.
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
if (defined $REGMARK && $REGMARK != 1)
|
|
Packit |
78a954 |
{
|
|
Packit |
78a954 |
$xx = $REGMARK;
|
|
Packit |
78a954 |
$xx = Encode::decode_utf8($xx) if $utf8;
|
|
Packit |
78a954 |
printf $outfile ("MK: %s\n", &pchars($xx));
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
}
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# printf $outfile "\n";
|
|
Packit |
78a954 |
|
|
Packit |
78a954 |
# End
|