Return to perltest.pl CVS log

Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / pcre

pcre

    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: 
   17: sub pchars {
   18: my($t) = "";
   19: 
   20: if ($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:   }
   30: else
   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: 
   49: if (@ARGV > 0)
   50:   {
   51:   open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n";
   52:   $infile = "INFILE";
   53:   }
   54: else { $infile = "STDIN"; }
   55: 
   56: if (@ARGV > 1)
   57:   {
   58:   open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n";
   59:   $outfile = "OUTFILE";
   60:   }
   61: else { $outfile = "STDOUT"; }
   62: 
   63: printf($outfile "Perl $] Regular Expressions\n\n");
   64: 
   65: # Main loop
   66: 
   67: NEXT_RE:
   68: for (;;)
   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: