doio: fix shmread() on non-string buffers

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);

pod/perldelta.pod

@@ -373,6 +373,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

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)