From 3a16cb5fb8114b7773a9c488c78684bffd787b62 Mon Sep 17 00:00:00 2001
From: Lukas Mai <lukasmai.403@gmail.com>
Date: Thu, 9 Jan 2025 00:46:39 +0100
Subject: [PATCH] doio: fix shmread() on non-string buffers

- If the buffer is a reference, don't leak memory (or abort, on
  debugging perls). The problem is that SvPOK_only() blindly turns off
  some SV flags, but does not decrement any refcounts if ROK was on.
- If the buffer is tied, don't call FETCH. Conceptually, shmread() is a
  bytestring assignment (from a shared memory segment to a scalar
  variable), so it should only STORE. (This is also why most of the code
  can be replaced by sv_setpvn().)

Fixes #22898.
---
 doio.c            | 13 ++-----------
 pod/perldelta.pod |  8 ++++++++
 t/io/shm.t        | 17 +++++++++++++++--
 3 files changed, 25 insertions(+), 13 deletions(-)

diff --git a/doio.c b/doio.c
index 87acf450bd7b..e5a6cade7765 100644
--- a/doio.c
+++ b/doio.c
@@ -3421,17 +3421,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
         return -1;
 
     if (optype == OP_SHMREAD) {
-        SvGETMAGIC(mstr);
-        SvUPGRADE(mstr, SVt_PV);
-        /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
-        if (! SvOK(mstr))
-            SvPVCLEAR(mstr);
-        SvPOK_only(mstr);
-        char *const mbuf = SvGROW(mstr, (STRLEN)msize+1);
-
-        Copy(shm + mpos, mbuf, msize, char);
-        SvCUR_set(mstr, msize);
-        *SvEND(mstr) = '\0';
+        sv_setpvn(mstr, shm + mpos, msize);
+        SvUTF8_off(mstr);
         SvSETMAGIC(mstr);
         /* who knows who has been playing with this shared memory? */
         SvTAINTED_on(mstr);
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 06e2335a252b..b4b51df8930f 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -393,6 +393,14 @@ XXX
 L<perlfunc/shmread> and L<perlfunc/shmwrite> are no longer limited to 31-bit
 values for their POS and SIZE arguments. [GH #22895]
 
+=item *
+
+L<perlfunc/shmread> is now better behaved if VAR is not a plain string. If VAR
+is a tied variable, it calls C<STORE> once; previously, it would also call
+C<FETCH>, but without using the result. If VAR is a reference, the referenced
+entity has its refcount properly decremented when VAR is turned into a string;
+previously, it would leak memory. [GH #22898]
+
 =back
 
 =head1 Known Problems
diff --git a/t/io/shm.t b/t/io/shm.t
index c54e07b4b446..69589d023763 100644
--- a/t/io/shm.t
+++ b/t/io/shm.t
@@ -54,7 +54,7 @@ if (not defined $key) {
   }
 }
 else {
-	plan(tests => 28);
+	plan(tests => 33);
 	pass('acquired shared mem');
 }
 
@@ -87,7 +87,7 @@ my ($fetch, $store) = (0, 0);
   sub STORE     { ++$store; $_[0][0] = $_[1] } }
 tie my $ct, 'Counted';
 shmread $key, $ct, 0, 1;
-is($fetch, 1, "shmread FETCH once");
+is($fetch, 0, "shmread FETCH none");
 is($store, 1, "shmread STORE once");
 ($fetch, $store) = (0, 0);
 shmwrite $key, $ct, 0, 1;
@@ -110,6 +110,19 @@ is($store, 0, "shmwrite STORE none");
     is($rdbuf, $text, "check we got back the expected (upgraded source)");
 }
 
+# GH #22898 - reading into reference is sane
+{
+    my $rdbuf = [];
+    builtin::weaken(my $wref = $rdbuf);
+
+    my $text = 'A';
+    ok(shmwrite($key, $text, 0, 1), "wrote 'A' to shared segment");
+    ok(shmread($key, $rdbuf, 0, 1), "read 1 byte into buffer that previously stored a ref");
+    is(ref($rdbuf), '', "buffer is not a reference anymore");
+    is($rdbuf, $text, "buffer contains expected string");
+    is($wref, undef, "no leak: referenced object had refcount decremented");
+}
+
 # GH #22895 - 2^31 boundary
 SKIP: {
     skip("need at least 5GB of memory for this test", 5)