--- code/trunk/perltest	2007/02/24 21:41:34	91
+++ code/trunk/perltest.pl	2011/07/02 15:20:59	612
@@ -1,4 +1,4 @@
-#! /usr/bin/perl
+#! /usr/bin/env perl
 
 # Program for testing regular expressions with perl to check that PCRE handles
 # them the same. This is the version that supports /8 for UTF-8 testing. As it
@@ -85,11 +85,27 @@
 
   # The private /+ modifier means "print $' afterwards".
 
-  $showrest = ($pattern =~ s/\+(?=[a-z]*$)//);
+  $showrest = ($pattern =~ s/\+(?=[a-zA-Z]*$)//);
 
   # Remove /8 from a UTF-8 pattern.
 
-  $utf8 = $pattern =~ s/8(?=[a-z]*$)//;
+  $utf8 = $pattern =~ s/8(?=[a-zA-Z]*$)//;
+
+  # Remove /J from a pattern with duplicate names.
+
+  $pattern =~ s/J(?=[a-zA-Z]*$)//;
+
+  # Remove /K from a pattern (asks pcretest to check MARK data) */
+
+  $pattern =~ s/K(?=[a-zA-Z]*$)//;
+
+  # Remove /W from a pattern (asks pcretest to set PCRE_UCP)
+
+  $pattern =~ s/W(?=[a-zA-Z]*$)//;
+
+  # Remove /S or /SS from a pattern (asks pcretest to study or not to study)
+
+  $pattern =~ s/S(?=[a-zA-Z]*$)//g;
 
   # Check that the pattern is valid
 
@@ -123,13 +139,15 @@
     chomp;
     printf $outfile "$_\n" if $infile ne "STDIN";
 
-    s/\s+$//;
-    s/^\s+//;
+    s/\s+$//;  # Remove trailing space
+    s/^\s+//;  # Remove leading space
+    s/\\Y//g;  # Remove \Y (pcretest flag to set PCRE_NO_START_OPTIMIZE)
 
     last if ($_ eq "");
     $x = eval "\"$_\"";   # To get escapes processed
 
-    # Empty array for holding results, then do the matching.
+    # Empty array for holding results, ensure $REGERROR and $REGMARK are
+    # unset, then do the matching.
 
     @subs = ();
 
@@ -152,6 +170,9 @@
          "push \@subs,\$16;" .
          "push \@subs,\$'; }";
 
+    undef $REGERROR;
+    undef $REGMARK;
+
     eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
 
     if ($@)
@@ -161,7 +182,10 @@
       }
     elsif (scalar(@subs) == 0)
       {
-      printf $outfile "No match\n";
+      printf $outfile "No match";
+      if (defined $REGERROR && $REGERROR != 1)
+        { print $outfile (", mark = $REGERROR"); }
+      printf $outfile "\n";
       }
     else
       {
@@ -182,6 +206,8 @@
           }
         splice(@subs, 0, 18);
         }
+      if (defined $REGMARK && $REGMARK != 1)
+        { print $outfile ("MK: $REGMARK\n"); }
       }
     }
   }