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