make shmread/shmwrite work with args beyond I32/2GB

doio.c

@@ -3356,41 +3356,78 @@ I32
 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 {
 #ifdef HAS_SHM
-    char *shm;
-    struct shmid_ds shmds;
-    const I32 id = SvIVx(*++mark);
-    SV * const mstr = *++mark;
-    const I32 mpos = SvIVx(*++mark);
-    const I32 msize = SvIVx(*++mark);
-
     PERL_ARGS_ASSERT_DO_SHMIO;
     PERL_UNUSED_ARG(sp);
 
-    SETERRNO(0,0);
-    if (shmctl(id, IPC_STAT, &shmds) == -1)
+    const IV iv_id = SvIVx(*++mark);
+    SV *const mstr = *++mark;
+    const IV iv_mpos = SvIVx(*++mark);
+    const IV iv_msize = SvIVx(*++mark);
+
+    /* must fit in int */
+    if (
+        iv_id < 0
+        || (sizeof (IV) > sizeof (int) && iv_id > PERL_INT_MAX)
+    ) {
+        SETERRNO(EINVAL,LIB_INVARG);
         return -1;
-    if (mpos < 0 || msize < 0
-        || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
-        SETERRNO(EFAULT,SS_ACCVIO);		/* can't do as caller requested */
+    }
+    const int id = iv_id;
+
+    /* must fit in both size_t and STRLEN (a.k.a Size_t) */
+    if (
+        iv_mpos < 0
+        || (sizeof (IV) > sizeof (size_t) && iv_mpos > (IV)SIZE_MAX)
+        || (sizeof (IV) > sizeof (STRLEN) && iv_mpos > (IV)(STRLEN)-1)
+    ) {
+        SETERRNO(EFAULT,SS_ACCVIO);
         return -1;
     }
-    if (id >= 0) {
-        shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
-    } else {
-        SETERRNO(EINVAL,LIB_INVARG);
+    const size_t mpos = iv_mpos;
+
+    /* must fit in both size_t and STRLEN (a.k.a Size_t) */
+    if (
+        iv_msize < 0
+        || (sizeof (IV) > sizeof (size_t) && iv_msize > (IV)SIZE_MAX)
+        || (sizeof (IV) > sizeof (STRLEN) && iv_msize > (IV)(STRLEN)-1)
+        /* for shmread(), we need one extra byte for the NUL terminator */
+        || (optype == OP_SHMREAD && (STRLEN)iv_msize > (STRLEN)-1 - 1)
+    ) {
+        SETERRNO(EFAULT,SS_ACCVIO);
+        return -1;
+    }
+    const size_t msize = iv_msize;
+
+    if (SIZE_MAX - mpos < msize) {
+        /* overflow */
+        SETERRNO(EFAULT,SS_ACCVIO);
         return -1;
     }
-    if (shm == (char *)-1)	/* I hate System V IPC, I really do */
+    const size_t mpos_end = mpos + msize;
+
+    SETERRNO(0,0);
+
+    struct shmid_ds shmds;
+    if (shmctl(id, IPC_STAT, &shmds) == -1)
+        return -1;
+
+    if (mpos_end > (size_t)shmds.shm_segsz) {
+        SETERRNO(EFAULT,SS_ACCVIO);
         return -1;
+    }
+
+    char *const shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
+    if (shm == (char *)-1)      /* I hate System V IPC, I really do */
+        return -1;
+
     if (optype == OP_SHMREAD) {
-        char *mbuf;
-        /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
         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);
-        mbuf = SvGROW(mstr, (STRLEN)msize+1);
+        char *const mbuf = SvGROW(mstr, (STRLEN)msize+1);
 
         Copy(shm + mpos, mbuf, msize, char);
         SvCUR_set(mstr, msize);
@@ -3400,18 +3437,19 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
         SvTAINTED_on(mstr);
     }
     else {
-        STRLEN len;
+        assert(optype == OP_SHMWRITE);
 
-        const char *mbuf = SvPVbyte(mstr, len);
-        const I32 n = ((I32)len > msize) ? msize : (I32)len;
+        STRLEN len;
+        const char *const mbuf = SvPVbyte(mstr, len);
+        const STRLEN n = (len > msize) ? msize : len;
         Copy(mbuf, shm + mpos, n, char);
         if (n < msize)
             memzero(shm + mpos + n, msize - n);
     }
     return shmdt(shm);
 #else
     /* diag_listed_as: shm%s not implemented */
-    Perl_croak(aTHX_ "shm I/O not implemented");
+    Perl_croak_nocontext("shm I/O not implemented");
     return -1;
 #endif
 }

pod/perldelta.pod

@@ -368,6 +368,11 @@ manager will later use a regex to expand these into links.
 
 XXX
 
+=item *
+
+L<perlfunc/shmread> and L<perlfunc/shmwrite> are no longer limited to 31-bit
+values for their POS and SIZE arguments. [GH #22895]
+
 =back
 
 =head1 Known Problems

t/io/shm.t

@@ -44,7 +44,7 @@ END { shmctl $key, IPC_RMID, 0 if defined $key }
 }
 
 if (not defined $key) {
-  my $info = "IPC::SharedMem->new failed: $!";
+  my $info = "shmget() failed: $!";
   if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS ||
       $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
     skip_all($info);
@@ -54,7 +54,7 @@ if (not defined $key) {
   }
 }
 else {
-	plan(tests => 21);
+	plan(tests => 28);
 	pass('acquired shared mem');
 }
 
@@ -85,10 +85,14 @@ my ($fetch, $store) = (0, 0);
   sub TIESCALAR { bless [undef] }
   sub FETCH     { ++$fetch; $_[0][0] }
   sub STORE     { ++$store; $_[0][0] = $_[1] } }
