From 4587c5322c964beac01a38188957ca11026dc766 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Mon, 27 May 2013 17:45:50 -0700
Subject: [PATCH] [perl #117947] Verify lvalueness of XSUBs at run time

If the sub is not visible at compile time, the op tree is flagged such
that pp_entersub will know whether to check the lvalueness of the
called sub.

That check has been in pp_entersub since da1dff9483c.  When I moved
it to pp_entersub in that commit, I only added it to the pure-Perl
branch, not to the XS branch, allowing all XSUBs to be treated as
lvalues if they are not visible at compile time.
---
 cop.h           | 13 ++++++++-----
 pp_hot.c        |  6 ++++++
 t/op/sub_lval.t |  7 ++++++-
 3 files changed, 20 insertions(+), 6 deletions(-)

diff --git a/cop.h b/cop.h
index a736768..94a1267 100644
--- a/cop.h
+++ b/cop.h
@@ -596,16 +596,19 @@ struct block_format {
 	    SAVEFREESV(cv);						\
 	}
 
-
-#define PUSHSUB(cx)							\
-    {									\
+#define PUSHSUB_GET_LVALUE_MASK(func) \
 	/* 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 : (U8)Perl_was_lvalue_sub(aTHX);			\
+	           ? 0 : (U8)func(aTHX)					\
+	)
+
+#define PUSHSUB(cx)							\
+    {									\
+	U8 phlags = PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);	\
 	PUSHSUB_BASE(cx)						\
 	cx->blk_u16 = PL_op->op_private &				\
 	                  (phlags|OPpDEREF);				\
diff --git a/pp_hot.c b/pp_hot.c
index dd9e5f1..157c469 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2847,6 +2847,12 @@ try_autoload:
 
 	PUTBACK;
 
+	if (((PL_op->op_private
+	       & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
+             ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+	    !CvLVALUE(cv))
+	    DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+
 	if (!hasargs) {
 	    /* Need to copy @_ to stack. Alternative may be to
 	     * switch stack to @_, and copy return values
diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index b2f56e3..9be3164 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=>191;
+plan tests=>192;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -962,3 +962,8 @@ sub ucfr : lvalue {
     }
 }
 ucfr();
+
+# [perl #117947] XSUBs should not be treated as lvalues at run time
+eval { &{\&utf8::is_utf8}("") = 3 };
+like $@, qr/^Can't modify non-lvalue subroutine call at /,
+        'XSUB not seen at compile time dies in lvalue context';
-- 
2.7.4