join: save the delimiter string before anything magical happens to it

This code had a few problems:

- changes to the content of delim from set or overload magic could
  result in the separator between elements changing during the
  process of the join.
- changes to the content of delim which allocated a new PVX
  resulted in access to freed memory
- changes to the flags of delim, the UTF-8 flag in particular, could
  result in an invalid joined string, either mojibake or an invalidly
  encoded upgraded string

To avoid that, we copy the separator, either into a local buffer
if it's large enough, or an allocated buffer, and save the flag we
use, to prevent changes to the delim SV from changing or invalidating
the delimpv value.

Fixes #21458 and some similar problems.

Author: tonycoz

doop.c

@@ -633,6 +633,13 @@ Perl_do_trans(pTHX_ SV *sv)
     }
 }
 
+#ifdef DEBUGGING
+/* make it small to exercise the logic */
+#  define JOIN_DELIM_BUFSIZE 2
+#else
+#  define JOIN_DELIM_BUFSIZE 40
+#endif
+
 /*
 =for apidoc_section $string
 =for apidoc do_join
@@ -662,10 +669,27 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp)
     SSize_t items = sp - mark;
     STRLEN len;
     STRLEN delimlen;
-    const char * const delims = SvPV_const(delim, delimlen);
+    const char * delimpv = SvPV_const(delim, delimlen);
+    char delim_buf[JOIN_DELIM_BUFSIZE];
+    bool delim_do_utf8 = DO_UTF8(delim);
 
     PERL_ARGS_ASSERT_DO_JOIN;
 
+    if (items >= 2) {
+        /* Make a copy of the delim, since G or A magic may modify the delim SV.
+           Use a local buffer if possible to avoid the cost of allocation and
+           clean up.
+        */
+        if (delimlen <= JOIN_DELIM_BUFSIZE) {
+            Copy(delimpv, delim_buf, delimlen, char);
+            delimpv = delim_buf;
+        }
+        else {
+            delimpv = savepvn(delimpv, delimlen);
+            SAVEFREEPV(delimpv);
+        }
+    }
+
     mark++;
     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
     SvUPGRADE(sv, SVt_PV);
@@ -699,11 +723,11 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp)
     }
 
     if (delimlen) {
-        const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES;
+        const U32 delimflag = delim_do_utf8 ? SV_CATUTF8 : SV_CATBYTES;
         for (; items > 0; items--,mark++) {
             STRLEN len;
             const char *s;
-            sv_catpvn_flags(sv,delims,delimlen,delimflag);
+            sv_catpvn_flags(sv, delimpv, delimlen, delimflag);
             s = SvPV_const(*mark,len);
             sv_catpvn_flags(sv,s,len,
                             DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES);

t/op/join.t

@@ -173,15 +173,12 @@ isnt $_[1], $_[0],
     is( $SM::fetched,    0,   'FETCH not called' );
 
     tie $t, "SM";
-    { local $TODO = "separator keeps being FETCHed";
     is( join( $t, "a", $t, "b", $t, "c" ),
         'a474b4104c', 'tied separator also in the join arguments' );
-    }
     is( $SM::fetched, 3, 'FETCH called 1 + 2 times' );
 }
 {
     # see GH #21484
-    local $TODO = "changes to delim have an effect";
     my $expect = "a\x{100}x\x{100}b\n";
     utf8::encode($expect);
     fresh_perl_is(<<'CODE', $expect, {}, "modifications delim from magic should be ignored");
@@ -199,7 +196,6 @@ CODE
 {
     # see GH #21484
     my $expect = "x\x{100}a\n";
-    local $TODO = "modifications to delim PVX caused UB";
     utf8::encode($expect); # fresh_perl() does bytes
     fresh_perl_is(<<'CODE', $expect, {}, "modifications to delim PVX shouldn't crash");
 my $n = 1;