Add the \[$@%&*] prototype support.

p4raw-id: //depot/perl@11865

diff --git a/op.c b/op.c
index f167a66..88646a2 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6545,6 +6545,8 @@ Perl_ck_subr(pTHX_ OP *o)
     GV *namegv = 0;
     int optional = 0;
     I32 arg = 0;
+    I32 contextclass = 0;
+    char *e;
     STRLEN n_a;
 
     o->op_private |= OPpENTERSUB_HASTARG;
@@ -6641,36 +6643,67 @@ Perl_ck_subr(pTHX_ OP *o)
                }
                scalar(o2);
                break;
+           case '[': case ']':
+                goto oops;
+                break;
            case '\\':
                proto++;
                arg++;
+           again:
                switch (*proto++) {
+               case '[':
+                    if (contextclass++ == 0) {
+                         e = strchr(proto, ']');
+                         if (!e || e == proto)
+                              goto oops;
+                    }
+                    else
+                         goto oops;
+                    goto again;
+                    break;
+               case ']':
+                    if (contextclass)
+                         contextclass = 0;
+                    else
+                         goto oops;
+                    break;
                case '*':
-                   if (o2->op_type != OP_RV2GV)
-                       bad_type(arg, "symbol", gv_ename(namegv), o2);
-                   goto wrapref;
+                    if (o2->op_type == OP_RV2GV)
+                         goto wrapref;
+                    if (!contextclass)
+                         bad_type(arg, "symbol", gv_ename(namegv), o2);
+                    break;
                case '&':
-                   if (o2->op_type != OP_ENTERSUB)
-                       bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
-                   goto wrapref;
+                    if (o2->op_type == OP_ENTERSUB)
+                         goto wrapref;
+                    if (!contextclass)
+                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
+                    break;
                case '$':
-                   if (o2->op_type != OP_RV2SV
-                       && o2->op_type != OP_PADSV
-                       && o2->op_type != OP_HELEM
-                       && o2->op_type != OP_AELEM
-                       && o2->op_type != OP_THREADSV)
-                   {
+                   if (o2->op_type == OP_RV2SV ||
+                       o2->op_type == OP_PADSV ||
+                       o2->op_type == OP_HELEM ||
+                       o2->op_type == OP_AELEM ||
+                       o2->op_type == OP_THREADSV)
+                        goto wrapref;
+                   if (!contextclass)
                        bad_type(arg, "scalar", gv_ename(namegv), o2);
-                   }
-                   goto wrapref;
+                    break;
                case '@':
-                   if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
+                   if (o2->op_type == OP_RV2AV ||
+                       o2->op_type == OP_PADAV)
+                        goto wrapref;
+                   if (!contextclass)
                        bad_type(arg, "array", gv_ename(namegv), o2);
-                   goto wrapref;
+                   break;
                case '%':
-                   if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
-                       bad_type(arg, "hash", gv_ename(namegv), o2);
-                 wrapref:
+                   if (o2->op_type == OP_RV2HV ||
+                       o2->op_type == OP_PADHV)
+                        goto wrapref;
+                   if (!contextclass)
+                        bad_type(arg, "hash", gv_ename(namegv), o2);
+                   break;
+               wrapref:
                    {
                        OP* kid = o2;
                        OP* sib = kid->op_sibling;
@@ -6679,9 +6712,15 @@ Perl_ck_subr(pTHX_ OP *o)
                        o2->op_sibling = sib;
                        prev->op_sibling = o2;
                    }
+                   if (contextclass) {
+                        proto = e + 1;
+                        contextclass = 0;
+                   }
                    break;
                default: goto oops;
                }
+               if (contextclass)
+                    goto again;
                break;
            case ' ':
                proto++;
@@ -6689,7 +6728,7 @@ Perl_ck_subr(pTHX_ OP *o)
            default:
              oops:
                Perl_croak(aTHX_ "Malformed prototype for %s: %s",
-                       gv_ename(namegv), SvPV((SV*)cv, n_a));
+                          gv_ename(namegv), SvPV((SV*)cv, n_a));
            }
        }
        else

diff --git a/pod/perlsub.pod b/pod/perlsub.pod
index ea7546e..4329c16 100644 (file)
--- a/pod/perlsub.pod
+++ b/pod/perlsub.pod
@@ -926,6 +926,22 @@ that absolutely must start with that character.  The value passed
 as part of C<@_> will be a reference to the actual argument given
 in the subroutine call, obtained by applying C<\> to that argument.
 
+You can also backslash several argument types simultaneously by using
+the C<\[]> notation:
+
+    sub myref (\[$@%&*])
+
+will allow calling myref() as
+
+    myref $var
+    myref @array
+    myref %hash
+    myref &sub
+    myref *glob
+
+and the first argument of myref() will be a reference to
+a scalar, an array, a hash, a code, or a glob.
+
 Unbackslashed prototype characters have special meanings.  Any
 unbackslashed C<@> or C<%> eats all remaining arguments, and forces
 list context.  An argument represented by C<$> forces scalar context.  An

diff --git a/t/comp/proto.t b/t/comp/proto.t
index ae0f9ab..a60f36f 100755 (executable)
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..125\n";
+print "1..130\n";
 
 my $i = 1;
 
@@ -506,3 +506,24 @@ print "ok ", $i++, "\n";
 # recv takes a scalar reference for its second argument
 print "not " unless prototype "CORE::recv" eq '*\\$$$';
 print "ok ", $i++, "\n";
+
+{
+    my $myvar;
+    my @myarray;
+    my %myhash;
+    sub mysub { print "not calling mysub I hope\n" }
+    local *myglob;
+
+    sub myref (\[$@%&*]) { print "# $_[0]\n"; return "$_[0]" }
+
+    print "not " unless myref($myvar)   =~ /^SCALAR\(/;
+    print "ok ", $i++, "\n";
+    print "not " unless myref(@myarray) =~ /^ARRAY\(/;
+    print "ok ", $i++, "\n";
+    print "not " unless myref(%myhash)  =~ /^HASH\(/;
+    print "ok ", $i++, "\n";
+    print "not " unless myref(&mysub)   =~ /^CODE\(/;
+    print "ok ", $i++, "\n";
+    print "not " unless myref(*myglob)  =~ /^GLOB\(/;
+    print "ok ", $i++, "\n";
+}