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
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 => 38);
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   ok(defined shmdt($addr), 'shmdt');
302 }
303
304 SKIP: {
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 }
340
341 END {
342   msgctl($msg, IPC_RMID, 0)    if defined $msg;
343   semctl($sem, 0, IPC_RMID, 0) if defined $sem;
344 }