Propagate (non-)lvalue context through nested calls

Before this commit, this code would fail:

$foo = "foo";
sub foo :lvalue{ return index "foo","o" }
sub bar :lvalue { foo }
$x = bar;

(It would fail for ‘return $]’ as well.  Whether it’s a PADTMP or a
read-only scalar makes no difference.)

foo would think it was being called in true lvalue context, because
the entersub op that called it (in bar) was marked that way, bar being
an lvalue sub as well.

The PUSHSUB macro in cop.h needed to be modified to account for
dynamic, or indetermine, context (i.e., indeterminable at compile
time).  This happens when an entersub op is an argument to return or
the last statement in a subroutine.  In those cases it has to propa-
gate the context from the caller.

So what we now do is this: Both lvalue and in-args flags are turned on
for an entersub op when op_lvalue is called with OP_LEAVESUBLV as the
type.  Then PUSHSUB copies into the context stack only those flags
that are set both on the current entersub op and in the context stack
for the previous sub call.

9 files changed, 56 insertions, 3 deletions

diff --git a/cop.h b/cop.h
index 82eee29fa9..d261edf13b 100644
--- a/cop.h
+++ b/cop.h
@@ -633,9 +633,18 @@ struct block_format {
 
 
 #define PUSHSUB(cx)							\
+    {									\
+	/* If the context is indeterminate, then only the lvalue */	\
+	/* flags that the caller also has are applicable.        */	\
+	U8 phlags =							\
+	   (PL_op->op_flags & OPf_WANT)					\
+	       ? OPpENTERSUB_LVAL_MASK					\
+	       : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK)		\
+	           ? 0 : was_lvalue_sub();				\
 	PUSHSUB_BASE(cx)						\
 	cx->blk_u16 = PL_op->op_private &				\
-	              (OPpLVAL_INTRO|OPpENTERSUB_INARGS|OPpENTERSUB_DEREF);
+	                  (phlags|OPpENTERSUB_DEREF);			\
+    }
 
 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
 #define PUSHSUB_DB(cx)							\
diff --git a/embed.fnc b/embed.fnc
index e1a5010493..8ab74aca7d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -545,6 +545,8 @@ p	|bool	|io_close	|NN IO* io|bool not_implicit
 : Used in perly.y
 pR	|OP*	|invert		|NULLOK OP* cmd
 ApR	|I32	|is_lvalue_sub
+: Used in cop.h
+pR	|I32	|was_lvalue_sub
 ApPR	|U32	|to_uni_upper_lc|U32 c
 ApPR	|U32	|to_uni_title_lc|U32 c
 ApPR	|U32	|to_uni_lower_lc|U32 c
diff --git a/embed.h b/embed.h
index 3e19420f43..9053ab935d 100644
--- a/embed.h
+++ b/embed.h
@@ -1151,6 +1151,7 @@
 #define unshare_hek(a)		Perl_unshare_hek(aTHX_ a)
 #define vivify_ref(a,b)		Perl_vivify_ref(aTHX_ a,b)
 #define wait4pid(a,b,c)		Perl_wait4pid(aTHX_ a,b,c)
+#define was_lvalue_sub()	Perl_was_lvalue_sub(aTHX)
 #define watch(a)		Perl_watch(aTHX_ a)
 #define write_to_stderr(a)	Perl_write_to_stderr(aTHX_ a)
 #define yyerror(a)		Perl_yyerror(aTHX_ a)
