From: Renee Baecker <renee.baecker@smart-websolutions.de>
Date: Mon, 26 May 2008 13:08:27 +0000 (+0200)
Subject: Add a new warning, "Prototype after '%s'"
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9e8d7757ba54bcb0e5a4571f5fbc9ca113df7b70;p=p5sagit%2Fp5-mst-13.2.git

Add a new warning, "Prototype after '%s'"
Based on:
Subject: Re: [perl #36673] sub foo(@$) {} should generate an error
Message-ID: <483A9A2B.6020808@smart-websolutions.de>

p4raw-id: //depot/perl@34021
---

diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
index f4842a7..b82268d 100644
--- a/t/lib/warnings/toke
+++ b/t/lib/warnings/toke
@@ -852,3 +852,26 @@ use warnings 'deprecated';
 our $bar :unique;
 EXPECT
 Use of :unique is deprecated at - line 4.
+########
+# toke.c
+use warnings "syntax";
+sub proto_after_array(@$);
+sub proto_after_arref(\@$);
+sub proto_after_arref2(\[@$]);
+sub proto_after_arref3(\[@$]_);
+sub proto_after_hash(%$);
+sub proto_after_hashref(\%$);
+sub proto_after_hashref2(\[%$]);
+sub underscore_last_pos($_);
+sub underscore2($_;$);
+sub underscore_fail($_$);
+sub underscore_after_at(@_);
+no warnings "syntax";
+sub proto_after_array(@$);
+sub proto_after_hash(%$);
+sub underscore_fail($_$);
+EXPECT
+Prototype after '@' for main::proto_after_array : @$ at - line 3.
+Prototype after '%' for main::proto_after_hash : %$ at - line 7.
+Illegal character in prototype for main::underscore_fail : $_$ at - line 12.
+Prototype after '@' for main::underscore_after_at : @_ at - line 13.
diff --git a/toke.c b/toke.c
index b76e434..5f75233 100644
--- a/toke.c
+++ b/toke.c
@@ -6744,6 +6744,11 @@ Perl_yylex(pTHX)
 		if (*s == '(') {
 		    char *p;
 		    bool bad_proto = FALSE;
+		    bool in_brackets = FALSE;
+		    char greedy_proto = ' ';
+		    bool proto_after_greedy_proto = FALSE;
+		    bool must_be_last = FALSE;
+		    bool underscore = FALSE;
 		    const bool warnsyntax = ckWARN(WARN_SYNTAX);
 
 		    s = scan_str(s,!!PL_madskills,FALSE);
@@ -6755,11 +6760,43 @@ Perl_yylex(pTHX)
 		    for (p = d; *p; ++p) {
 			if (!isSPACE(*p)) {
 			    d[tmp++] = *p;
-			    if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
-				bad_proto = TRUE;
+
+			    if (warnsyntax) {
+				if (must_be_last)
+				    proto_after_greedy_proto = TRUE;
+				if (!strchr("$@%*;[]&\\_", *p)) {
+				    bad_proto = TRUE;
+				}
+				else {
+				    if ( underscore ) {
+					if ( *p != ';' )
+					    bad_proto = TRUE;
+					underscore = FALSE;
+				    }
+				    if ( *p == '[' ) {
+					in_brackets = TRUE;
+				    }
+				    else if ( *p == ']' ) {
+					in_brackets = FALSE;
+				    }
+				    else if ( (*p == '@' || *p == '%') &&
+					 ( tmp < 2 || d[tmp-2] != '\\' ) &&
+					 !in_brackets ) {
+					must_be_last = TRUE;
+					greedy_proto = *p;
+				    }
+				    else if ( *p == '_' ) {
+					underscore = TRUE;
+				    }
+				}
+			    }
 			}
 		    }
 		    d[tmp] = '\0';
+		    if (proto_after_greedy_proto)
+			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+				    "Prototype after '%c' for %"SVf" : %s",
+				    greedy_proto, SVfARG(PL_subname), d);
 		    if (bad_proto)
 			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 				    "Illegal character in prototype for %"SVf" : %s",