[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.

diff --git a/cop.h b/cop.h
index a736768..94a1267 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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';