diff --git a/op.c b/op.c
index eab717a107..fba667fb79 100644
--- a/op.c
+++ b/op.c
@@ -1472,7 +1472,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
 	else if (o->op_private & OPpENTERSUB_NOMOD)
 	    return o;
 	else {				/* lvalue subroutine call */
-	    o->op_private |= OPpLVAL_INTRO;
+	    o->op_private |= OPpLVAL_INTRO
+	                   |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
 	    PL_modcount = RETURN_UNLIMITED_NUMBER;
 	    if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
 		/* Backward compatibility mode: */
diff --git a/op.h b/op.h
index d80eb38bb1..e184468c0c 100644
--- a/op.h
+++ b/op.h
@@ -196,12 +196,17 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpDEREF_SV		(32|64)	/*   Want ref to SV. */
 /* Private for OP_RV2SV, OP_RV2AV, OP_RV2AV */
 #define OPpDEREFed		4	/* prev op was OPpDEREF */
+
   /* OP_ENTERSUB only */
 #define OPpENTERSUB_DB		16	/* Debug subroutine. */
 #define OPpENTERSUB_HASTARG	32	/* Called from OP tree. */
 #define OPpENTERSUB_NOMOD	64	/* Immune to op_lvalue() for :attrlist. */
 #define OPpENTERSUB_INARGS	4	/* Lval used as arg to a sub. */
 #define OPpENTERSUB_DEREF	1	/* Lval call that autovivifies. */
+  /* Mask for OP_ENTERSUB flags, the absence of which must be propagated
+     in dynamic context */
+#define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS)
+
   /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER	8	/* Used & form to call. */
 #define OPpENTERSUB_NOPAREN	128	/* bare sub call (without parens) */
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 6e3f67c920..157f115027 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -527,6 +527,13 @@ the C<__FILE__>, C<__LINE__> and C<__PACKAGE__> directives, instead of
 dying, as they are indistinguishable syntactically from nullary functions
 like C<time>.
 
+=item *
+
+A bug affecting lvalue context propagation through nested lvalue subroutine
+calls has been fixed.  Previously, returning a value in nested rvalue
+context would be treated as lvalue context by the inner subroutine call,
+resulting in some values (such as read-only values) being rejected.
+
 =back
 
 =head1 Known Problems
diff --git a/pp_ctl.c b/pp_ctl.c
index caa0da5038..854c89d607 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1469,6 +1469,20 @@ Perl_is_lvalue_sub(pTHX)
 	return 0;
 }
 
+/* only used by PUSHSUB */
+I32
+Perl_was_lvalue_sub(pTHX)
+{
+    dVAR;
+    const I32 cxix = dopoptosub(cxstack_ix-1);
+    assert(cxix >= 0);  /* We should only be called from inside subs */
+
+    if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
+	return CxLVAL(cxstack + cxix);
+    else
+	return 0;
+}
+
 STATIC I32
 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
 {
diff --git a/proto.h b/proto.h
index 7b9964863d..2e9a45a3f1 100644
--- a/proto.h
+++ b/proto.h
@@ -4473,6 +4473,9 @@ PERL_CALLCONV void	Perl_warner(pTHX_ U32 err, const char* pat, ...)
 #define PERL_ARGS_ASSERT_WARNER	\
 	assert(pat)
 
+PERL_CALLCONV I32	Perl_was_lvalue_sub(pTHX)
+			__attribute__warn_unused_result__;
+
 PERL_CALLCONV void	Perl_watch(pTHX_ char** addr)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_WATCH	\
diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index 64e7b4edcc..aaf8e56e6b 100644
--- a/t/op/sub_lval.t
+++ b/t/op/sub_lval.t
@@ -3,7 +3,7 @@ BEGIN {
     @INC = '../lib';
     require './test.pl';
 }
-plan tests=>175;
+plan tests=>179;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -900,3 +900,14 @@ for (
 	         .$suffix             # (they used to be copied)
 }
 continue { $suffix = ' (explicit return)' }
+
+# Returning unwritables from nested lvalue sub call in in rvalue context
+# First, ensure we are testing what we think we are:
+if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); }
+sub squibble : lvalue { return $] }
+sub squebble : lvalue {        squibble }
+sub squabble : lvalue { return squibble }
+is $x = squebble, $], 'returning ro from nested lv sub call in rv cx';
+is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx';
+is \squebble, \$], 'returning ro from nested lv sub call in ref cx';
+is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx';