patch from Larry to make (\&) prototype work; added tests for

the same

p4raw-id: //depot/perl@5963

diff --git a/op.c b/op.c
index 95aa4f2..711be2f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6262,7 +6262,9 @@ Perl_ck_subr(pTHX_ OP *o)
                proto++;
                arg++;
                if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
-                   bad_type(arg, "block", gv_ename(namegv), o2);
+                   bad_type(arg,
+                       arg == 1 ? "block or sub {}" : "sub {}",
+                       gv_ename(namegv), o2);
                break;
            case '*':
                /* '*' allows any scalar type, including bareword */
@@ -6310,8 +6312,8 @@ Perl_ck_subr(pTHX_ OP *o)
                        bad_type(arg, "symbol", gv_ename(namegv), o2);
                    goto wrapref;
                case '&':
-                   if (o2->op_type != OP_RV2CV)
-                       bad_type(arg, "sub", gv_ename(namegv), o2);
+                   if (o2->op_type != OP_ENTERSUB)
+                       bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
                    goto wrapref;
                case '$':
                    if (o2->op_type != OP_RV2SV

diff --git a/t/comp/proto.t b/t/comp/proto.t
index ee17088..a77db9b 100755 (executable)
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..107\n";
+print "1..110\n";
 
 my $i = 1;
 
@@ -293,6 +293,25 @@ printf "ok %d\n",$i++;
 ##
 ##
 
+testing \&a_subx, '\&';
+
+sub a_subx (\&) {
+    print "# \@_ = (",join(",",@_),")\n";
+    &{$_[0]};
+}
+
+sub tmp_sub_2 { printf "ok %d\n",$i++ }
+a_subx &tmp_sub_2;
+
+@array = ( \&tmp_sub_2 );
+eval 'a_subx @array';
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
 testing \&sub_aref, '&\@';
 
 sub sub_aref (&\@) {