From 61c4568c5950efb10a908a153cfa02ea4af4b4eb 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 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 #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 455bdf67d6327..1676ded76c8dd 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 f436b45d2bb76..bb3304b13383b 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 93865b0b3d5f9..80cb7b074d82e 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 '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+$/);