Add back-compat (?[ ]) tests
authorKarl Williamson <public@khwilliamson.com>
Fri, 11 Jan 2013 18:17:32 +0000 (11:17 -0700)
committerKarl Williamson <public@khwilliamson.com>
Fri, 11 Jan 2013 18:50:39 +0000 (11:50 -0700)
This adds testing of (?[ ]), using the same tests, t/re/re_tests<
as are used by many of the regular expression .t files.  Basically, it
converts the [bracketed] character classes in these tests to the new
syntax and verifies that they work there.

Some tests won't work in one or the other, and the capability to skip
depending on the .t is added

MANIFEST
t/re/re_tests
t/re/regex_sets_compat.t [new file with mode: 0644]
t/re/regexp.t

index 48a7dcf..5791283 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5492,6 +5492,7 @@ t/re/regexp.t                     See if regular expressions work
 t/re/regexp_trielist.t         See if regular expressions work with trie optimisation
 t/re/regexp_unicode_prop.t     See if unicode properties work in regular expressions as expected
 t/re/regexp_unicode_prop_thr.t See if unicode properties work in regular expressions as expected under threads
+t/re/regex_sets_compat.t       Test (?[ ]) is compatible with old [ ]
 t/re/regex_sets.t              Test (?[ ])
 t/re/reg_fold.t                        See if case folding works properly
 t/re/reg_mesg.t                        See if one can get regular expression errors
index df50965..e2a7e89 100644 (file)
@@ -108,7 +108,7 @@ a[b-d]e     ace     y       $&      ace
 a[b-d] aac     y       $&      ac
 a[-b]  a-      y       $&      a-
 a[b-]  a-      y       $&      a-
-a[b-a] -       c       -       Invalid [] range \"b-a\"
+a[b-a] -       c       -       Invalid [] range
 a[]b   -       c       -       Unmatched [
 a[     -       c       -       Unmatched [
 a]     a]      y       $&      a]
@@ -352,7 +352,7 @@ a[-]?c      ac      y       $&      ac
 'a[b-d]'i      AAC     y       $&      AC
 'a[-b]'i       A-      y       $&      A-
 'a[b-]'i       A-      y       $&      A-
-'a[b-a]'i      -       c       -       Invalid [] range \"b-a\"
+'a[b-a]'i      -       c       -       Invalid [] range
 'a[]b'i        -       c       -       Unmatched [
 'a['i  -       c       -       Unmatched [
 'a]'i  A]      y       $&      A]
@@ -876,12 +876,18 @@ foo.bart  foo.bart        y       -       -
 .[X](.+)+[X][X]        bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n       -       -
 .[X][X](.+)+[X]        bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n       -       -
 tt+$   xxxtt   y       -       -
-([a-\d]+)      za-9z   y       $1      a-9
-([\d-z]+)      a0-za   y       $1      0-z
-([\d-\s]+)     a0- z   y       $1      0- 
-([a-[:digit:]]+)       za-9z   y       $1      a-9
-([[:digit:]-z]+)       =0-z=   y       $1      0-z
-([[:digit:]-[:alpha:]]+)       =0-z=   y       $1      0-z
+([a-\d]+)      za-9z   Sy      $1      a-9
+([a-\d]+)      -       sc      -       False [] range
+([\d-z]+)      a0-za   Sy      $1      0-z
+([\d-z]+)      -       sc      $1      False [] range
+([\d-\s]+)     a0- z   Sy      $1      0- 
+([\d-\s]+)     -       sc      $1      False [] range
+([a-[:digit:]]+)       za-9z   Sy      $1      a-9
+([a-[:digit:]]+)       -       sc      -       False [] range
+([[:digit:]-z]+)       =0-z=   Sy      $1      0-z
+([[:digit:]-z]+)       -       sc      c       False [] range
+([[:digit:]-[:alpha:]]+)       =0-z=   Sy      $1      0-z
+([[:digit:]-[:alpha:]]+)       -       sc      -       False [] range
 \GX.*X aaaXbX  n       -       -
 (\d+\.\d+)     3.1415926       y       $1      3.1415926
 (\ba.{0,10}br) have a web browser      y       $1      a web br
