mutlitconcat: fix non-folding adjacent consts

RT ##132646

v5.27.6-120-gbcc30fd changed multiconcat so that adjacent constants
weren't folded, so that ($overloaded . "a" . "b") is invoked as
    $overloaded->concat("a")->concat("b")
rather than
    $overloaded->concat("ab")

It did this by 'demoting' every second adjacent const as a real arg rather
than adding it to the const string. However, that could leave a
multiconcat op with more than the maximum allowed args.

So include demotion candidates as part of the arg count.

2 files changed, 40 insertions, 2 deletions

diff --git a/op.c b/op.c
index 724dfef6ad..d9886482cd 100644
--- a/op.c
+++ b/op.c
@@ -2666,6 +2666,7 @@ S_maybe_multiconcat(pTHX_ OP *o)
 
     SSize_t nargs  = 0;
     SSize_t nconst = 0;
+    SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
     STRLEN variant;
     bool utf8 = FALSE;
     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
@@ -2677,6 +2678,7 @@ S_maybe_multiconcat(pTHX_ OP *o)
     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
     bool is_sprintf = FALSE; /* we're optimising an sprintf */
     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
+    bool prev_was_const = FALSE; /* previous arg was a const */
 
     /* -----------------------------------------------------------------
      * Phase 1:
@@ -2893,7 +2895,7 @@ S_maybe_multiconcat(pTHX_ OP *o)
             last = TRUE;
         }
 
-        if (   nargs              >  PERL_MULTICONCAT_MAXARG        - 2
+        if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
         {
             /* At least two spare slots are needed to decompose both
@@ -2924,10 +2926,16 @@ S_maybe_multiconcat(pTHX_ OP *o)
             argp++->p = sv;
             utf8   |= cBOOL(SvUTF8(sv));
             nconst++;
+            if (prev_was_const)
+                /* this const may be demoted back to a plain arg later;
+                 * make sure we have enough arg slots left */
+                nadjconst++;
+            prev_was_const = !prev_was_const;
         }
         else {
             argp++->p = NULL;
             nargs++;
+            prev_was_const = FALSE;
         }
 
         if (last)
diff --git a/t/opbasic/concat.t b/t/opbasic/concat.t
index 55965c1702..42851d23b9 100644
--- a/t/opbasic/concat.t
+++ b/t/opbasic/concat.t
@@ -39,7 +39,7 @@ sub is {
     return $ok;
 }
 
-print "1..251\n";
+print "1..252\n";
 
 ($a, $b, $c) = qw(foo bar);
 
@@ -810,3 +810,33 @@ ok(ref(CORE::state $y = "a $o b") eq 'o',
         is($got, $expected, "long concat chain $i");
     }
 }
+
+# RT #132646
+# with adjacent consts, the second const is treated as an arg rather than a
+# consts. Make sure this doesn't exceeed the maximum allowed number of
+# args
+{
+    my $x = 'X';
+    my $got =
+          'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        . 'A' . $x . 'B' . 'C' . $x . 'D'
+        ;
+    is ($got,
+        "AXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXD",
+        "RT #132646");
+}