This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_multiconcat: don't stringify LHS overload arg
authorDavid Mitchell <davem@iabyn.com>
Sat, 4 Nov 2017 10:30:00 +0000 (10:30 +0000)
committerDavid Mitchell <davem@iabyn.com>
Sat, 4 Nov 2017 10:33:51 +0000 (10:33 +0000)
RT #132385

In something like

    $a1 . $a2

where $a2 is overloaded, the concat overload method was being called
like

    concat($a2, "$a1", 1);

(The 1 indicated that the args are reversed).

This commit changes it so that it's called as

    concat($a2, $a1, 1);

i.e. that the original arg is passed in rather than a stringified copy
of it. This is important if for example $a1 is a ref.

lib/overload.t
pp_hot.c

index e6b2f32..46b193b 100644 (file)
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl'; require './charset_tools.pl' }
-plan tests => 5326;
+plan tests => 5331;
 
 use Scalar::Util qw(tainted);
 
@@ -2995,3 +2995,42 @@ package Concat {
     cc '$R.=sprintf("%s%s%s",$a,$B,$c)', 'RaBc', 1, '("",[B],u,)(.=,[R],aBc,u)'
                                                    .'("",[RaBc],u,)';
 }
+
+# RT #132385
+# The first arg of a reversed concat shouldn't be stringified:
+#      $left . $right
+#  where $right is overloaded, should invoke
+#      concat($right, $left, 1)
+#  rather than
+#      concat($right, "$left", 1)
+
+package RT132385 {
+
+    use constant C => [ "constref" ];
+
+    use overload '.' => sub {
+                            my ($r, $l, $rev) = @_;
+                            die "expected reverse\n" unless $rev;
+                            my $res = ref $l ? $l->[0] : "$l";
+                            $res .= "-" . $r->[0];
+                            $res;
+                        }
+    ;
+
+    my $r1 = [ "ref1" ];
+    my $r2 = [ "ref2" ];
+    my $s1 =   "str1";
+
+    my $o = bless [ "obj" ];
+
+    # try variations that will call either pp_concat or pp_multiconcat,
+    # with the ref as the first or a later arg
+
+    ::is($r1.$o,        "ref1-obj",             "RT #132385 r1.o");
+    ::is($r1.$o.$s1 ,   "ref1-objstr1",         "RT #132385 r1.o.s1");
+    ::is("const".$o.$s1 ,"const-objstr1",       "RT #132385 const.o.s1");
+    ::is(C.$o.$s1       ,"constref-objstr1",    "RT #132385 C.o.s1");
+
+    ::like($r1.$r2.$o,   qr/^ARRAY\(0x\w+\)ARRAY\(0x\w+\)-obj/,
+                                                "RT #132385 r1.r2.o");
+}
index 2ce77b3..d980db8 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -520,6 +520,41 @@ PP(pp_multiconcat)
                      * FAKE implies an optimised sprintf which doesn't use
                      * concat overloading, only "" overloading.
                      */
+
+                    if (   svpv_end == svpv_buf + 1
+                           /* no const string segments */
+                        && aux[PERL_MULTICONCAT_IX_LENGTHS].size     == -1
+                        && aux[PERL_MULTICONCAT_IX_LENGTHS + 1].size == -1
+                    ) {
+                        /* special case: if the overloaded sv is the
+                         * second arg in the concat chain, stop at the
+                         * first arg rather than this, so that
+                         *
+                         *   $arg1 . $arg2
+                         *
+                         * invokes overloading as
+                         *
+                         *    concat($arg2, $arg1, 1)
+                         *
+                         * rather than
+                         *
+                         *    concat($arg2, "$arg1", 1)
+                         *
+                         * This means that if for example arg1 is a ref,
+                         * it gets passed as-is to the concat method
+                         * rather than a stringified copy. If it's not the
+                         * first arg, it doesn't matter, as in $arg0 .
+                         * $arg1 .  $arg2, where the result of ($arg0 .
+                         * $arg1) will already be a string.
+                         * THis isn't perfect: we'll have already
+                         * done SvPV($arg1) on the previous iteration;
+                         * and are now throwing away that result and
+                         * hoping arg1 hasn;t been affected.
+                         */
+                        svpv_end--;
+                        SP--;
+                    }
+
                   setup_overload:
                     dsv = newSVpvn_flags("", 0, SVs_TEMP);