In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/fb42fcd60deb02934a9c292d63d3290ea1741c44?hp=1c6ce212d37a2a17424675e94afb035a9a446f9f>
- Log -----------------------------------------------------------------
commit fb42fcd60deb02934a9c292d63d3290ea1741c44
Author: Tony Cook <t...@develop-help.com>
Date: Wed Dec 4 01:30:57 2013 +0100
Brian Childs is now a perl AUTHOR
M AUTHORS
commit 64d7628235943ff18939a1ff98ace513aeb5260c
Author: Brian Childs <br...@rentec.com>
Date: Tue Dec 3 06:33:41 2013 +0100
Fixes the case where on 64bit big-endian boxes, calls to
semctl(id,semnum,SETVAL,$wantedval) will ignore the passed in $wantedval, and
always use 0
M MANIFEST
M doio.c
A t/io/sem.t
-----------------------------------------------------------------------
Summary of changes:
AUTHORS | 1 +
MANIFEST | 1 +
doio.c | 9 ++++++--
t/io/sem.t | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 81 insertions(+), 2 deletions(-)
create mode 100644 t/io/sem.t
diff --git a/AUTHORS b/AUTHORS
index 9bf9b04..076aac6 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -138,6 +138,7 @@ Bill Glicker <bi...@burrelles.com>
Billy Constantine <wdcon...@cs.adelaide.edu.au>
Blair Zajac <bl...@orcaware.com>
Brandon Black <blbl...@gmail.com>
+Brian Childs <br...@rentec.com>
Bo Borgerson <gig...@gmail.com>
Bo Johansson <bo.johan...@lsn.se>
Bo Lindbergh <b...@stacken.kth.se>
diff --git a/MANIFEST b/MANIFEST
index 880e830..dda46b0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4898,6 +4898,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/sem.t See if SysV semaphores work
t/io/shm.t See if SysV shared memory works
t/io/tell.t See if file seeking works
t/io/through.t See if pipe passes data intact
diff --git a/doio.c b/doio.c
index 98e2c42..b39c587 100644
--- a/doio.c
+++ b/doio.c
@@ -2155,11 +2155,16 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
#ifdef Semctl
union semun unsemds;
+ if(cmd == SETVAL) {
+ unsemds.val = PTR2nat(a);
+ }
+ else {
#ifdef EXTRA_F_IN_SEMUN_BUF
- unsemds.buff = (struct semid_ds *)a;
+ unsemds.buff = (struct semid_ds *)a;
#else
- unsemds.buf = (struct semid_ds *)a;
+ unsemds.buf = (struct semid_ds *)a;
#endif
+ }
ret = Semctl(id, n, cmd, unsemds);
#else
/* diag_listed_as: sem%s not implemented */
diff --git a/t/io/sem.t b/t/io/sem.t
new file mode 100644
index 0000000..272c396
--- /dev/null
+++ b/t/io/sem.t
@@ -0,0 +1,72 @@
+#!perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+
+ require "./test.pl";
+ require Config; import Config;
+
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ skip_all('-- IPC::SysV was not built');
+ }
+ skip_all_if_miniperl();
+ if ($Config{'d_sem'} ne 'define') {
+ skip_all('-- $Config{d_sem} undefined');
+ }
+}
+
+use strict;
+our $TODO;
+
+use sigtrap qw/die normal-signals error-signals/;
+use IPC::SysV qw/ IPC_PRIVATE S_IRUSR S_IWUSR IPC_RMID SETVAL GETVAL SETALL
GETALL IPC_CREAT /;
+
+my $id;
+my $nsem = 10;
+END { semctl $id, IPC_RMID, 0, 0 if defined $id }
+
+{
+ local $SIG{SYS} = sub { skip_all("SIGSYS caught") } if exists $SIG{SYS};
+ $id = semget IPC_PRIVATE, $nsem, S_IRUSR | S_IWUSR | IPC_CREAT;
+}
+
+if (not defined $id) {
+ my $info = "semget failed: $!";
+ if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS ||
+ $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
+ plan(skip_all => $info);
+ }
+ else {
+ die $info;
+ }
+}
+else {
+ plan(tests => 7);
+ pass('acquired semaphore');
+}
+
+{ # [perl #120635] 64 bit big-endian semctl SETVAL bug
+ ok(semctl($id, "ignore", SETALL, pack("s!*",(0)x$nsem)),
+ "Initialize all $nsem semaphores to zero");
+
+ my $sem2set = 3;
+ my $semval = 17;
+ ok(semctl($id, $sem2set, SETVAL, $semval),
+ "Set semaphore $sem2set to $semval");
+
+ my $semvals;
+ ok(semctl($id, "ignore", GETALL, $semvals),
+ 'Get current semaphore values');
+
+ my @semvals = unpack("s!*", $semvals);
+ is(scalar(@semvals), $nsem,
+ "Make sure we get back statuses for all $nsem semaphores");
+
+ is($semvals[$sem2set], $semval,
+ "Checking value of semaphore $sem2set");
+
+ is(semctl($id, $sem2set, GETVAL, "ignored"), $semval,
+ "Check value via GETVAL");
+}
+
--
Perl5 Master Repository
