1#! /usr/bin/env perl 2 3# Program for testing regular expressions with perl to check that PCRE handles 4# them the same. This version supports /8 for UTF-8 testing. However, it needs 5# to have "use utf8" at the start for running the UTF-8 tests, but *not* for 6# the other tests. The only way I've found for doing this is to cat this line 7# in explicitly in the RunPerlTest script. I've also used this method to supply 8# "require Encode" for the UTF-8 tests, so that the main test will still run 9# where Encode is not installed. 10 11# use locale; # With this included, \x0b matches \s! 12 13# Function for turning a string into a string of printing chars. 14 15#require Encode; 16 17sub pchars { 18my($t) = ""; 19 20if ($utf8) 21 { 22 @p = unpack('U*', $_[0]); 23 foreach $c (@p) 24 { 25 if ($c >= 32 && $c < 127) { $t .= chr $c; } 26 else { $t .= sprintf("\\x{%02x}", $c); 27 } 28 } 29 } 30else 31 { 32 foreach $c (split(//, $_[0])) 33 { 34 if (ord $c >= 32 && ord $c < 127) { $t .= $c; } 35 else { $t .= sprintf("\\x%02x", ord $c); } 36 } 37 } 38 39$t; 40} 41 42 43# Read lines from named file or stdin and write to named file or stdout; lines 44# consist of a regular expression, in delimiters and optionally followed by 45# options, followed by a set of test data, terminated by an empty line. 46 47# Sort out the input and output files 48 49if (@ARGV > 0) 50 { 51 open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n"; 52 $infile = "INFILE"; 53 } 54else { $infile = "STDIN"; } 55 56if (@ARGV > 1) 57 { 58 open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n"; 59 $outfile = "OUTFILE"; 60 } 61else { $outfile = "STDOUT"; } 62 63printf($outfile "Perl $] Regular Expressions\n\n"); 64 65# Main loop 66 67NEXT_RE: 68for (;;) 69 { 70 printf " re> " if $infile eq "STDIN"; 71 last if ! ($_ = <$infile>); 72 printf $outfile "$_" if $infile ne "STDIN"; 73 next if ($_ eq ""); 74 75 $pattern = $_; 76 77 while ($pattern !~ /^\s*(.).*\1/s) 78 { 79 printf " > " if $infile eq "STDIN"; 80 last if ! ($_ = <$infile>); 81 printf $outfile "$_" if $infile ne "STDIN"; 82 $pattern .= $_; 83 } 84 85 chomp($pattern); 86 $pattern =~ s/\s+$//; 87 88 # The private /+ modifier means "print $' afterwards". 89 90 $showrest = ($pattern =~ s/\+(?=[a-zA-Z]*$)//); 91 92 # A doubled version is used by pcretest to print remainders after captures 93 94 $pattern =~ s/\+(?=[a-zA-Z]*$)//; 95 96 # Remove /8 from a UTF-8 pattern. 97 98 $utf8 = $pattern =~ s/8(?=[a-zA-Z]*$)//; 99 100 # Remove /J from a pattern with duplicate names. 101 102 $pattern =~ s/J(?=[a-zA-Z]*$)//; 103 104 # Remove /K from a pattern (asks pcretest to check MARK data) */ 105 106 $pattern =~ s/K(?=[a-zA-Z]*$)//; 107 108 # Remove /W from a pattern (asks pcretest to set PCRE_UCP) 109 110 $pattern =~ s/W(?=[a-zA-Z]*$)//; 111 112 # Remove /S or /SS from a pattern (asks pcretest to study or not to study) 113 114 $pattern =~ s/S(?=[a-zA-Z]*$)//g; 115 116 # Remove /Y from a pattern (asks pcretest to disable PCRE optimization) 117 118 $pattern =~ s/Y(?=[a-zA-Z]*$)//; 119 120 # Check that the pattern is valid 121 122 eval "\$_ =~ ${pattern}"; 123 if ($@) 124 { 125 printf $outfile "Error: $@"; 126 next NEXT_RE; 127 } 128 129 # If the /g modifier is present, we want to put a loop round the matching; 130 # otherwise just a single "if". 131 132 $cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if"; 133 134 # If the pattern is actually the null string, Perl uses the most recently 135 # executed (and successfully compiled) regex is used instead. This is a 136 # nasty trap for the unwary! The PCRE test suite does contain null strings 137 # in places - if they are allowed through here all sorts of weird and 138 # unexpected effects happen. To avoid this, we replace such patterns with 139 # a non-null pattern that has the same effect. 140 141 $pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/); 142 143 # Read data lines and test them 144 145 for (;;) 146 { 147 printf "data> " if $infile eq "STDIN"; 148 last NEXT_RE if ! ($_ = <$infile>); 149 chomp; 150 printf $outfile "$_\n" if $infile ne "STDIN"; 151 152 s/\s+$//; # Remove trailing space 153 s/^\s+//; # Remove leading space 154 s/\\Y//g; # Remove \Y (pcretest flag to set PCRE_NO_START_OPTIMIZE) 155 156 last if ($_ eq ""); 157 $x = eval "\"$_\""; # To get escapes processed 158 159 # Empty array for holding results, ensure $REGERROR and $REGMARK are 160 # unset, then do the matching. 161 162 @subs = (); 163 164 $pushes = "push \@subs,\$&;" . 165 "push \@subs,\$1;" . 166 "push \@subs,\$2;" . 167 "push \@subs,\$3;" . 168 "push \@subs,\$4;" . 169 "push \@subs,\$5;" . 170 "push \@subs,\$6;" . 171 "push \@subs,\$7;" . 172 "push \@subs,\$8;" . 173 "push \@subs,\$9;" . 174 "push \@subs,\$10;" . 175 "push \@subs,\$11;" . 176 "push \@subs,\$12;" . 177 "push \@subs,\$13;" . 178 "push \@subs,\$14;" . 179 "push \@subs,\$15;" . 180 "push \@subs,\$16;" . 181 "push \@subs,\$'; }"; 182 183 undef $REGERROR; 184 undef $REGMARK; 185 186 eval "${cmd} (\$x =~ ${pattern}) {" . $pushes; 187 188 if ($@) 189 { 190 printf $outfile "Error: $@\n"; 191 next NEXT_RE; 192 } 193 elsif (scalar(@subs) == 0) 194 { 195 printf $outfile "No match"; 196 if (defined $REGERROR && $REGERROR != 1) 197 { printf $outfile (", mark = %s", &pchars($REGERROR)); } 198 printf $outfile "\n"; 199 } 200 else 201 { 202 while (scalar(@subs) != 0) 203 { 204 printf $outfile (" 0: %s\n", &pchars($subs[0])); 205 printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest; 206 $last_printed = 0; 207 for ($i = 1; $i <= 16; $i++) 208 { 209 if (defined $subs[$i]) 210 { 211 while ($last_printed++ < $i-1) 212 { printf $outfile ("%2d: <unset>\n", $last_printed); } 213 printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i])); 214 $last_printed = $i; 215 } 216 } 217 splice(@subs, 0, 18); 218 } 219 220 # It seems that $REGMARK is not marked as UTF-8 even when use utf8 is 221 # set and the input pattern was a UTF-8 string. We can, however, force 222 # it to be so marked. 223 224 if (defined $REGMARK && $REGMARK != 1) 225 { 226 $xx = $REGMARK; 227 $xx = Encode::decode_utf8($xx) if $utf8; 228 printf $outfile ("MK: %s\n", &pchars($xx)); 229 } 230 } 231 } 232 } 233 234# printf $outfile "\n"; 235 236# End 237