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