Change 11865 by jhi@alpha on 2001/09/04 13:36:58
Add the \[$@%&*] prototype support.
Affected files ...
... //depot/perl/op.c#437 edit
... //depot/perl/pod/perlsub.pod#37 edit
... //depot/perl/t/comp/proto.t#30 edit
Differences ...
==== //depot/perl/op.c#437 (text) ====
Index: perl/op.c
--- perl/op.c.~1~ Tue Sep 4 07:45:05 2001
+++ perl/op.c Tue Sep 4 07:45:05 2001
@@ -6545,6 +6545,8 @@
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 @@
}
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 @@
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 @@
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
==== //depot/perl/pod/perlsub.pod#37 (text) ====
Index: perl/pod/perlsub.pod
--- perl/pod/perlsub.pod.~1~ Tue Sep 4 07:45:05 2001
+++ perl/pod/perlsub.pod Tue Sep 4 07:45:05 2001
@@ -926,6 +926,22 @@
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
==== //depot/perl/t/comp/proto.t#30 (xtext) ====
Index: perl/t/comp/proto.t
--- perl/t/comp/proto.t.~1~ Tue Sep 4 07:45:05 2001
+++ perl/t/comp/proto.t Tue Sep 4 07:45:05 2001
@@ -16,7 +16,7 @@
use strict;
-print "1..125\n";
+print "1..130\n";
my $i = 1;
@@ -506,3 +506,24 @@
# 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";
+}
End of Patch.
