Split the handling for "Illegal character" and "Illegal character after '_'"

After applying this patch, both can now be triggered at once, whereas
previously any use of '_' would trigger the "after '_'" variant.  Since
the two warnings warn for different reasons, there's no reason to
conflate the two.  Also updated perldiag with a clearer explanation
of the tighter restrictions after an underscore.

(In the tests, the change of uniproto12 to uniproto13 is merely correcting
an error from a previous patch, reusing the name would conflate
two kinds of tests in one statement).

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index fa9d7f2..6552f67 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2231,7 +2231,9 @@ offending digit.
 =item Illegal character after '_' in prototype for %s : %s
 
 (W illegalproto) An illegal character was found in a prototype declaration.
-Legal characters in prototypes are $, @, %, *, ;, [, ], &, \, and +.
+The '_' in a prototype must be followed by a ';', indicating the rest of
+the parameters are optional, or one of '@' or '%', since those two will
+accept 0 or more final parameters.
 
 =item Illegal character \%o (carriage return)
 

diff --git a/t/comp/proto.t b/t/comp/proto.t
index d472cd3..213ae3a 100644 (file)
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -18,7 +18,7 @@ BEGIN {
 # strict
 use strict;
 
-print "1..187\n";
+print "1..196\n";
 
 my $i = 1;
 
@@ -669,19 +669,43 @@ for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
   
   eval 'sub badproto (@bar) { 1; }';
   print "not " unless $warn =~ /Illegal character in prototype for main::badproto : \@bar/;
-  print "ok ", $i++, "\n";
+  print "ok ", $i++, " checking badproto - (\@bar)\n";
 
   eval 'sub badproto2 (bar) { 1; }';
   print "not " unless $warn =~ /Illegal character in prototype for main::badproto2 : bar/;
-  print "ok ", $i++, "\n";
+  print "ok ", $i++, " checking badproto2 - (bar)\n";
   
   eval 'sub badproto3 (&$bar$@) { 1; }';
   print "not " unless $warn =~ /Illegal character in prototype for main::badproto3 : &\$bar\$\@/;
-  print "ok ", $i++, "\n";
+  print "ok ", $i++, " checking badproto3 - (&\$bar\$\@)\n";
   
   eval 'sub badproto4 (@ $b ar) { 1; }';
+  # This one emits two warnings
   print "not " unless $warn =~ /Illegal character in prototype for main::badproto4 : \@ \$b ar/;
-  print "ok ", $i++, "\n";
+  print "ok ", $i++, " checking badproto4 - (\@ \$b ar) - illegal character\n";
+  print "not " unless $warn =~ /Prototype after '\@' for main::badproto4 : \@ \$b ar/;
+  print "ok ", $i++, " checking badproto4 - (\@ \$b ar) - prototype after '\@'\n";
+
+  eval 'sub badproto5 ($_$) { 1; }';
+  print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto5 : \$_\$/;
+  print "ok ", $i++, " checking badproto5 - (\$_\$) - illegal character after '_'\n";
+  print "not " if $warn =~ /Illegal character in prototype for main::badproto5 : \$_\$/;
+  print "ok ", $i++, " checking badproto5 - (\$_\$) - but not just illegal character\n";
+  eval 'sub badproto6 (bar_) { 1; }';
+  print "not " unless $warn =~ /Illegal character in prototype for main::badproto6 : bar_/;
+  print "ok ", $i++, " checking badproto6 - (bar_) - illegal character\n";
+  print "not " if $warn =~ /Illegal character after '_' in prototype for main::badproto6 : bar_/;
+  print "ok ", $i++, " checking badproto6 - (bar_) - shouldn't add \"after '_'\"\n";
+  eval 'sub badproto7 (_;bar) { 1; }';
+  print "not " unless $warn =~ /Illegal character in prototype for main::badproto7 : _;bar/;
+  print "ok ", $i++, " checking badproto7 - (_;bar) - illegal character\n";
+  print "not " if $warn =~ /Illegal character after '_' in prototype for main::badproto7 : _;bar/;
+  print "ok ", $i++, " checking badproto7 - (_;bar) - shouldn't add \"after '_'\"\n";
+  eval 'sub badproto8 (_b) { 1; }';
+  print "not " unless $warn =~ /Illegal character after '_' in prototype for main::badproto8 : _b/;
+  print "ok ", $i++, " checking badproto8 - (_b) - illegal character after '_'\n";
+  print "not " unless $warn =~ /Illegal character in prototype for main::badproto8 : _b/;
+  print "ok ", $i++, " checking badproto8 - (_b) - just illegal character\n";
 }
 
 # make sure whitespace in prototypes works
@@ -745,8 +769,9 @@ print "not "
  unless eval 'sub uniproto12 (;;;+) {} uniproto12 $_, 1' or warn $@;
 print "ok ", $i++, " - uniproto12 (;;;*)\n";
 print "not "
- unless eval 'sub uniproto12 ( ; ; ; + ) {} uniproto12 $_, 1' or warn $@;
-print "ok ", $i++, " - uniproto12 ( ; ; ; * )\n";
+ unless eval 'sub uniproto13 ( ; ; ; + ) {} uniproto13 $_, 1' or warn $@;
+print "ok ", $i++, " - uniproto13 ( ; ; ; * )\n";
+
 
 # Test that a trailing semicolon makes a sub have listop precedence
 sub unilist ($;)  { $_[0]+1 }

diff --git a/toke.c b/toke.c
index 11b235f..8fc205f 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1608,7 +1608,7 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
     bool proto_after_greedy_proto = FALSE;
     bool must_be_last = FALSE;
     bool underscore = FALSE;
-    bool seen_underscore = FALSE;
+    bool bad_proto_after_underscore = FALSE;
 
     PERL_ARGS_ASSERT_VALIDATE_PROTO;
 
@@ -1620,16 +1620,15 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
        if (!isSPACE(*p)) {
            if (must_be_last)
                proto_after_greedy_proto = TRUE;
+           if (underscore) {
+               if (!strchr(";@%", *p))
+                   bad_proto_after_underscore = TRUE;
+               underscore = FALSE;
+           }
            if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
                bad_proto = TRUE;
            }
            else {
-               if (underscore) {
-                   if(!strchr(";@%", *p))
-                       bad_proto = TRUE;
-                   underscore = FALSE;
-               }
-
                if (*p == '[')
                    in_brackets = TRUE;
                else if (*p == ']')
@@ -1641,7 +1640,7 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
                    greedy_proto = *p;
                }
                else if (*p == '_')
-                   underscore = seen_underscore = TRUE;
+                   underscore = TRUE;
            }
            if (*p == '\\')
                after_slash = TRUE;
@@ -1664,8 +1663,12 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
                        greedy_proto, SVfARG(name), p);
        if (bad_proto)
            Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
-                       "Illegal character %sin prototype for %"SVf" : %s",
-                       seen_underscore ? "after '_' " : "", SVfARG(name), p);
+                       "Illegal character in prototype for %"SVf" : %s",
+                       SVfARG(name), p);
+       if (bad_proto_after_underscore)
+           Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+                       "Illegal character after '_' in prototype for %"SVf" : %s",
+                       SVfARG(name), p);
     }
 
     return (! (proto_after_greedy_proto || bad_proto) );