Basic bad prototype detection

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

p4raw-id: //depot/perl@13971

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1935550..8ee25f2 100644 (file)
--- 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 a60f36f..b42a5cc 100755 (executable)
--- 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 1527daa..55aaedb 100644 (file)
--- 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;
                    }