From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 19 Apr 2006 09:22:03 +0000 (+0000)
Subject: Avoid temporarily writing over the prototype when reporting an error.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a075176614b5ba61bbee8cc5336ddfbd48f21998;p=p5sagit%2Fp5-mst-13.2.git

Avoid temporarily writing over the prototype when reporting an error.
(And beef up the relevant tests to really check that it all works).

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

diff --git a/op.c b/op.c
index 86d01d4..8efe3b2 100644
--- a/op.c
+++ b/op.c
@@ -7231,7 +7231,7 @@ Perl_ck_subr(pTHX_ OP *o)
 	     ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
     OP *o2 = prev->op_sibling;
     OP *cvop;
-    char *proto = NULL;
+    const char *proto = NULL;
     const char *proto_end = NULL;
     CV *cv = NULL;
     GV *namegv = NULL;
@@ -7381,15 +7381,13 @@ Perl_ck_subr(pTHX_ OP *o)
 		     break;
 		case ']':
 		     if (contextclass) {
-			 /* XXX We shouldn't be modifying proto, so we can const proto */
-		         char *p = proto;
-			 const char s = *p;
+		         const char *p = proto;
+			 const char *const end = proto;
 			 contextclass = 0;
-			 *p = '\0';
 			 while (*--p != '[');
-			 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
-				 gv_ename(namegv), o3);
-			 *proto = s;
+			 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+						 (int)(end - p), p),
+				  gv_ename(namegv), o3);
 		     } else
 			  goto oops;
 		     break;
diff --git a/t/comp/proto.t b/t/comp/proto.t
index 7f566e2..1f5ed30 100755
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -585,20 +585,25 @@ print "ok ", $i++, "\n";
     print "ok ", $i++, "\n";
 
     eval q/sub multi1 (\[%@]) { 1 } multi1 $myvar;/;
-    print "not " unless $@ =~ /Type of arg 1 to main::multi1 must be one of/;
+    print "not "
+	unless $@ =~ /Type of arg 1 to main::multi1 must be one of \[%\@\] /;
     print "ok ", $i++, "\n";
     eval q/sub multi2 (\[$*&]) { 1 } multi2 @myarray;/;
-    print "not " unless $@ =~ /Type of arg 1 to main::multi2 must be one of/;
+    print "not "
+	unless $@ =~ /Type of arg 1 to main::multi2 must be one of \[\$\*&\] /;
     print "ok ", $i++, "\n";
     eval q/sub multi3 (\[$@]) { 1 } multi3 %myhash;/;
-    print "not " unless $@ =~ /Type of arg 1 to main::multi3 must be one of/;
+    print "not "
+	unless $@ =~ /Type of arg 1 to main::multi3 must be one of \[\$\@\] /;
     print "ok ", $i++, "\n";
     eval q/sub multi4 ($\[%]) { 1 } multi4 1, &mysub;/;
-    print "not " unless $@ =~ /Type of arg 2 to main::multi4 must be one of/;
+    print "not "
+	unless $@ =~ /Type of arg 2 to main::multi4 must be one of \[%\] /;
     print "ok ", $i++, "\n";
     eval q/sub multi5 (\[$@]$) { 1 } multi5 *myglob;/;
-    print "not " unless $@ =~ /Type of arg 1 to main::multi5 must be one of/
-		     && $@ =~ /Not enough arguments/;
+    print "not "
+	unless $@ =~ /Type of arg 1 to main::multi5 must be one of \[\$\@\] /
+	    && $@ =~ /Not enough arguments/;
     print "ok ", $i++, "\n";
 }