@@ -1434,7 +1440,8 @@ abc\N     abc\n   n
 # and bypasses the lexer.
 /\N{U+}/       -       c       -       Invalid hexadecimal number
 # Below currently gives a misleading message
-/[\N{U+}]/     -       c       -       Unmatched
+/[\N{U+}]/     -       Sc      -       Unmatched
+/[\N{U+}]/     -       sc      -       Syntax error in (?[...])
 /abc\N{def/    -       c       -       Missing right brace
 /\N{U+4AG3}/   -       c       -       Illegal hexadecimal digit
 /[\N{U+4AG3}]/ -       c       -       Illegal hexadecimal digit
@@ -1482,14 +1489,18 @@ a\97    a97     y       $&      a97
 
 
 # The below was inserting a NULL into the character class.
-[\8\9] \000    n       -       -
-[\8\9] 8       y       $&      8
-[\8\9] 9       y       $&      9
+[\8\9] \000    Sn      -       -
+[\8\9] -       sc      $&      Unrecognized escape \\8 in character class
+[\8\9] 8       Sy      $&      8
+[\8\9] 9       Sy      $&      9
 
 # Verify that reads 1-3 octal digits, and that \_ works in char class
-[\0]   \000    y       $&      \000
-[\07]  \007    y       $&      \007
-[\07]  7\000   n       -       -
+[\0]   \000    Sy      $&      \000
+[\0]   -       sc      -       Need exactly 3 octal digits
+[\07]  \007    Sy      $&      \007
+[\07]  -       sc      -       Need exactly 3 octal digits
+[\07]  7\000   Sn      -       -
+[\07]  -       sc      -       Need exactly 3 octal digits
 [\006] \006    y       $&      \006
 [\006] 6\000   n       -       -
 [\0005]        \0005   y       $&      \000
@@ -1531,7 +1542,7 @@ a\97      a97     y       $&      a97
 # Normally 1E9E generates a multi-char fold, but not in inverted class;
 # See [perl #89750].  This makes sure that the simple fold gets generated
 # in that case, to DF.
-/[^\x{1E9E}]/i \x{DF}  n       -       -
+/[^\x{1E9E}]/i \x{DF}  Sn      -       -
 
 # RT #96354
 /^.*\d\H/      X1      n       -       -
@@ -1543,7 +1554,7 @@ a\97      a97     y       $&      a97
 /^\p{L}/       \x{3400}        y       $&      \x{3400}
 
 # RT #89774
-/[s\xDF]a/ui   ssa     y       $&      ssa
+/[s\xDF]a/ui   ssa     Sy      $&      ssa
 /[s\xDF]a/ui   sa      y       $&      sa
 
 # RT #99928
diff --git a/t/re/regex_sets_compat.t b/t/re/regex_sets_compat.t
new file mode 100644 (file)
index 0000000..27eb309
--- /dev/null
@@ -0,0 +1,15 @@
+#!./perl
+
+# This tests that the (?[...]) feature doesn't introduce unexpected
+# differences from regular bracketed character classes.  It just sets a flag
+# and calls regexp.t which will run through its test suite, modifiying the
+# tests to use (?[...]) instead wherever the test uses [].
+
+BEGIN { $regex_sets = 1; }
+for $file ('./re/regexp.t', './t/re/regexp.t', ':re:regexp.t') {
+    if (-r $file) {
+       do $file or die $@;
+       exit;
+    }
+}
+die "Cannot find ./re/regexp.t or ./t/re/regexp.t\n";
index 85edbfa..21cae1d 100644 (file)
@@ -18,6 +18,8 @@
 #      B       test exposes a known bug in Perl, should be skipped
 #      b       test exposes a known bug in Perl, should be skipped if noamp
 #      t       test exposes a bug with threading, TODO if qr_embed_thr
+#       s       test should only be run for regex_sets_compat.t
+#       S       test should not be run for regex_sets_compat.t
 #
 # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
 #
@@ -67,7 +69,8 @@ sub _comment {
 use strict;
 use warnings FATAL=>"all";
 use vars qw($bang $ffff $nulnul); # used by the tests
-use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
+use vars qw($qr $skip_amp $qr_embed $qr_embed_thr $regex_sets); # set by our callers
+
 
 
 if (!defined $file) {
@@ -96,24 +99,210 @@ foreach (@tests) {
         next;
     }
     chomp;
-    s/\\n/\n/g;
+    s/\\n/\n/g unless $regex_sets;
     my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
     $reason = '' unless defined $reason;
     my $input = join(':',$pat,$subject,$result,$repl,$expect);
     # the double '' below keeps simple syntax highlighters from going crazy
     $pat = "'$pat'" unless $pat =~ /^[:''\/]/; 
     $pat =~ s/(\$\{\w+\})/$1/eeg;
-    $pat =~ s/\\n/\n/g;
+    $pat =~ s/\\n/\n/g unless $regex_sets;
     $subject = eval qq("$subject"); die $@ if $@;
     $expect  = eval qq("$expect"); die $@ if $@;
     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
     my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
     my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
     ++$skip if $result =~ s/M// && !defined &DynaLoader::boot_DynaLoader;
+    if ($result =~ s/ ( [Ss] ) //x) {
+        if (($1 eq 'S' && $regex_sets) || ($1 eq 's' && ! $regex_sets)) {
+            $skip++;
+            $reason = "Test not valid for $0";
+        }
+    }
     $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
     $result =~ s/B//i unless $skip;
     my $todo= $result =~ s/T// ? " # TODO" : "";
-    
+    if (! $skip && $regex_sets) {
+
+        # If testing regex sets, change the [bracketed] classes into
+        # (?[bracketed]).
+
+        if ($pat !~ / \[ /x) {
+
+            $skip++;
+            $reason = "Pattern doesn't contain [brackets]";
+        }
+        else { # Use non-regex features of Perl to accomplish this.
+            my $modified = "";
+            my $in_brackets = 0;
+
+            # Go through the pattern character-by-character.  We also add
+            # blanks around each token to test the /x parts of (?[ ])
+            my $pat_len = length($pat);
+      CHAR: for (my $i = 0; $i < $pat_len; $i++) {
+                my $curchar = substr($pat, $i, 1);
+                if ($curchar eq '\\') {
+                    $modified .= " " if $in_brackets;
+                    $modified .= $curchar;
+                    $i++;
+
+                    # Get the character the backslash is escaping
+                    $curchar = substr($pat, $i, 1);
+                    $modified .= $curchar;
+
+                    # If the character following that is a '{}', treat the
+                    # entire amount as a single token
+                    if ($i < $pat_len -1 && substr($pat, $i+1, 1) eq '{') {
+                        my $j = index($pat, '}', $i+2);
+                        if ($j < 0) {
+                            last unless $in_brackets;
+                            if ($result eq 'c') {
+                                $skip++;
+                                $reason = "Can't handle compilation errors with unmatched '{'";
+                            }
+                            else {
+                                print "not ok $test # Problem in $0; original = '$pat'; mod = '$modified'\n";
+                                next TEST;
+                            }
+                        }
+                        $modified .= substr($pat, $i+1, $j - $i);
+                        $i = $j;
+                    }
+                    elsif ($curchar eq 'x') {
+
+                        # \x without brackets is supposed to be followed by 2
+                        # hex digits.  Take up to 2, and then add a blank
+                        # after the last one.  This avoids getting errors from
+                        # (?[ ]) for run-ons, like \xabc
+                        my $j = $i + 1;
+                        for (; $j < $i + 3 && $j < $pat_len; $j++) {
+                            my $curord = ord(substr($pat, $j, 1));
+                            if (!(($curord >= ord("A") && $curord <= ord("F"))
+                                 || ($curord >= ord("a") && $curord <= ord("f"))
+                                 || ($curord >= ord("0") && $curord <= ord("9"))))
+                            {
+                                $j++;
+                                last;
+                            }
+                        }
+                        $j--;
+                        $modified .= substr($pat, $i + 1, $j - $i) . " ";
+                        $i = $j;
+                    }
+                    elsif (ord($curchar) >= ord('0')
+                           && (ord($curchar) <= ord('7')))
+                    {
+                        # Similarly, octal constants have up to 3 digits.
+                        my $j = $i + 1;
+                        for (; $j < $i + 3 && $j < $pat_len; $j++) {
+                            my $curord = ord(substr($pat, $j, 1));
+                            if (! ($curord >= ord("0") &&  $curord <= ord("7"))) {
+                                $j++;
+                                last;
+                            }
+                        }
+                        $j--;
+                        $modified .= substr($pat, $i + 1, $j - $i);
+                        $i = $j;
+                    }
+
+                    next;
+                } # End of processing a backslash sequence
+
+                if (! $in_brackets  # Skip (?{ })
+                    && $curchar eq '('
+                    && $i < $pat_len - 2
+                    && substr($pat, $i+1, 1) eq '?'
+                    && substr($pat, $i+2, 1) eq '{')
+                {
+                    $skip++;
+                    $reason = "Pattern contains '(?{'";
+                    last;
+                }
+
+                # Closing ']'
+                if ($curchar eq ']' && $in_brackets) {
+                    $modified .= " ] ])";
+                    $in_brackets = 0;
+                    next;
+                }
+
+                # A regular character.
+                if ($curchar ne '[') {
+                    if (! $in_brackets) {
+                        $modified .= $curchar;
+                    }
+                    else {
+                        $modified .= " $curchar ";
+                    }
+                    next;
+                }
+
+                # Here is a '['; If not in a bracketed class, treat as the
+                # beginning of one.
+                if (! $in_brackets) {
+                    $in_brackets = 1;
+                    $modified .= "(?[ [ ";
+
+                    # An immediately following ']' or '^]' is not the ending
+                    # of the class, but is to be treated literally.
+                    if ($i < $pat_len - 1
+                        && substr($pat, $i+1, 1) eq ']')
+                    {
+                        $i ++;
+                        $modified .= " ] ";
+                    }
+                    elsif ($i < $pat_len - 2
+                            && substr($pat, $i+1, 1) eq '^'
+                            && substr($pat, $i+2, 1) eq ']')
+                    {
+                        $i += 2;
+                        $modified .= " ^ ] ";
+                    }
+                    next;
+                }
+
+                # Here is a plain '[' within [ ].  Could mean wants to
+                # match a '[', or it could be a posix class that has a
+                # corresponding ']'.  Absorb either
+
+                $modified .= ' [';
+                last if $i >= $pat_len - 1;
+
+                $i++;
+                $curchar = substr($pat, $i, 1);
+                if ($curchar =~ /[:=.]/) {
+                    for (my $j = $i + 1; $j < $pat_len; $j++) {
+                        next unless substr($pat, $j, 1) eq ']';
+                        last if $j - $i < 2;
+                        if (substr($pat, $j - 1, 1) eq $curchar) {
+                            # Here, is a posix class
+                            $modified .= substr($pat, $i, $j - $i + 1) . " ";
+                            $i = $j;
+                            next CHAR;
+                        }
+                    }
+                }
+
+                # Here wasn't a posix class, just process normally
+                $modified .= " $curchar ";
+            }
+
+            if ($in_brackets && ! $skip) {
+                if ($result eq 'c') {
+                    $skip++;
+                    $reason = "Can't figure out where to put the (?[ and ]) since is a compilation error";
+                }
+                else {
+                    print "not ok $test # Problem in $0; original = '$pat'; mod = '$modified'\n";
+                    next TEST;
+                }
+            }
+
+            # Use our modified pattern instead of the original
+            $pat = $modified;
+        }
+    }
 
     for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
                   'utf8::upgrade($subject); study $subject') {
@@ -155,6 +344,7 @@ EOFCODE
                 \$got = "$repl";
 EOFCODE
         }
+        $code = "no warnings 'experimental::regex_sets';$code" if $regex_sets;
         #$code.=qq[\n\$expect="$expect";\n];
         #use Devel::Peek;
         #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;