From: Father Chrysostomos <sprout@cpan.org>
Date: Fri, 24 Jun 2011 06:14:17 +0000 (-0700)
Subject: Allow the \$ proto to accept any scalar lvalue [perl #91846]
X-Git-Tag: accepted/trunk/20130322.191538~3526
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=062678b2241d3d1cc3a46f80f402cf4147b825f1;p=platform%2Fupstream%2Fperl.git

Allow the \$ proto to accept any scalar lvalue [perl #91846]

This makes the \$ prototype’s parsing the same as the second argument
to read(), making it possible to create a custom myread() function
that has the same syntax.

This is handled in two places in the prototype-parsing code, to avoid
calling scalar() on the op if another character in \[...] will accept
it.  I don’t know what the consequences of that would be.  So it calls
Perl_op_lvalue_flags in the $ case only if it is not inside brackets.
Then in the ] case it checks to see whether there was a $.

OP_READ, not OP_ENTERSUB, is passed as the type to
Perl_op_lvalue_flags, since OP_ENTERSUB would allow sub foo(\$) to
accept an array as an argument.  OP_RECV and OP_SYSREAD would have
worked, too.
---

diff --git a/op.c b/op.c
index ccd2fad..267bfb9 100644
--- a/op.c
+++ b/op.c
@@ -8825,7 +8825,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
 			    const char *p = proto;
 			    const char *const end = proto;
 			    contextclass = 0;
-			    while (*--p != '[') {}
+			    while (*--p != '[')
+				/* \[$] accepts any scalar lvalue */
+				if (*p == '$'
+				 && Perl_op_lvalue_flags(aTHX_
+				     scalar(o3),
+				     OP_READ, /* not entersub */
+				     OP_LVALUE_NO_CROAK
+				    )) goto wrapref;
 			    bad_type(arg, Perl_form(aTHX_ "one of %.*s",
 					(int)(end - p), p),
 				    gv_ename(namegv), o3);
@@ -8851,8 +8858,15 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
 				o3->op_type == OP_HELEM ||
 				o3->op_type == OP_AELEM)
 			    goto wrapref;
-			if (!contextclass)
+			if (!contextclass) {
+			    /* \$ accepts any scalar lvalue */
+			    if (Perl_op_lvalue_flags(aTHX_
+				    scalar(o3),
+				    OP_READ,  /* not entersub */
+				    OP_LVALUE_NO_CROAK
+			       )) goto wrapref;
 			    bad_type(arg, "scalar", gv_ename(namegv), o3);
+			}
 			break;
 		    case '@':
 			if (o3->op_type == OP_RV2AV ||
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 751da25..d4bc3c3 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -33,6 +33,15 @@ here, but most should go in the L</Performance Enhancements> section.
 You can now limit the size of an array using C<splice(@a,MAX_LEN)> without
 worrying about warnings.
 
+=head2 The C<\$> prototype accepts any scalar lvalue
+
+The C<\$> and C<\[$]> subroutine prototypes now accept any scalar lvalue
+argument.  Previously they only accepted scalars beginning with C<$> and
+hash and array elements.  This change makes them consistent with the way
+the built-in C<read> and C<recv> functions (among others) parse their
+arguments. This means that one can override the built-in functions with
+custom subroutines that parse their arguments the same way.
+
 =head1 Security
 
 XXX Any security-related notices go here.  In particular, any security
diff --git a/t/comp/proto.t b/t/comp/proto.t
index a982f6a..50aebef 100644
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -18,7 +18,7 @@ BEGIN {
 # strict
 use strict;
 
-print "1..171\n";
+print "1..174\n";
 
 my $i = 1;
 
@@ -545,6 +545,9 @@ sub sreftest (\$$) {
     sreftest($helem{$i}, $i++);
     sreftest $aelem[0], $i++;
     sreftest sub { [0] }->()[0], $i++;
+    sreftest my $a = 'quidgley', $i++;
+    print "not " if eval 'return 1; sreftest(3+4)';
+    print "ok ", $i++, ' - \$ with invalid argument', "\n";
 }
 
 # test single term
@@ -599,6 +602,8 @@ for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
 
     print "not " unless myref($myvar)   =~ /^SCALAR\(/;
     print "ok ", $i++, "\n";
+    print "not " unless myref($myvar=7) =~ /^SCALAR\(/;
+    print "ok ", $i++, "\n";
     print "not " unless myref(@myarray) =~ /^ARRAY\(/;
     print "ok ", $i++, "\n";
     print "not " unless myref(%myhash)  =~ /^HASH\(/;