From: Marcus Holland-Moritz <mhx-perl@gmx.net>
Date: Thu, 24 Jun 2004 16:22:05 +0000 (+0000)
Subject: Fix for: [perl #2738] perl segfautls on input
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8e742a20f09cb882e499103f4c5f4964764f2a86;p=p5sagit%2Fp5-mst-13.2.git

Fix for: [perl #2738] perl segfautls on input
The parser was incorrectly accepting <> as a subroutine prototype and
newATTRSUB didn't validate the proto argument before accessing op_sv.

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

diff --git a/op.c b/op.c
index cdc0749..0fd5547 100644
--- a/op.c
+++ b/op.c
@@ -4069,11 +4069,19 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     char *name;
     char *aname;
     GV *gv;
-    char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
+    char *ps;
     register CV *cv=0;
     SV *const_sv;
 
     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+
+    if (proto) {
+	assert(proto->op_type == OP_CONST);
+	ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
+    }
+    else
+	ps = Nullch;
+
     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
 	SV *sv = sv_newmortal();
 	Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 747dc05..8541645 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1729,6 +1729,10 @@ characters in prototypes are $, @, %, *, ;, [, ], &, and \.
 (F) When using the C<sub> keyword to construct an anonymous subroutine,
 you must always specify a block of code. See L<perlsub>.
 
+=item Illegal declaration of subroutine %s
+
+(F) A subroutine was not declared correctly. See L<perlsub>.
+
 =item Illegal division by zero
 
 (F) You tried to divide a number by 0.  Either something was wrong in
diff --git a/t/comp/parser.t b/t/comp/parser.t
index 92b9a6c..d784373 100644
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -9,7 +9,7 @@ BEGIN {
 }
 
 require "./test.pl";
-plan( tests => 44 );
+plan( tests => 47 );
 
 eval '%@x=0;';
 like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' );
@@ -156,3 +156,15 @@ EOF
     pass();
     $[ = 0; # restore the original value for less side-effects
 }
+
+# [perl #2738] perl segfautls on input
+{
+    eval q{ sub _ <> {} };
+    like($@, qr/Illegal declaration of subroutine main::_/, "readline operator as prototype");
+
+    eval q{ $s = sub <> {} };
+    like($@, qr/Illegal declaration of anonymous subroutine/, "readline operator as prototype");
+
+    eval q{ sub _ __FILE__ {} };
+    like($@, qr/Illegal declaration of subroutine main::_/, "__FILE__ as prototype");
+}
diff --git a/toke.c b/toke.c
index b113499..2b14e02 100644
--- a/toke.c
+++ b/toke.c
@@ -5095,8 +5095,12 @@ Perl_yylex(pTHX)
 
 		if (*s == ':' && s[1] != ':')
 		    PL_expect = attrful;
-		else if (!have_name && *s != '{' && key == KEY_sub)
-		    Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
+		else if (*s != '{' && key == KEY_sub) {
+		    if (!have_name)
+			Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
+		    else if (*s != ';')
+			Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
+		}
 
 		if (have_proto) {
 		    PL_nextval[PL_nexttoke].opval =