diff --git a/doio.c b/doio.c index 24bc91d937dd..87acf450bd7b 100644 --- a/doio.c +++ b/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,10 +3437,11 @@ 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); @@ -3411,7 +3449,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) 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 } diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 2d4881a6b6aa..5f2333089750 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -368,6 +368,11 @@ manager will later use a regex to expand these into links. XXX +=item * + +L and L are no longer limited to 31-bit +values for their POS and SIZE arguments. [GH #22895] + =back =head1 Known Problems diff --git a/t/io/shm.t b/t/io/shm.t index 1070bdf5b146..c54e07b4b446 100644 --- a/t/io/shm.t +++ b/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"); +}