From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 10 Dec 2009 18:59:45 +0000 (+0000)
Subject: Move prototype parsing related warnings from the 'syntax' top level warnings category... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=197afce1e759b5f0a1885a151064a83b27a7324e;p=p5sagit%2Fp5-mst-13.2.git

Move prototype parsing related warnings from the 'syntax' top level warnings category to a new 'illegalproto' subcategory.

Two warnings can be emitted when parsing a prototype -

  Illegal character in prototype for %s : %s
  Prototype after '%c' for %s : %s

The first one is emitted when any invalid character is found, the latter
when further prototype-type stuff is found after a slurpy entry (i.e. valid
character but in such a place as to be a no-op, and therefore likely a bug).

These warnings are distinct from those emitted when a sub is overwritten by
one with a different prototype, and when calls are made to subroutines with
prototypes - those are in the pre-existing sub-category 'prototype'.

Since modules such as signatures.pm and Web::Simple only need to disable
the warnings during parsing, I chose to add a new category containing only
these. Moving these warnings into the 'prototype' sub-category would have
forced authors to disable more warnings than they intended, and the entire
raison d'etre of this patch is to allow the specific warnings involved to
be disabled.

In order to maintain compatibility with existing code, the new location
needed to be a sub-category of 'syntax' - this means that

  no warnings 'syntax';

will continue to work as expected - even in cases like Web::Simple where all
subcategories extant prior to this patch are re-enabled (this is another
reason why a move into the 'protoype' category would not achieve the desired
goal).

The category name 'illegalproto' was chosen because the most common warning
to encounter is the "Illegal character" one, and therefore 'illegalproto'
while minorly inaccurate by ignoring the (relatively recent and unknown)
second warning is an easy name to spot on an initial skim of perllexwarn
and will behave as expected by also disabling the case of an unusual prototype
that happens to look like a normal one.

This patch updates pod/perllexwarn.pod, perldiag.pod and perl5113delta.pod
to document the new category, toke.c and warnings.pl to create and implement
the new category, and a new test t/op/protowarn.t that verifies the new
behaviour in a number of cases. It also includes the files generated by
regen.pl that are found in the repo - notably warnings.h and lib/warnings.pm.
---

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 771c98c..55837ba 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -213,10 +213,11 @@ our %Offsets = (
     # Warnings Categories added in Perl 5.011
 
     'imprecision'	=> 92,
+    'illegalproto'	=> 94,
   );
 
 our %Bits = (
-    'all'		=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
+    'all'		=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
     'ambiguous'		=> "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
     'bareword'		=> "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
     'closed'		=> "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -227,6 +228,7 @@ our %Bits = (
     'exec'		=> "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'		=> "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
     'glob'		=> "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+    'illegalproto'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
     'imprecision'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
     'inplace'		=> "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
     'internal'		=> "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
@@ -254,7 +256,7 @@ our %Bits = (
     'severe'		=> "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
     'signal'		=> "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
     'substr'		=> "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
-    'syntax'		=> "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
+    'syntax'		=> "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
     'taint'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
     'threads'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
     'uninitialized'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
@@ -266,7 +268,7 @@ our %Bits = (
   );
 
 our %DeadBits = (
-    'all'		=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
+    'all'		=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
     'ambiguous'		=> "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
     'bareword'		=> "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
     'closed'		=> "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -277,6 +279,7 @@ our %DeadBits = (
     'exec'		=> "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'		=> "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
     'glob'		=> "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+    'illegalproto'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
     'imprecision'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
     'inplace'		=> "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
     'internal'		=> "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
@@ -304,7 +307,7 @@ our %DeadBits = (
     'severe'		=> "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
     'signal'		=> "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
     'substr'		=> "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
-    'syntax'		=> "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
+    'syntax'		=> "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
     'taint'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
     'threads'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
     'uninitialized'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
@@ -316,7 +319,7 @@ our %DeadBits = (
   );
 
 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 94 ;
+$LAST_BIT = 96 ;
 $BYTES    = 12 ;
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/pod/perl5113delta.pod b/pod/perl5113delta.pod
index 77918e2..bdc7061 100644
--- a/pod/perl5113delta.pod
+++ b/pod/perl5113delta.pod
@@ -443,6 +443,24 @@ C<sort> called recursively from within an active comparison subroutine no longer
 
 =item *
 
+The two warnings :
+
+  Illegal character in prototype for %s : %s
+  Prototype after '%c' for %s : %s
+
+have been moved from the C<syntax> top-level warnings category into a new
+first-level category, C<illegalproto>. These two warnings are currently the
+only ones emitted during parsing of an invalid/illegal prototype, so one
+can now do
+
+  no warnings 'illegalproto';
+
+to suppress only those, but not other syntax-related warnings. Warnings where
+prototypes are changed, ignored, or not met are still in the C<prototype>
+category as before.
+
+=item *
+
 C<split> now warns when called in void context
 
 
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 320e46a..6656148 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1926,8 +1926,8 @@ to your Perl administrator.
 
 =item Illegal character in prototype for %s : %s
 
-(W syntax) An illegal character was found in a prototype declaration.  Legal
-characters in prototypes are $, @, %, *, ;, [, ], &, and \.
+(W illegalproto) An illegal character was found in a prototype declaration.
+Legal characters in prototypes are $, @, %, *, ;, [, ], &, and \.
 
 =item Illegal declaration of anonymous subroutine
 
@@ -3535,7 +3535,7 @@ in L<perlos2>.
 
 =item Prototype after '%c' for %s : %s
 
-(W syntax) A character follows % or @ in a prototype. This is useless,
+(W illegalproto) A character follows % or @ in a prototype. This is useless,
 since % and @ gobble the rest of the subroutine arguments.
 
 =item Prototype mismatch: %s vs %s
diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod
index 1eb8b30..45a7f5f 100644
--- a/pod/perllexwarn.pod
+++ b/pod/perllexwarn.pod
@@ -278,6 +278,8 @@ The current hierarchy is:
        |                |
        |                +- digit
        |                |
+       |                +- illegalproto
+       |                |
        |                +- parenthesis
        |                |
        |                +- precedence
diff --git a/t/op/protowarn.t b/t/op/protowarn.t
new file mode 100644
index 0000000..0cf946a
--- /dev/null
+++ b/t/op/protowarn.t
@@ -0,0 +1,110 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+}
+
+use strict;
+use warnings;
+
+BEGIN {
+    require 'test.pl';
+    plan( tests => 12 );
+}
+
+use vars qw{ @warnings $sub $warn };
+
+BEGIN {
+    $warn = 'Illegal character in prototype';
+}
+
+sub one_warning_ok {
+    cmp_ok(scalar(@warnings), '==', 1, 'One warning');
+    cmp_ok(substr($warnings[0],0,length($warn)),'eq',$warn,'warning message');
+    @warnings = ();
+}
+
+sub no_warnings_ok {
+    cmp_ok(scalar(@warnings), '==', 0, 'No warnings');
+    @warnings = ();
+}
+
+BEGIN {
+    $SIG{'__WARN__'} = sub { push @warnings, @_ };
+    $| = 1;
+}
+
+BEGIN { @warnings = () }
+
+$sub = sub (x) { };
+
+BEGIN {
+    one_warning_ok;
+}
+
+{
+    no warnings 'syntax';
+    $sub = sub (x) { };
+}
+
+BEGIN {
+    no_warnings_ok;
+}
+
+{
+    no warnings 'illegalproto';
+    $sub = sub (x) { };
+}
+
+BEGIN {
+    no_warnings_ok;
+}
+
+{
+    no warnings 'syntax';
+    use warnings 'illegalproto';
+    $sub = sub (x) { };
+}
+
+BEGIN {
+    one_warning_ok;
+}
+
+BEGIN {
+    $warn = q{Prototype after '@' for};
+}
+
+$sub = sub (@$) { };
+
+BEGIN {
+    one_warning_ok;
+}
+
+{
+    no warnings 'syntax';
+    $sub = sub (@$) { };
+}
+
+BEGIN {
+    no_warnings_ok;
+}
+
+{
+    no warnings 'illegalproto';
+    $sub = sub (@$) { };
+}
+
+BEGIN {
+    no_warnings_ok;
+}
+
+{
+    no warnings 'syntax';
+    use warnings 'illegalproto';
+    $sub = sub (@$) { };
+}
+
+BEGIN {
+    one_warning_ok;
+}
diff --git a/toke.c b/toke.c
index 1398439..deae6a5 100644
--- a/toke.c
+++ b/toke.c
@@ -7348,7 +7348,7 @@ Perl_yylex(pTHX)
 		    bool must_be_last = FALSE;
 		    bool underscore = FALSE;
 		    bool seen_underscore = FALSE;
-		    const bool warnsyntax = ckWARN(WARN_SYNTAX);
+		    const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
 
 		    s = scan_str(s,!!PL_madskills,FALSE);
 		    if (!s)
@@ -7360,7 +7360,7 @@ Perl_yylex(pTHX)
 			if (!isSPACE(*p)) {
 			    d[tmp++] = *p;
 
-			    if (warnsyntax) {
+			    if (warnillegalproto) {
 				if (must_be_last)
 				    proto_after_greedy_proto = TRUE;
 				if (!strchr("$@%*;[]&\\_", *p)) {
@@ -7393,11 +7393,11 @@ Perl_yylex(pTHX)
 		    }
 		    d[tmp] = '\0';
 		    if (proto_after_greedy_proto)
-			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+			Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
 				    "Prototype after '%c' for %"SVf" : %s",
 				    greedy_proto, SVfARG(PL_subname), d);
 		    if (bad_proto)
-			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+			Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
 				    "Illegal character %sin prototype for %"SVf" : %s",
 				    seen_underscore ? "after '_' " : "",
 				    SVfARG(PL_subname), d);
diff --git a/warnings.h b/warnings.h
index 56b3079..3ed9ecf 100644
--- a/warnings.h
+++ b/warnings.h
@@ -79,6 +79,7 @@
 /* Warnings Categories added in Perl 5.011 */
 
 #define WARN_IMPRECISION	46
+#define WARN_ILLEGALPROTO	47
 
 #define WARNsize		12
 #define WARN_ALLstring		"\125\125\125\125\125\125\125\125\125\125\125\125"
diff --git a/warnings.pl b/warnings.pl
index 835fd7c..d3aca3d 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -46,6 +46,7 @@ my $tree = {
        	 			'printf'	=> [ 5.008, DEFAULT_OFF],
        	 			'prototype'	=> [ 5.008, DEFAULT_OFF],
        	 			'qw'		=> [ 5.008, DEFAULT_OFF],
+                                'illegalproto'  => [ 5.011, DEFAULT_OFF],
 			   }],
        	'severe'	=> [ 5.008, { 	
 				'inplace'	=> [ 5.008, DEFAULT_ON],