This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to IPC-SysV 2.05.
[perl5.git] / cpan / IPC-SysV / t / ipcsysv.t
1 ################################################################################
2 #
3 #  Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>.
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
11 BEGIN {
12   require Test::More; import Test::More;
13   require Config; import Config;
14
15   if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
16     plan(skip_all => 'IPC::SysV was not built');
17   }
18 }
19
20 if ($Config{'d_sem'} ne 'define') {
21   plan(skip_all => '$Config{d_sem} undefined');
22 }
23 elsif ($Config{'d_msg'} ne 'define') {
24   plan(skip_all => '$Config{d_msg} undefined');
25 }
26
27 plan(tests => 39);
28
29 # These constants are common to all tests.
30 # Later the sem* tests will import more for themselves.
31
32 use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
33 use strict;
34
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
45 It may be that the cygserver service isn't running.
46
47 EOM
48
49       diag(<<EOM) unless exists $ENV{CYGWIN} && $ENV{CYGWIN} eq 'server';
50 You also may have to set the CYGWIN environment variable
51 to 'server' before running the test suite:
52
53   export CYGWIN=server
54
55 EOM
56     }
57     else {
58       diag(<<EOM);
59
60 It may be that your kernel does not have SysV IPC configured.
61
62 EOM
63
64       diag(<<EOM) if $^O eq 'freebsd';
65 You must have following options in your kernel:
66
67 options         SYSVSHM
68 options         SYSVSEM
69 options         SYSVMSG
70
71 See config(8).
72
73 EOM
74     }
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";
89     if ($why == &IPC::SysV::ENOSPC || $why == &IPC::SysV::ENOSYS ||
90         $why == &IPC::SysV::ENOMEM || $why == &IPC::SysV::EACCES) {
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.
110 if (exists $SIG{SYS}) {  # No SIGSYS with older perls...
111   $SIG{SYS} = sub {
112     do_sys_diag();
113     diag('Bail out! SIGSYS caught');
114     exit(1);
115   };
116 }
117
118 my $msg;
119
120 my $perm = S_IRWXU;
121 my $test_name;
122 my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
123
124 SKIP: {
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';
130
131   $msg = catchsig(sub { msgget(IPC_PRIVATE, $perm) });
132
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   }
137
138   pass('msgget IPC_PRIVATE S_IRWXU');
139
140   #Putting a message on the queue
141   my $msgtype = 1;
142   my $msgtext = "hello";
143
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);
157 The failure of the subtest #2 may indicate that the message queue
158 resource limits either of the system or of the testing account
159 have been reached.  Error message "Operating would block" is
160 usually indicative of this situation.  The error message was now:
161 "$!"
162
163 You can check the message queues with the 'ipcs' command and
164 you can remove unneeded queues with the 'ipcrm -q id' command.
165 You may also consider configuring your system or account
166 to have more message queue resources.
167
168 Because of the subtest #2 failing also the substests #5 and #6 will
169 very probably also fail.
170 EOM
171   }
172
173   my $data = '';
174   ok(msgctl($msg, IPC_STAT, $data), 'msgctl IPC_STAT call');
175
176   cmp_ok(length($data), '>', 0, 'msgctl IPC_STAT data');
177
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);
190 This failure was to be expected because the subtest #2 failed.
191 EOM
192   }
193
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) {
208     print <<EOM;
209 This failure was to be expected because the subtest #2 failed.
210 EOM
211   }
212 }
213
214 my $sem;
215
216 SKIP: {
217   skip('lacking d_semget d_semctl', 11) unless
218       $Config{'d_semget'} eq 'define' &&
219       $Config{'d_semctl'} eq 'define';
220
221   use IPC::SysV qw(IPC_CREAT GETALL SETALL);
222
223   # FreeBSD's default limit seems to be 9
224   my $nsem = 5;
225
226   $sem = catchsig(sub { semget(IPC_PRIVATE, $nsem, $perm | IPC_CREAT) });
227
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   }
232
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');
241
242   $data = "";
243   ok(semctl($sem, 0, GETALL, $data), 'get all sems');
244
245   is(length($data), length(pack("s$N*", (0) x $nsem)), 'right length');
246
247   my @data = unpack("s$N*", $data);
248
249   my $adata = "0" x $nsem;
250
251   is(scalar(@data), $nsem, 'right amount');
252   cmp_ok(join("", @data), 'eq', $adata, 'right data');
253
254   my $poke = 2;
255
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
268 SKIP: {
269   skip('lacking d_shm', 10) unless
270       $Config{'d_shm'} eq 'define';
271
272   use IPC::SysV qw(shmat shmdt memread memwrite ftok);
273
274   my $shm = catchsig(sub { shmget(IPC_PRIVATE, 4, S_IRWXU) });
275
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   }
280
281   pass("shm acquire");
282
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   is(shmat(-1, undef, 0), undef, 'shmat illegal id fails');
302
303   ok(defined shmdt($addr), 'shmdt');
304 }
305
306 SKIP: {
307   skip('lacking d_shm', 11) unless
308       $Config{'d_shm'} eq 'define';
309
310   use IPC::SysV qw(ftok);
311
312   my $key1i = ftok($0);
313   my $key1e = ftok($0, 1);
314
315   ok(defined $key1i, 'ftok implicit project id');
316   ok(defined $key1e, 'ftok explicit project id');
317   is($key1i, $key1e, 'keys match');
318
319   my $keyAsym = ftok($0, 'A');
320   my $keyAnum = ftok($0, ord('A'));
321
322   ok(defined $keyAsym, 'ftok symbolic project id');
323   ok(defined $keyAnum, 'ftok numeric project id');
324   is($keyAsym, $keyAnum, 'keys match');
325
326   my $two = '2';
327   my $key1 = ftok($0, 2);
328   my $key2 = ftok($0, ord('2'));
329   my $key3 = ftok($0, $two);
330   my $key4 = ftok($0, int($two));
331
332   is($key1, $key4, 'keys match');
333   isnt($key1, $key2, 'keys do not match');
334   is($key2, $key3, 'keys match');
335
336   eval { my $foo = ftok($0, 'AA') };
337   ok(index($@, 'invalid project id') >= 0, 'ftok error');
338
339   eval { my $foo = ftok($0, 3.14159) };
340   ok(index($@, 'invalid project id') >= 0, 'ftok error');
341 }
342
343 END {
344   msgctl($msg, IPC_RMID, 0)    if defined $msg;
345   semctl($sem, 0, IPC_RMID, 0) if defined $sem;
346 }