From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Tue, 4 Sep 2001 13:36:58 +0000 (+0000)
Subject: Add the \[$@%&*] prototype support.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5b794e0558240996f259d9acbc8089c989bf711e;p=p5sagit%2Fp5-mst-13.2.git

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

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

diff --git a/op.c b/op.c
index f167a66..88646a2 100644
--- 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
--- 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
--- 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";
+}