This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update IPC-SysV to CPAN version 2.04
[perl5.git] / cpan / IPC-SysV / t / ipcsysv.t
CommitLineData
8f85282b
MHM
1################################################################################
2#
dd0df890 3# Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>.
8f85282b
MHM
4# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
5#
6# This program is free software; you can redistribute it and/or
7# modify it under the same terms as Perl itself.
8#
9################################################################################
10
6edcbe38 11BEGIN {
8f85282b
MHM
12 require Test::More; import Test::More;
13 require Config; import Config;
6edcbe38 14
8f85282b
MHM
15 if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
16 plan(skip_all => 'IPC::SysV was not built');
17 }
1ba50a1a 18}
6edcbe38 19
8f85282b
MHM
20if ($Config{'d_sem'} ne 'define') {
21 plan(skip_all => '$Config{d_sem} undefined');
1ba50a1a
DL
22}
23elsif ($Config{'d_msg'} ne 'define') {
8f85282b 24 plan(skip_all => '$Config{d_msg} undefined');
6edcbe38
JH
25}
26
8f85282b
MHM
27plan(tests => 38);
28
6edcbe38
JH
29# These constants are common to all tests.
30# Later the sem* tests will import more for themselves.
31
32use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
33use strict;
34
8f85282b
MHM
35{
36 my $did_diag = 0;
37
38 sub do_sys_diag
39 {
40 return if $did_diag++;
41
42 if ($^O eq 'cygwin') {
43 diag(<<EOM);
44
45It may be that the cygserver service isn't running.
46
47EOM
48
49 diag(<<EOM) unless exists $ENV{CYGWIN} && $ENV{CYGWIN} eq 'server';
50You also may have to set the CYGWIN environment variable
51to 'server' before running the test suite:
52
53 export CYGWIN=server
54
55EOM
56 }
57 else {
58 diag(<<EOM);
6edcbe38 59
6edcbe38
JH
60It may be that your kernel does not have SysV IPC configured.
61
62EOM
8f85282b
MHM
63
64 diag(<<EOM) if $^O eq 'freebsd';
6edcbe38
JH
65You must have following options in your kernel:
66
67options SYSVSHM
68options SYSVSEM
69options SYSVMSG
70
71See config(8).
1ba50a1a 72
6edcbe38
JH
73EOM
74 }
8f85282b
MHM
75 }
76}
77
78{
79 my $SIGSYS_caught = 0;
80
81 sub skip_or_die
82 {
83 my($what, $why) = @_;
84 if ($SIGSYS_caught) {
85 do_sys_diag();
86 return "$what failed: SIGSYS caught";
87 }
88 my $info = "$what failed: $why";
503ba33a
MHM
89 if ($why == &IPC::SysV::ENOSPC || $why == &IPC::SysV::ENOSYS ||
90 $why == &IPC::SysV::ENOMEM || $why == &IPC::SysV::EACCES) {
8f85282b
MHM
91 do_sys_diag() if $why == &IPC::SysV::ENOSYS;
92 return $info;
93 }
94 die $info;
95 }
96
97 sub catchsig
98 {
99 my $code = shift;
100 if (exists $SIG{SYS}) {
101 local $SIG{SYS} = sub { $SIGSYS_caught++ };
102 return $code->();
103 }
104 return $code->();
105 }
106}
107
108# FreeBSD and cygwin are known to throw this if there's no SysV IPC
109# in the kernel or the cygserver isn't running properly.
110if (exists $SIG{SYS}) { # No SIGSYS with older perls...
111 $SIG{SYS} = sub {
112 do_sys_diag();
1ba50a1a 113 diag('Bail out! SIGSYS caught');
6edcbe38 114 exit(1);
8f85282b
MHM
115 };
116}
117
118my $msg;
6edcbe38
JH
119
120my $perm = S_IRWXU;
8f85282b
MHM
121my $test_name;
122my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
6edcbe38 123
1ba50a1a 124SKIP: {
8f85282b
MHM
125 skip('lacking d_msgget d_msgctl d_msgsnd d_msgrcv', 6) unless
126 $Config{'d_msgget'} eq 'define' &&
127 $Config{'d_msgctl'} eq 'define' &&
128 $Config{'d_msgsnd'} eq 'define' &&
129 $Config{'d_msgrcv'} eq 'define';
1ba50a1a 130
8f85282b 131 $msg = catchsig(sub { msgget(IPC_PRIVATE, $perm) });
6edcbe38 132
8f85282b
MHM
133 # Very first time called after machine is booted value may be 0
134 unless (defined $msg && $msg >= 0) {
135 skip(skip_or_die('msgget', $!), 6);
136 }
6edcbe38 137
8f85282b 138 pass('msgget IPC_PRIVATE S_IRWXU');
6edcbe38 139
8f85282b
MHM
140 #Putting a message on the queue
141 my $msgtype = 1;
142 my $msgtext = "hello";
6edcbe38 143
8f85282b
MHM
144 my $test2bad;
145 my $test5bad;
146 my $test6bad;
147
148 $test_name = 'queue a message';
149
150 if (msgsnd($msg, pack("L$N a*", $msgtype, $msgtext), IPC_NOWAIT)) {
151 pass($test_name);
152 }
153 else {
154 fail($test_name);
155 $test2bad = 1;
156 diag(<<EOM);
1ba50a1a
DL
157The failure of the subtest #2 may indicate that the message queue
158resource limits either of the system or of the testing account
159have been reached. Error message "Operating would block" is
160usually indicative of this situation. The error message was now:
161"$!"
162
163You can check the message queues with the 'ipcs' command and
164you can remove unneeded queues with the 'ipcrm -q id' command.
165You may also consider configuring your system or account
166to have more message queue resources.
167
168Because of the subtest #2 failing also the substests #5 and #6 will
169very probably also fail.
6edcbe38 170EOM
8f85282b 171 }
6edcbe38 172
8f85282b
MHM
173 my $data = '';
174 ok(msgctl($msg, IPC_STAT, $data), 'msgctl IPC_STAT call');
6edcbe38 175
8f85282b 176 cmp_ok(length($data), '>', 0, 'msgctl IPC_STAT data');
6edcbe38 177
8f85282b
MHM
178 $test_name = 'message get call';
179
180 my $msgbuf = '';
181 if (msgrcv($msg, $msgbuf, 256, 0, IPC_NOWAIT)) {
182 pass($test_name);
183 }
184 else {
185 fail($test_name);
186 $test5bad = 1;
187 }
188 if ($test5bad && $test2bad) {
189 diag(<<EOM);
1ba50a1a 190This failure was to be expected because the subtest #2 failed.
6edcbe38 191EOM
8f85282b 192 }
6edcbe38 193
8f85282b
MHM
194 $test_name = 'message get data';
195
196 my($rmsgtype, $rmsgtext);
197 ($rmsgtype, $rmsgtext) = unpack("L$N a*", $msgbuf);
198
199 if ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
200 pass($test_name);
201 }
202 else {
203 fail($test_name);
204 $test6bad = 1;
205 }
206
207 if ($test6bad && $test2bad) {
1ba50a1a
DL
208 print <<EOM;
209This failure was to be expected because the subtest #2 failed.
6edcbe38 210EOM
8f85282b
MHM
211 }
212}
213
214my $sem;
6edcbe38 215
1ba50a1a 216SKIP: {
8f85282b
MHM
217 skip('lacking d_semget d_semctl', 11) unless
218 $Config{'d_semget'} eq 'define' &&
219 $Config{'d_semctl'} eq 'define';
6edcbe38 220
8f85282b 221 use IPC::SysV qw(IPC_CREAT GETALL SETALL);
6edcbe38 222
8f85282b
MHM
223 # FreeBSD's default limit seems to be 9
224 my $nsem = 5;
6edcbe38 225
8f85282b 226 $sem = catchsig(sub { semget(IPC_PRIVATE, $nsem, $perm | IPC_CREAT) });
4aaee4e1 227
8f85282b
MHM
228 # Very first time called after machine is booted value may be 0
229 unless (defined $sem && $sem >= 0) {
230 skip(skip_or_die('semget', $!), 11);
231 }
6edcbe38 232
8f85282b
MHM
233 pass('sem acquire');
234
235 my $data = '';
236 ok(semctl($sem, 0, IPC_STAT, $data), 'sem data call');
237
238 cmp_ok(length($data), '>', 0, 'sem data len');
239
240 ok(semctl($sem, 0, SETALL, pack("s$N*", (0) x $nsem)), 'set all sems');
6edcbe38 241
8f85282b
MHM
242 $data = "";
243 ok(semctl($sem, 0, GETALL, $data), 'get all sems');
6edcbe38 244
8f85282b 245 is(length($data), length(pack("s$N*", (0) x $nsem)), 'right length');
6edcbe38 246
8f85282b 247 my @data = unpack("s$N*", $data);
6edcbe38 248
8f85282b 249 my $adata = "0" x $nsem;
6edcbe38 250
8f85282b
MHM
251 is(scalar(@data), $nsem, 'right amount');
252 cmp_ok(join("", @data), 'eq', $adata, 'right data');
6edcbe38 253
8f85282b 254 my $poke = 2;
6edcbe38 255
8f85282b
MHM
256 $data[$poke] = 1;
257 ok(semctl($sem, 0, SETALL, pack("s$N*", @data)), 'poke it');
258
259 $data = "";
260 ok(semctl($sem, 0, GETALL, $data), 'and get it back');
261
262 @data = unpack("s$N*", $data);
263 my $bdata = "0" x $poke . "1" . "0" x ($nsem - $poke - 1);
264
265 cmp_ok(join("", @data), 'eq', $bdata, 'changed');
266}
267
268SKIP: {
269 skip('lacking d_shm', 10) unless
270 $Config{'d_shm'} eq 'define';
6edcbe38 271
8f85282b 272 use IPC::SysV qw(shmat shmdt memread memwrite ftok);
6edcbe38 273
8f85282b 274 my $shm = catchsig(sub { shmget(IPC_PRIVATE, 4, S_IRWXU) });
6edcbe38 275
8f85282b
MHM
276 # Very first time called after machine is booted value may be 0
277 unless (defined $shm && $shm >= 0) {
278 skip(skip_or_die('shmget', $!), 10);
279 }
6edcbe38 280
8f85282b 281 pass("shm acquire");
6edcbe38 282
8f85282b
MHM
283 ok(shmwrite($shm, pack("N", 0xdeadbeef), 0, 4), 'shmwrite(0xdeadbeef)');
284
285 my $addr = shmat($shm, undef, 0);
286 ok(defined $addr, 'shmat');
287
288 is(unpack("N", unpack("P4", $addr)), 0xdeadbeef, 'read shm by addr');
289
290 ok(defined shmctl($shm, IPC_RMID, 0), 'shmctl(IPC_RMID)');
291
292 my $var = '';
293 ok(memread($addr, $var, 0, 4), 'memread($var)');
294
295 is(unpack("N", $var), 0xdeadbeef, 'read shm by memread');
296
297 ok(memwrite($addr, pack("N", 0xbadc0de5), 0, 4), 'memwrite(0xbadc0de5)');
298
299 is(unpack("N", unpack("P4", $addr)), 0xbadc0de5, 'read modified shm by addr');
300
301 ok(defined shmdt($addr), 'shmdt');
302}
303
304SKIP: {
305 skip('lacking d_shm', 11) unless
306 $Config{'d_shm'} eq 'define';
307
308 use IPC::SysV qw(ftok);
309
310 my $key1i = ftok($0);
311 my $key1e = ftok($0, 1);
312
313 ok(defined $key1i, 'ftok implicit project id');
314 ok(defined $key1e, 'ftok explicit project id');
315 is($key1i, $key1e, 'keys match');
316
317 my $keyAsym = ftok($0, 'A');
318 my $keyAnum = ftok($0, ord('A'));
319
320 ok(defined $keyAsym, 'ftok symbolic project id');
321 ok(defined $keyAnum, 'ftok numeric project id');
322 is($keyAsym, $keyAnum, 'keys match');
323
324 my $two = '2';
325 my $key1 = ftok($0, 2);
326 my $key2 = ftok($0, ord('2'));
327 my $key3 = ftok($0, $two);
328 my $key4 = ftok($0, int($two));
329
330 is($key1, $key4, 'keys match');
331 isnt($key1, $key2, 'keys do not match');
332 is($key2, $key3, 'keys match');
333
334 eval { my $foo = ftok($0, 'AA') };
335 ok(index($@, 'invalid project id') >= 0, 'ftok error');
336
337 eval { my $foo = ftok($0, 3.14159) };
338 ok(index($@, 'invalid project id') >= 0, 'ftok error');
339}
6edcbe38 340
1ba50a1a 341END {
8f85282b
MHM
342 msgctl($msg, IPC_RMID, 0) if defined $msg;
343 semctl($sem, 0, IPC_RMID, 0) if defined $sem;
6edcbe38 344}