pp_pack: SvPV_force() pack(p/P, ...) arguments when writable

pack("p"/"P") is generally pretty awful, but we document that you
can pack("P") and then write to the pointer supplied, so make that
safer but ensuring the PV isn't shared with other SVs.

Since _force() throws on a READONLY SV, and you shouldn't be writing
to one, only _force() for a writable SV.

This is still broken when magic is involved, but we did document it.

Fixes the UUID::FFI part of Perl#22380

Some other modules (and UUID::FFI itself, really) will need XS
fixes.

ext/XS-APItest/APItest.xs

@@ -4941,7 +4941,11 @@ rc_add(sv1, sv2)
         rpp_replace_2_1(r);
         return;
 
-
+void
+modify_pv(IV pi, IV sz)
+    PPCODE:
+        /* used by op/pack.t when testing pack "p" */
+        memset(INT2PTR(char *, pi), 'y', sz);
 
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 

pp_pack.c

@@ -3076,7 +3076,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
                                        "Attempt to pack pointer to temporary value");
                     }
-                    if (SvPOK(fromstr) || SvNIOK(fromstr))
+                    if (SvREADONLY(fromstr))
                         aptr = SvPV_nomg_const_nolen(fromstr);
                     else
                         aptr = SvPV_force_flags_nolen(fromstr, 0);

t/op/pack.t

@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc(qw '../lib ../cpan/Math-BigInt/lib');
 }
 
-plan tests => 14722;
+plan tests => 14724;
 
 use strict;
 use warnings qw(FATAL all);
@@ -343,6 +343,20 @@ sub foo { my $a = "a"; return $a . $a++ . $a++ }
   like($warning, qr/temporary val/);
 }
 
+SKIP:
+{
+    # based on https://github.com/Perl/perl5/issues/22380
+    eval { require XS::APItest; 1 }
+      or skip "Cannot load XS::APItest", 2;
+    # writable "P"
+    my $orig = "x" x 36;
+    my $data = $orig;
+    my $ptr = unpack 'L!', pack 'P', $data;
+    XS::APItest::modify_pv($ptr, length $data);
+    is($data, "y" x 36, "check \$data was modified");
+    is($orig, "x" x 36, "check \$orig wasn't modified");
+}
+
 # undef should give null pointer
 like(pack("p", undef), qr/^\0+$/);
 like(pack("p<", undef), qr/^\0+$/);