Make lvalue subs copy returned PADTMPs in rvalue cx

I was trying to write a JAPH, but did not get what I expected:

$ ./perl -Ilib -e '@UNIVERSAL::ISA = CORE; print "just another "->ucfirst, "perl hacker,\n"->ucfirst'
Perl hacker,
Perl hacker,

This happened because coresubs use leavesublv, to avoid copying the
return value wastefully.

But since this is exactly the same ucfirst op being called each time
(the one in &CORE::ucfirst’s op tree), and since ucfirst uses TARG, we
end up with the same scalar.

We have the same problem with lvalue subs:

$ ./perl -Ilib -e 'sub UNIVERSAL::ucfirst :lvalue { ucfirst $_[0] } print "just another "->ucfirst, "perl hacker,\n"->ucfirst'
Perl hacker,
Perl hacker,

(This is not a regression, as 5.14 gave ‘Can't modify ucfirst in
lvalue subroutine return’.)

So ‘fixing’ coresubs would not be a solution, but a workaround.

The solution therefore is for leavesublv to copy PADTMPs in
rvalue context.

Commit 80422e24c fixed this for potential lvalue list context (i.e.,
for(lvsub()) {...}), but it wasn’t sufficient.

diff --git a/pp_ctl.c b/pp_ctl.c
index 8f4c103..7a8c797 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2370,13 +2370,24 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
        if (MARK < SP) {
              copy_sv:
                if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
+                   if (!SvPADTMP(*SP)) {
                        *++newsp = SvREFCNT_inc(*SP);
                        FREETMPS;
                        sv_2mortal(*newsp);
+                   }
+                   else {
+                       /* FREETMPS could clobber it */
+                       SV *sv = SvREFCNT_inc(*SP);
+                       FREETMPS;
+                       *++newsp = sv_mortalcopy(sv);
+                       SvREFCNT_dec(sv);
+                   }
                }
                else
                    *++newsp =
-                       !SvTEMP(*SP)
+                     SvPADTMP(*SP)
+                      ? sv_mortalcopy(*SP)
+                      : !SvTEMP(*SP)
                          ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
                          : *SP;
        }
@@ -2396,10 +2407,10 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
        if (ref || !CxLVAL(cx))
            while (++MARK <= SP)
                *++newsp =
-                    SvTEMP(*MARK)
-                      ? *MARK
-                      : ref && SvFLAGS(*MARK) & SVs_PADTMP
+                      SvFLAGS(*MARK) & SVs_PADTMP
                           ? sv_mortalcopy(*MARK)
+                    : SvTEMP(*MARK)
+                          ? *MARK
                           : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
        else while (++MARK <= SP) {
            if (*MARK != &PL_sv_undef

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index b0263ee..85084bb 100644 (file)
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -125,6 +125,11 @@ $tests++;
 ok eval { *CORE::exit = \42 },
   '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
 
+@UNIVERSAL::ISA = CORE;
+is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
+   "Just another Perl hacker,\n", 'coresubs do not return TARG';
+++$tests;
+
 done_testing $tests;
 
 CORE::__END__

diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index 7008caf..b2f56e3 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=>187;
+plan tests=>191;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -944,3 +944,21 @@ package _102486 {
   ::like $@, qr/^Can't modify non-lvalue subroutine call at /,
         'sub:lvalue{&$x}->() dies in true lvalue context';
 }
+
+# TARG should be copied in rvalue context
+sub ucf :lvalue { ucfirst $_[0] }
+is ucf("just another ") . ucf("perl hacker,\n"),
+   "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx';
+is join('',ucf("just another "), ucf "perl hacker,\n"),
+   "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx';
+sub ucfr : lvalue {
+    @_ ? ucfirst $_[0] : do {
+       is ucfr("just another ") . ucfr("perl hacker,\n"),
+          "Just another Perl hacker,\n",
+          'TARG is copied in recursive rvalue scalar cx';
+       is join('',ucfr("just another "), ucfr("perl hacker,\n")),
+          "Just another Perl hacker,\n",
+          'TARG is copied in recursive rvalue list cx';
+    }
+}
+ucfr();