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   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
  26 if ($Config{'d_sem'} ne 'define') {
  27   plan(skip_all => '$Config{d_sem} undefined');
  28 }
  29 elsif ($Config{'d_msg'} ne 'define') {
  30   plan(skip_all => '$Config{d_msg} undefined');
  31 }
  32
  33 plan(tests => 38);
  34
  35 # These constants are common to all tests.
  36 # Later the sem* tests will import more for themselves.
  37
  38 use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
  39 use 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
  51 It may be that the cygserver service isn't running.
  52
  53 EOM
  54
  55       diag(<<EOM) unless exists $ENV{CYGWIN} && $ENV{CYGWIN} eq 'server';
  56 You also may have to set the CYGWIN environment variable
  57 to 'server' before running the test suite:
  58
  59   export CYGWIN=server
  60
  61 EOM
  62     }
  63     else {
  64       diag(<<EOM);
  65
  66 It may be that your kernel does not have SysV IPC configured.
  67
  68 EOM
  69
  70       diag(<<EOM) if $^O eq 'freebsd';
  71 You must have following options in your kernel:
  72
  73 options         SYSVSHM
  74 options         SYSVSEM
  75 options         SYSVMSG
  76
  77 See config(8).
  78
  79 EOM
  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.
 116 if (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
 124 my $msg;
 125
 126 my $perm = S_IRWXU;
 127 my $test_name;
 128 my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
 129
 130 SKIP: {
 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);
 163 The failure of the subtest #2 may indicate that the message queue
 164 resource limits either of the system or of the testing account
 165 have been reached.  Error message "Operating would block" is
 166 usually indicative of this situation.  The error message was now:
 167 "$!"
 168
 169 You can check the message queues with the 'ipcs' command and
 170 you can remove unneeded queues with the 'ipcrm -q id' command.
 171 You may also consider configuring your system or account
 172 to have more message queue resources.
 173
 174 Because of the subtest #2 failing also the substests #5 and #6 will
 175 very probably also fail.
 176 EOM
 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);
 196 This failure was to be expected because the subtest #2 failed.
 197 EOM
 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;
 215 This failure was to be expected because the subtest #2 failed.
 216 EOM
 217   }
 218 }
 219
 220 my $sem;
 221
 222 SKIP: {
 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
 274 SKIP: {
 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
 310 SKIP: {
 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
 347 END {
 348   msgctl($msg, IPC_RMID, 0)    if defined $msg;
 349   semctl($sem, 0, IPC_RMID, 0) if defined $sem;
 350 }