Re: enhanced(?) regex error messages

Message-Id: <200008090759.AAA07144@ventrue.yahoo.com>

(plus two small patches sent privately)
(this still seems to leave few test failures)

p4raw-id: //depot/perl@6560

3 files changed, 213 insertions, 27 deletions

diff --git a/t/op/misc.t b/t/op/misc.t
index 00abc99b45..900e014d58 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -346,7 +346,7 @@ print "you die joe!\n" unless "@x" eq 'x y z';
 /(?{"{"})/	# Check it outside of eval too
 EXPECT
 Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern
-/(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1.
+Sequence (?{...}) not terminated or not {}-balanced at <HERE< mark in regex m/(?{ <<<HERE<<< "{"})/ at - line 1.
 ########
 /(?{"{"}})/	# Check it outside of eval too
 EXPECT
diff --git a/t/op/regmesg.t b/t/op/regmesg.t
new file mode 100644
index 0000000000..fa22c0649b
--- /dev/null
+++ b/t/op/regmesg.t
@@ -0,0 +1,185 @@
+#!./perl -w
+
+BEGIN {
+	chdir 't' if -d 't';
+	unshift @INC, '../lib';
+}
+
+my $debug = 1;
+
+##
+## If the markers used are changed (search for "MARKER1" in regcomp.c),
+## update only these two variables, and leave the {#} in the @death/@warning
+## arrays below. The {#} is a meta-marker -- it marks where the marker should
+## go.
+
+my $marker1 = "<HERE<";
+my $marker2 = " <<<HERE<<< ";
+
+##
+## Key-value pairs of code/error of code that should have fatal errors.
+##
+my @death =
+(
+ '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions at {#} mark in regex m/[[=foo=]{#}]/',
+
+ '/(?<= .*)/' =>  'Variable length lookbehind not implemented at {#} mark in regex m/(?<= .*){#}/',
+
+ '/(?<= x{10000})/' => 'Lookbehind longer than 255 not implemented at {#} mark in regex m/(?<= x{10000}){#}/',
+
+ '/(?@)/' => 'Sequence (?@...) not implemented at {#} mark in regex m/(?@{#})/',
+
+ '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced at {#} mark in regex m/(?{{#} 1/',
+
+ '/(?(1x))/' => 'Switch condition not recognized at {#} mark in regex m/(?(1x{#}))/',
+
+ '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches at {#} mark in regex m/(?(1)x|y|{#}z)/',
+
+ '/(?(x)y|x)/' => 'Unknown switch condition (?(x) at {#} mark in regex m/(?({#}x)y|x)/',
+
+ '/(?/' => 'Sequence (? incomplete at {#} mark in regex m/(?{#}/',
+
+ '/(?;x/' => 'Sequence (?;...) not recognized at {#} mark in regex m/(?;{#}x/',
+ '/(?<;x/' => 'Sequence (?<;...) not recognized at {#} mark in regex m/(?<;{#}x/',
+
+ '/((x)/' => 'Unmatched ( at {#} mark in regex m/({#}(x)/',
+
+ '/x{99999}/' => 'Quantifier in {,} bigger than 32766 at {#} mark in regex m/x{{#}99999}/',
+
+ '/x{3,1}/' => 'Can\'t do {n,m} with n > m at {#} mark in regex m/x{3,1}{#}/',
+
+ '/x**/' => 'Nested quantifiers at {#} mark in regex m/x**{#}/',
+
+ '/x[/' => 'Unmatched [ at {#} mark in regex m/x[{#}/',
+
+ '/*/', => 'Quantifier follows nothing at {#} mark in regex m/*{#}/',
+
+ '/\p{x/' => 'Missing right brace on \p{} at {#} mark in regex m/\p{{#}x/',
+
+ 'use utf8; /[\p{x]/' => 'Missing right brace on \p{} at {#} mark in regex m/[\p{{#}x]/',
+
+ '/(x)\2/' => 'Reference to nonexistent group at {#} mark in regex m/(x)\2{#}/',
+
+ 'my $m = chr(92); $m =~ $m', => 'Trailing \ in regex m/\/',
+
+ '/\x{1/' => 'Missing right brace on \x{} at {#} mark in regex m/\x{{#}1/',
+
+ 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} at {#} mark in regex m/[\x{{#}X]/',
+
+ '/\x{x}/' => 'Can\'t use \x{} without \'use utf8\' declaration at {#} mark in regex m/\x{x}{#}/',
+
+ '/[[:barf:]]/' => 'POSIX class [:barf:] unknown at {#} mark in regex m/[[:barf:]{#}]/',
+
+ '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions at {#} mark in regex m/[[=barf=]{#}]/',
+
+ '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions at {#} mark in regex m/[[.barf.]{#}]/',
+  
+ '/[z-a]/' => 'Invalid [] range "z-a" at {#} mark in regex m/[z-a{#}]/',
+);
+
+##
+## Key-value pairs of code/error of code that should have non-fatal warnings.
+##
+@warning = (
+    "m/(?p{ 'a' })/" => "(?p{}) is deprecated - use (??{}) at {#} mark in regex m/(?p{#}{ 'a' })/",
+
+    'm/\b*/' => '\b* matches null string many times at {#} mark in regex m/\b*{#}/',
+
+    'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes at {#} mark in regex m/[:blank:]{#}/',
+
+    "m'[\\y]'"     => 'Unrecognized escape \y in character class passed through at {#} mark in regex m/[\y{#}]/',
+
+    'm/[a-\d]/' => 'False [] range "a-\d" at {#} mark in regex m/[a-\d{#}]/',
+    'm/[\w-x]/' => 'False [] range "\w-" at {#} mark in regex m/[\w-{#}x]/',
+    "m'\\y'"     => 'Unrecognized escape \y passed through at {#} mark in regex m/\y{#}/',
+);
+
+my $total = (@death + @warning)/2;
+
+print "1..$total\n";
+
+my $count = 0;
+
+while (@death)
+{
+    $count++;
+    my $regex = shift @death;
+    my $result = shift @death;
+
+    undef $@;
+    $_ = "x";
+    eval $regex;
+    if (not $@) {
+	if ($debug) {
+	    print "oops, $regex didn't die\n"
+	} else {
+	    print "not ok $count\n";
+	}
+	next;
+    }
+    chomp $@;
+    $@ =~ s/ at \(.*?\) line \d+\.$//;
+    $result =~ s/{\#}/$marker1/;
+    $result =~ s/{\#}/$marker2/;
+    if ($@ ne $result) {
+	if ($debug) {
+	    print "For $regex, expected:\n  $result\nGot:\n  $@\n\n";
+	} else {
+	    print "not ok $count\n";
+	}
+	next;
+    }
+    print "ok $count\n";
+}
+
+
+our $warning;
+$SIG{__WARN__} = sub { $warning = shift };
+
+while (@warning)
+{
+    $count++;
+    my $regex = shift @warning;
+    my $result = shift @warning;
+
+    undef $warning;
+    $_ = "x";
+    eval $regex;
+
+    if ($@)
+    {
+	if ($debug) {
+	    print "oops, $regex died with:\n\t$@\n";
+	} else {
+	    print "not ok $count\n";
+	}
+	next;
+    }
+
+    if (not $warning)
+    {
+	if ($debug) {
+	    print "oops, $regex didn't generate a warning\n";
+	} else {
+	    print "not ok $count\n";
+	}
+	next;
+    }
+    chomp $warning;
+    $warning =~ s/ at \(.*?\) line \d+\.$//;
+    $result =~ s/{\#}/$marker1/;
+    $result =~ s/{\#}/$marker2/;
+    if ($warning ne $result)
+    {
+	if ($debug) {
+	    print "For $regex, expected:\n  $result\nGot:\n  $warning\n\n";
+	} else {
+	    print "not ok $count\n";
+	}
+	next;
+    }
+    print "ok $count\n";
+}
+
+
+
diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp
index ef87b7fbb4..82b9b53722 100644
--- a/t/pragma/warn/regcomp
+++ b/t/pragma/warn/regcomp
@@ -29,7 +29,7 @@ $a =~ /(?=a)*/ ;
 no warnings 'regexp' ;
 $a =~ /(?=a)*/ ;
 EXPECT
-(?=a)* matches null string many times at - line 4.
+(?=a)* matches null string many times at <HERE< mark in regex m/(?=a)* <<<HERE<<< / at - line 4.
 ########
 # regcomp.c [S_study_chunk]
 use warnings 'regexp' ;
@@ -38,7 +38,7 @@ $_ = "" ;
 no warnings 'regexp' ;
 /(?=a)?/;
 EXPECT
-Strange *+?{} on zero-length expression at - line 4.
+Quantifier unexpected on zero-length expression at <HERE< mark in regex m/(?=a)? <<<HERE<<< / at - line 4.
 ########
 # regcomp.c [S_regatom]
 $x = '\m' ;
@@ -47,7 +47,7 @@ $a =~ /a$x/ ;
 no warnings 'regexp' ;
 $a =~ /a$x/ ;
 EXPECT
-/a\m/: Unrecognized escape \m passed through at - line 4.
+Unrecognized escape \m passed through at <HERE< mark in regex m/a\m <<<HERE<<< / at - line 4.
 ########
 # regcomp.c [S_regpposixcc S_checkposixcc]
 BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 }
@@ -61,9 +61,9 @@ no warnings 'regexp' ;
 /[:zog:]/;
 /[[:zog:]]/;
 EXPECT
-Character class syntax [: :] belongs inside character classes at - line 5.
-Character class syntax [: :] belongs inside character classes at - line 6.
-Character class [:zog:] unknown at - line 7.
+POSIX syntax [: :] belongs inside character classes at <HERE< mark in regex m/[:alpha:] <<<HERE<<< / at - line 5.
+POSIX syntax [: :] belongs inside character classes at <HERE< mark in regex m/[:zog:] <<<HERE<<< / at - line 6.
+POSIX class [:zog:] unknown at <HERE< mark in regex m/[[:zog:] <<<HERE<<< ]/
 ########
 # regcomp.c [S_checkposixcc]
 BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 }
@@ -73,8 +73,8 @@ $_ = "" ;
 no warnings 'regexp' ;
 /[.zog.]/;
 EXPECT
-Character class syntax [. .] belongs inside character classes at - line 5.
-Character class syntax [. .] is reserved for future extensions at - line 5.
+POSIX syntax [. .] belongs inside character classes at <HERE< mark in regex m/[.zog.] <<<HERE<<< / at - line 5.
+POSIX syntax [. .] is reserved for future extensions at <HERE< mark in regex m/[.zog.] <<<HERE<<< /
 ########
 # regcomp.c [S_checkposixcc]
 BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 }
@@ -84,7 +84,7 @@ $_ = "" ;
 no warnings 'regexp' ;
 /[[.zog.]]/;
 EXPECT
-Character class syntax [. .] is reserved for future extensions at - line 5.
+POSIX syntax [. .] is reserved for future extensions at <HERE< mark in regex m/[[.zog.] <<<HERE<<< ]/
 ########
 # regcomp.c [S_regclass]
 $_ = "";
@@ -109,14 +109,14 @@ no warnings 'regexp' ;
 /[[:alpha:]-[:digit:]]/;
 /[[:digit:]-[:alpha:]]/;
 EXPECT
-/[a-\d]/: false [] range "a-\d" in regexp at - line 5.
-/[\d-b]/: false [] range "\d-" in regexp at - line 6.
-/[\s-\d]/: false [] range "\s-" in regexp at - line 7.
-/[\d-\s]/: false [] range "\d-" in regexp at - line 8.
-/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 9.
-/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 10.
-/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 11.
-/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12.
+False [] range "a-\d" at <HERE< mark in regex m/[a-\d <<<HERE<<< ]/ at - line 5.
+False [] range "\d-" at <HERE< mark in regex m/[\d- <<<HERE<<< b]/ at - line 6.
+False [] range "\s-" at <HERE< mark in regex m/[\s- <<<HERE<<< \d]/ at - line 7.
+False [] range "\d-" at <HERE< mark in regex m/[\d- <<<HERE<<< \s]/ at - line 8.
+False [] range "a-[:digit:]" at <HERE< mark in regex m/[a-[:digit:] <<<HERE<<< ]/ at - line 9.
+False [] range "[:digit:]-" at <HERE< mark in regex m/[[:digit:]- <<<HERE<<< b]/ at - line 10.
+False [] range "[:alpha:]-" at <HERE< mark in regex m/[[:alpha:]- <<<HERE<<< [:digit:]]/ at - line 11.
+False [] range "[:digit:]-" at <HERE< mark in regex m/[[:digit:]- <<<HERE<<< [:alpha:]]/ at - line 12.
 ########
 # regcomp.c [S_regclassutf8]
 BEGIN {
@@ -148,14 +148,14 @@ no warnings 'regexp' ;
 /[[:alpha:]-[:digit:]]/;
 /[[:digit:]-[:alpha:]]/;
 EXPECT
-/[a-\d]/: false [] range "a-\d" in regexp at - line 12.
-/[\d-b]/: false [] range "\d-" in regexp at - line 13.
-/[\s-\d]/: false [] range "\s-" in regexp at - line 14.
-/[\d-\s]/: false [] range "\d-" in regexp at - line 15.
-/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 16.
-/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 17.
-/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 18.
-/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19.
+False [] range "a-\d" at <HERE< mark in regex m/[a-\d <<<HERE<<< ]/ at - line 12.
+False [] range "\d-" at <HERE< mark in regex m/[\d- <<<HERE<<< b]/ at - line 13.
+False [] range "\s-" at <HERE< mark in regex m/[\s- <<<HERE<<< \d]/ at - line 14.
+False [] range "\d-" at <HERE< mark in regex m/[\d- <<<HERE<<< \s]/ at - line 15.
+False [] range "a-[:digit:]" at <HERE< mark in regex m/[a-[:digit:] <<<HERE<<< ]/ at - line 16.
+False [] range "[:digit:]-" at <HERE< mark in regex m/[[:digit:]- <<<HERE<<< b]/ at - line 17.
+False [] range "[:alpha:]-" at <HERE< mark in regex m/[[:alpha:]- <<<HERE<<< [:digit:]]/ at - line 18.
+False [] range "[:digit:]-" at <HERE< mark in regex m/[[:digit:]- <<<HERE<<< [:alpha:]]/ at - line 19.
 ########
 # regcomp.c [S_regclass S_regclassutf8]
 use warnings 'regexp' ;
@@ -163,4 +163,5 @@ $a =~ /[a\zb]/ ;
 no warnings 'regexp' ;
 $a =~ /[a\zb]/ ;
 EXPECT
-/[a\zb]/: Unrecognized escape \z in character class passed through at - line 3.
+Unrecognized escape \z in character class passed through at <HERE< mark in regex m/[a\z <<<HERE<<< b]/ at - line 3.
+