[perl.git] branch blead, updated. v5.21.5-10-gfa367bc

[Aaron Crane]

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