From 6924143a860d0bcd40a30eb75953a3afdaa1ae69 Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Wed, 8 Jan 2025 11:46:22 +0100 Subject: [PATCH 1/4] doio: fix shmio args assert PERL_ARGS_ASSERT_DO_SHMIO is equivalent to `assert(mark); assert(sp)`. There is no point in checking pointers that have already been dereferenced by previous statements. An optimizing compiler will simply remove those asserts as no-ops. Move the asserts up to before any of the function arguments are used. --- doio.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doio.c b/doio.c index 24bc91d937dd..a959180ade8e 100644 --- a/doio.c +++ b/doio.c @@ -3356,6 +3356,9 @@ I32 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_SHM + PERL_ARGS_ASSERT_DO_SHMIO; + PERL_UNUSED_ARG(sp); + char *shm; struct shmid_ds shmds; const I32 id = SvIVx(*++mark); @@ -3363,9 +3366,6 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) 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) return -1; From 55f136d68d8196b41412cc652a9257e47fe09ffb Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Wed, 8 Jan 2025 14:22:33 +0100 Subject: [PATCH 2/4] doio: make do_shmio() work with args beyond I32 - Extend mpos/msize to the full size_t/STRLEN range (whatever that is on the current platform). - Fully validate the range of all incoming values, including making sure that mpos+misze does not overflow (I think you used to be able to crash perl with this before). - Assert that the optype is either OP_SHMREAD or OP_SHMWRITE (because the code blindly performs a shmwrite() if optype is not OP_SHMREAD). - Switch to Perl_croak_nocontext because why not. Fixes #22895. --- doio.c | 84 ++++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 61 insertions(+), 23 deletions(-) diff --git a/doio.c b/doio.c index a959180ade8e..87acf450bd7b 100644 --- a/doio.c +++ b/doio.c @@ -3359,38 +3359,75 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) PERL_ARGS_ASSERT_DO_SHMIO; PERL_UNUSED_ARG(sp); - 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); + 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; + } + const int id = iv_id; - SETERRNO(0,0); - if (shmctl(id, IPC_STAT, &shmds) == -1) + /* 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 (mpos < 0 || msize < 0 - || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { - SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ + } + 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; } - if (id >= 0) { - shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); - } else { - SETERRNO(EINVAL,LIB_INVARG); + 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 } From 01ac950d56a44f70e2e10b5cc6440140428f20dd Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Wed, 8 Jan 2025 14:28:06 +0100 Subject: [PATCH 3/4] t/io/shm.t: test shmwrite beyond the 2GB mark Guard tests behind PERL_TEST_MEMORY because we're allocating a 2GB shared mem segment and a 2GB scalar buffer. These tests used to fail (or crash) before the do_shmio() I32 fixes. Also fix the error message if the initial shmget fails ("IPC::SharedMem->new" was a copy/paste oversight from when these tests were copied in from IPC::SysV in 2d5385e000). Also test that shmwrite() from a tied buffer only calls FETCH once while we're at it. --- t/io/shm.t | 32 +++++++++++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) 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"); +} From 734a88119d66e1729be3b2e13861dc2d34c92f9b Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Wed, 8 Jan 2025 14:33:48 +0100 Subject: [PATCH 4/4] perldelta for the shmread/shmwrite 31-bit fixes --- pod/perldelta.pod | 5 +++++ 1 file changed, 5 insertions(+) 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