In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/fa367bcbf78381959666f443b5f1d9da7870f943?hp=6aa683079638ed0b1923473b64317a0ef3a99849>
- Log ----------------------------------------------------------------- commit fa367bcbf78381959666f443b5f1d9da7870f943 Author: Aaron Crane <a...@cpan.org> Date: Mon Oct 20 15:22:52 2014 +0100 Fix stack-management bug when semctl encounters errors The success cases in pp_semctl both push a single value to the stack, but the error case merely set the topmost stack value to undef. The fix is to push an undef. This bug manifests most obviously as an "uninitialized value in list slice" warning when doing something like `my $test = (semctl -1,0,0,0)[0]`; that was reported out-of-band to rjbs. ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + pp_sys.c | 2 +- t/io/semctl.t | 24 ++++++++++++++++++++++++ 3 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 t/io/semctl.t diff --git a/MANIFEST b/MANIFEST index a31d29b..8fb37a6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4868,6 +4868,7 @@ t/io/print.t See if print commands work t/io/pvbm.t See if PVBMs break IO commands t/io/read.t See if read works t/io/say.t See if say works +t/io/semctl.t See if SysV semaphore semctl works t/io/sem.t See if SysV semaphores work t/io/shm.t See if SysV shared memory works t/io/socket.t See if socket functions work diff --git a/pp_sys.c b/pp_sys.c index 95a709b..16c2d60 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -4753,7 +4753,7 @@ PP(pp_semctl) const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) - RETSETUNDEF; + RETPUSHUNDEF; if (anum != 0) { PUSHi(anum); } diff --git a/t/io/semctl.t b/t/io/semctl.t new file mode 100644 index 0000000..5394ac1 --- /dev/null +++ b/t/io/semctl.t @@ -0,0 +1,24 @@ +use strict; +use warnings; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib' && -d '../ext'; + + require "./test.pl"; + require Config; import Config; +} + +skip_all('no SysV semaphores on this platform') if !$Config{d_sem}; + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, $_[0] }; + my $test = (semctl(-1,0,0,0))[0]; + ok(!defined $test, "erroneous semctl list slice yields undef"); +} + +is(scalar @warnings, 0, "no warnings from erroneous semctl list slice") + or diag("warnings found: @warnings"); + +done_testing; -- Perl5 Master Repository