From 70cffaec10350bd5a6936fb63022774cfd0355cb Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 15 Jul 2024 11:45:16 +1000
Subject: [PATCH] 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 by 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
as usable.

Fixes the UUID::FFI part of #22380

Some other modules (and UUID::FFI itself, really) will need XS
fixes.
---
 ext/XS-APItest/APItest.xs |  6 +++++-
 pp_pack.c                 |  2 +-
 t/op/pack.t               | 16 +++++++++++++++-
 3 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 455bdf67d632..1676ded76c8d 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/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
 
diff --git a/pp_pack.c b/pp_pack.c
index f436b45d2bb7..bb3304b13383 100644
--- a/pp_pack.c
+++ b/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);
diff --git a/t/op/pack.t b/t/op/pack.t
index 93865b0b3d5f..441a2c01841b 100644
--- a/t/op/pack.t
+++ b/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 'j', 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+$/);