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 (file)
--- 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 (executable)
--- 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";
 }