Basic bad prototype detection

Message-ID: <Pine.LNX.4.33.0112301948270.9102-200000@localhost.localdomain>

p4raw-id: //depot/perl@13971

3 files changed, 26 insertions, 2 deletions

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1935550821..8ee25f2eac 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1869,6 +1869,13 @@ a builtin library search path, prefix2 is substituted.  The error may
 appear if components are not found, or are too long.  See
 "PERLLIB_PREFIX" in L<perlos2>.
 
+=item Malformed prototype for %s: %s
+
+(F) You declared or tried to use a function with a malformed
+prototype.  The syntax of function prototypes is given a brief
+compile-time check for obvious errors like invalid characters.  A more
+rigorous check is run when the function is called.
+
 =item Malformed UTF-8 character (%s)
 
 Perl detected something that didn't comply with UTF-8 encoding rules.
diff --git a/t/comp/proto.t b/t/comp/proto.t
index a60f36f75b..b42a5cc4c5 100755
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..130\n";
+print "1..133\n";
 
 my $i = 1;
 
@@ -527,3 +527,17 @@ print "ok ", $i++, "\n";
     print "not " unless myref(*myglob)  =~ /^GLOB\(/;
     print "ok ", $i++, "\n";
 }
+
+# check that obviously bad prototypes are getting rejected
+eval 'sub badproto (@bar) { 1; }';
+print "not " unless $@ =~ /^Malformed prototype for main::badproto : \@bar/;
+print "ok ", $i++, "\n";
+
+eval 'sub badproto2 (bar) { 1; }';
+print "not " unless $@ =~ /^Malformed prototype for main::badproto2 : bar/;
+print "ok ", $i++, "\n";
+
+eval 'sub badproto3 (&$bar$@) { 1; }';
+print "not " unless $@ =~ /^Malformed prototype for main::badproto3 : &\$bar\$\@/;
+print "ok ", $i++, "\n";
+
diff --git a/toke.c b/toke.c
index 1527daaff2..55aaedbea1 100644
--- a/toke.c
+++ b/toke.c
@@ -4952,10 +4952,13 @@ Perl_yylex(pTHX)
 		    s = scan_str(s,FALSE,FALSE);
 		    if (!s)
 			Perl_croak(aTHX_ "Prototype not terminated");
-		    /* strip spaces */
+		    /* strip spaces and check for bad characters */
 		    d = SvPVX(PL_lex_stuff);
 		    tmp = 0;
 		    for (p = d; *p; ++p) {
+		        if (!strchr("$@%*;[]&\\ ", *p))
+			    Perl_croak(aTHX_ "Malformed prototype for %s : %s",
+				       SvPVX(PL_subname), d);
 			if (!isSPACE(*p))
 			    d[tmp++] = *p;
 		    }