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 11BEGIN { 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 20if ($Config{'d_sem'} ne 'define') { 21 plan(skip_all => '$Config{d_sem} undefined'); 22} 23elsif ($Config{'d_msg'} ne 'define') { 24 plan(skip_all => '$Config{d_msg} undefined'); 25} 26 27plan(tests => 39); 28 29# These constants are common to all tests. 30# Later the sem* tests will import more for themselves. 31 32use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU); 33use 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 45It may be that the cygserver service isn't running. 46 47EOM 48 49 diag(<<EOM) unless exists $ENV{CYGWIN} && $ENV{CYGWIN} eq 'server'; 50You also may have to set the CYGWIN environment variable 51to 'server' before running the test suite: 52 53 export CYGWIN=server 54 55EOM 56 } 57 else { 58 diag(<<EOM); 59 60It may be that your kernel does not have SysV IPC configured. 61 62EOM 63 64 diag(<<EOM) if $^O eq 'freebsd'; 65You must have following options in your kernel: 66 67options SYSVSHM 68options SYSVSEM 69options SYSVMSG 70 71See config(8). 72 73EOM 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. 110if (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 118my $msg; 119 120my $perm = S_IRWXU; 121my $test_name; 122my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; 123 124SKIP: { 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); 157The failure of the subtest #2 may indicate that the message queue 158resource limits either of the system or of the testing account 159have been reached. Error message "Operating would block" is 160usually indicative of this situation. The error message was now: 161"$!" 162 163You can check the message queues with the 'ipcs' command and 164you can remove unneeded queues with the 'ipcrm -q id' command. 165You may also consider configuring your system or account 166to have more message queue resources. 167 168Because of the subtest #2 failing also the substests #5 and #6 will 169very probably also fail. 170EOM 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); 190This failure was to be expected because the subtest #2 failed. 191EOM 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; 209This failure was to be expected because the subtest #2 failed. 210EOM 211 } 212} 213 214my $sem; 215 216SKIP: { 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 268SKIP: { 269 skip('lacking d_shm', 11) 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', $!), 11); 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 306SKIP: { 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 343END { 344 msgctl($msg, IPC_RMID, 0) if defined $msg; 345 semctl($sem, 0, IPC_RMID, 0) if defined $sem; 346} 347