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