cpan/IPC-SysV/t/ipcsysv.t

   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
  17 BEGIN {
  18   if ($ENV{'PERL_CORE'}) {
  19     chdir 't' if -d 't';
  20     @INC = '../lib' if -d '../lib' && -d '../ext';
  21   }
  22
  23   require Test::More; import Test::More;
  24   require Config; import Config;
  25
  26   if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
  27     plan(skip_all => 'IPC::SysV was not built');
  28   }
  29 }
  30
  31 if ($Config{'d_sem'} ne 'define') {
  32   plan(skip_all => '$Config{d_sem} undefined');
  33 }
  34 elsif ($Config{'d_msg'} ne 'define') {
  35   plan(skip_all => '$Config{d_msg} undefined');
  36 }
  37
  38 plan(tests => 38);
  39
  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
  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);
  70
  71 It may be that your kernel does not have SysV IPC configured.
  72
  73 EOM
  74
  75       diag(<<EOM) if $^O eq 'freebsd';
  76 You must have following options in your kernel:
  77
  78 options         SYSVSHM
  79 options         SYSVSEM
  80 options         SYSVMSG
  81
  82 See config(8).
  83
  84 EOM
  85     }
  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";
 100     if ($why == &IPC::SysV::ENOSPC || $why == &IPC::SysV::ENOSYS ||
 101         $why == &IPC::SysV::ENOMEM || $why == &IPC::SysV::EACCES) {
 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();
 124     diag('Bail out! SIGSYS caught');
 125     exit(1);
 126   };
 127 }
 128
 129 my $msg;
 130
 131 my $perm = S_IRWXU;
 132 my $test_name;
 133 my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
 134
 135 SKIP: {
 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';
 141
 142   $msg = catchsig(sub { msgget(IPC_PRIVATE, $perm) });
 143
 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   }
 148
 149   pass('msgget IPC_PRIVATE S_IRWXU');
 150
 151   #Putting a message on the queue
 152   my $msgtype = 1;
 153   my $msgtext = "hello";
 154
 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);
 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.
 181 EOM
 182   }
 183
 184   my $data = '';
 185   ok(msgctl($msg, IPC_STAT, $data), 'msgctl IPC_STAT call');
 186
 187   cmp_ok(length($data), '>', 0, 'msgctl IPC_STAT data');
 188
 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);
 201 This failure was to be expected because the subtest #2 failed.
 202 EOM
 203   }
 204
 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) {
 219     print <<EOM;
 220 This failure was to be expected because the subtest #2 failed.
 221 EOM
 222   }
 223 }
 224
 225 my $sem;
 226
 227 SKIP: {
 228   skip('lacking d_semget d_semctl', 11) unless
 229       $Config{'d_semget'} eq 'define' &&
 230       $Config{'d_semctl'} eq 'define';
 231
 232   use IPC::SysV qw(IPC_CREAT GETALL SETALL);
 233
 234   # FreeBSD's default limit seems to be 9
 235   my $nsem = 5;
 236
 237   $sem = catchsig(sub { semget(IPC_PRIVATE, $nsem, $perm | IPC_CREAT) });
 238
 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   }
 243
 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');
 252
 253   $data = "";
 254   ok(semctl($sem, 0, GETALL, $data), 'get all sems');
 255
 256   is(length($data), length(pack("s$N*", (0) x $nsem)), 'right length');
 257
 258   my @data = unpack("s$N*", $data);
 259
 260   my $adata = "0" x $nsem;
 261
 262   is(scalar(@data), $nsem, 'right amount');
 263   cmp_ok(join("", @data), 'eq', $adata, 'right data');
 264
 265   my $poke = 2;
 266
 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';
 282
 283   use IPC::SysV qw(shmat shmdt memread memwrite ftok);
 284
 285   my $shm = catchsig(sub { shmget(IPC_PRIVATE, 4, S_IRWXU) });
 286
 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   }
 291
 292   pass("shm acquire");
 293
 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 }
 351
 352 END {
 353   msgctl($msg, IPC_RMID, 0)    if defined $msg;
 354   semctl($sem, 0, IPC_RMID, 0) if defined $sem;
 355 }