| 1 |
#! /usr/bin/perl |
#! /usr/bin/perl |
| 2 |
|
|
| 3 |
# Program for testing regular expressions with perl to check that PCRE handles |
# Program for testing regular expressions with perl to check that PCRE handles |
| 4 |
# them the same. |
# them the same. This is the version that supports /8 for UTF-8 testing. As it |
| 5 |
|
# stands, it requires at least Perl 5.8 for UTF-8 support. For Perl 5.6, it |
| 6 |
|
# can be used as is for non-UTF-8 testing, but you have to uncomment the |
| 7 |
|
# "use utf8" lines in order to to UTF-8 stuff (and you mustn't uncomment them |
| 8 |
|
# for non-UTF-8 use). |
| 9 |
|
|
| 10 |
|
|
| 11 |
# Function for turning a string into a string of printing chars |
# Function for turning a string into a string of printing chars. There are |
| 12 |
|
# currently problems with UTF-8 strings; this fudges round them. |
| 13 |
|
|
| 14 |
sub pchars { |
sub pchars { |
| 15 |
my($t) = ""; |
my($t) = ""; |
| 16 |
|
|
| 17 |
foreach $c (split(//, $_[0])) |
if ($utf8) |
| 18 |
{ |
{ |
| 19 |
if (ord $c >= 32 && ord $c < 127) { $t .= $c; } |
# use utf8; <=============== For UTF-8 in Perl 5.6 |
| 20 |
else { $t .= sprintf("\\x%02x", ord $c); } |
@p = unpack('U*', $_[0]); |
| 21 |
|
foreach $c (@p) |
| 22 |
|
{ |
| 23 |
|
if ($c >= 32 && $c < 127) { $t .= chr $c; } |
| 24 |
|
else { $t .= sprintf("\\x{%02x}", $c); } |
| 25 |
|
} |
| 26 |
} |
} |
| 27 |
|
|
| 28 |
|
else |
| 29 |
|
{ |
| 30 |
|
foreach $c (split(//, $_[0])) |
| 31 |
|
{ |
| 32 |
|
if (ord $c >= 32 && ord $c < 127) { $t .= $c; } |
| 33 |
|
else { $t .= sprintf("\\x%02x", ord $c); } |
| 34 |
|
} |
| 35 |
|
} |
| 36 |
|
|
| 37 |
$t; |
$t; |
| 38 |
} |
} |
| 39 |
|
|
| 84 |
chomp($pattern); |
chomp($pattern); |
| 85 |
$pattern =~ s/\s+$//; |
$pattern =~ s/\s+$//; |
| 86 |
|
|
| 87 |
# The private /+ modifier means "print $' afterwards". We use it |
# The private /+ modifier means "print $' afterwards". |
|
# only on the end of patterns to make it easy to chop off here. |
|
| 88 |
|
|
| 89 |
$showrest = ($pattern =~ s/\+(?=[a-z]*$)//); |
$showrest = ($pattern =~ s/\+(?=[a-z]*$)//); |
| 90 |
|
|
| 91 |
|
# The private /8 modifier means "operate in UTF-8". Currently, Perl |
| 92 |
|
# has bugs that we try to work around using this flag. |
| 93 |
|
|
| 94 |
|
$utf8 = ($pattern =~ s/8(?=[a-z]*$)//); |
| 95 |
|
|
| 96 |
# Check that the pattern is valid |
# Check that the pattern is valid |
| 97 |
|
|
| 98 |
eval "\$_ =~ ${pattern}"; |
if ($utf8) |
| 99 |
|
{ |
| 100 |
|
# use utf8; <=============== For UTF-8 in Perl 5.6 |
| 101 |
|
eval "\$_ =~ ${pattern}"; |
| 102 |
|
} |
| 103 |
|
else |
| 104 |
|
{ |
| 105 |
|
eval "\$_ =~ ${pattern}"; |
| 106 |
|
} |
| 107 |
|
|
| 108 |
if ($@) |
if ($@) |
| 109 |
{ |
{ |
| 110 |
printf $outfile "Error: $@"; |
printf $outfile "Error: $@"; |
| 145 |
|
|
| 146 |
@subs = (); |
@subs = (); |
| 147 |
|
|
| 148 |
eval "${cmd} (\$x =~ ${pattern}) {" . |
$pushes = "push \@subs,\$&;" . |
|
"push \@subs,\$&;" . |
|
| 149 |
"push \@subs,\$1;" . |
"push \@subs,\$1;" . |
| 150 |
"push \@subs,\$2;" . |
"push \@subs,\$2;" . |
| 151 |
"push \@subs,\$3;" . |
"push \@subs,\$3;" . |
| 164 |
"push \@subs,\$16;" . |
"push \@subs,\$16;" . |
| 165 |
"push \@subs,\$'; }"; |
"push \@subs,\$'; }"; |
| 166 |
|
|
| 167 |
|
if ($utf8) |
| 168 |
|
{ |
| 169 |
|
# use utf8; <=============== For UTF-8 in Perl 5.6 |
| 170 |
|
eval "${cmd} (\$x =~ ${pattern}) {" . $pushes; |
| 171 |
|
} |
| 172 |
|
else |
| 173 |
|
{ |
| 174 |
|
eval "${cmd} (\$x =~ ${pattern}) {" . $pushes; |
| 175 |
|
} |
| 176 |
|
|
| 177 |
if ($@) |
if ($@) |
| 178 |
{ |
{ |
| 179 |
printf $outfile "Error: $@\n"; |
printf $outfile "Error: $@\n"; |
| 206 |
} |
} |
| 207 |
} |
} |
| 208 |
|
|
| 209 |
printf $outfile "\n"; |
# printf $outfile "\n"; |
| 210 |
|
|
| 211 |
# End |
# End |
Parent Directory
| 
Revision Log
| 
Patch