-tie $ct, 'Counted';
+tie my $ct, 'Counted';
 shmread $key, $ct, 0, 1;
 is($fetch, 1, "shmread FETCH once");
 is($store, 1, "shmread STORE once");
+($fetch, $store) = (0, 0);
+shmwrite $key, $ct, 0, 1;
+is($fetch, 1, "shmwrite FETCH once");
+is($store, 0, "shmwrite STORE none");
 
 {
     # check reading into an upgraded buffer is sane
@@ -105,3 +109,25 @@ is($store, 1, "shmread STORE once");
     ok(shmread($key, $rdbuf, 0, 4), "read it back (upgraded source)");
     is($rdbuf, $text, "check we got back the expected (upgraded source)");
 }
+
+# GH #22895 - 2^31 boundary
+SKIP: {
+    skip("need at least 5GB of memory for this test", 5)
+        unless ($ENV{PERL_TEST_MEMORY} // 0) >= 5;
+
+    # delete previous allocation
+    shmctl $key, IPC_RMID, 0;
+    $key = undef;
+
+    my $int32_max = 0x7fff_ffff;
+    $key = shmget(IPC_PRIVATE, $int32_max+2, S_IRWXU) // die "shmget(2GB+1) failed: $!";
+    my $bigbuf = 'A' x $int32_max;
+    ok(shmwrite($key, $bigbuf, 0, length($bigbuf)), "wrote $int32_max bytes");
+    $bigbuf .= 'X';
+    ok(shmwrite($key, $bigbuf, 0, length($bigbuf)), "wrote $int32_max+1 bytes");
+    my $smallbuf = 'X';
+    ok(shmwrite($key, $smallbuf, $int32_max, 1), "wrote 1 byte at offset $int32_max");
+    ok(shmwrite($key, $smallbuf, $int32_max+1, 1), "wrote 1 byte at offset $int32_max+1");
+    my $int30x = 0x4000_0000;
+    ok(shmwrite($key, $bigbuf, $int30x, $int30x), "wrote $int30x bytes at offset $int30x");
+}