t/lib/ipc_sysv.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5
   6     unshift @INC, '../lib';
   7
   8     require Config; import Config;
   9
  10     my $reason;
  11
  12     if ($Config{'d_sem'} ne 'define') {
  13       $reason = '$Config{d_sem} undefined';
  14     } elsif ($Config{'d_msg'} ne 'define') {
  15       $reason = '$Config{d_msg} undefined';
  16     }
  17     if ($reason) {
  18         print "1..0 # Skip: $reason\n";
  19         exit 0;
  20     }
  21 }
  22
  23 # These constants are common to all tests.
  24 # Later the sem* tests will import more for themselves.
  25
  26 use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
  27 use strict;
  28
  29 print "1..16\n";
  30
  31 my $msg;
  32 my $sem;
  33
  34 $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
  35
  36 # FreeBSD is known to throw this if there's no SysV IPC in the kernel.
  37 $SIG{SYS} = sub {
  38     print STDERR <<EOM;
  39 SIGSYS caught.
  40 It may be that your kernel does not have SysV IPC configured.
  41
  42 EOM
  43     if ($^O eq 'freebsd') {
  44         print STDERR <<EOM;
  45 You must have following options in your kernel:
  46
  47 options         SYSVSHM
  48 options         SYSVSEM
  49 options         SYSVMSG
  50
  51 See config(8).
  52 EOM
  53     }
  54     exit(1);
  55 };
  56
  57 my $perm = S_IRWXU;
  58
  59 if ($Config{'d_msgget'} eq 'define' &&
  60     $Config{'d_msgctl'} eq 'define' &&
  61     $Config{'d_msgsnd'} eq 'define' &&
  62     $Config{'d_msgrcv'} eq 'define') {
  63
  64     $msg = msgget(IPC_PRIVATE, $perm);
  65     # Very first time called after machine is booted value may be 0
  66     die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
  67
  68     print "ok 1\n";
  69
  70     #Putting a message on the queue
  71     my $msgtype = 1;
  72     my $msgtext = "hello";
  73
  74     my $test2bad;
  75     my $test5bad;
  76     my $test6bad;
  77
  78     unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
  79         print "not ";
  80         $test2bad = 1;
  81     }
  82     print "ok 2\n";
  83     if ($test2bad) {
  84         print <<EOM;
  85 #
  86 # The failure of the subtest #2 may indicate that the message queue
  87 # resource limits either of the system or of the testing account
  88 # have been reached.  Error message "Operating would block" is
  89 # usually indicative of this situation.  The error message was now:
  90 # "$!"
  91 #
  92 # You can check the message queues with the 'ipcs' command and
  93 # you can remove unneeded queues with the 'ipcrm -q id' command.
  94 # You may also consider configuring your system or account
  95 # to have more message queue resources.
  96 #
  97 # Because of the subtest #2 failing also the substests #5 and #6 will
  98 # very probably also fail.
  99 #
 100 EOM
 101     }
 102
 103     my $data;
 104     msgctl($msg,IPC_STAT,$data) or print "not ";
 105     print "ok 3\n";
 106
 107     print "not " unless length($data);
 108     print "ok 4\n";
 109
 110     my $msgbuf;
 111     unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
 112         print "not ";
 113         $test5bad = 1;
 114     }
 115     print "ok 5\n";
 116     if ($test5bad && $test2bad) {
 117         print <<EOM;
 118 #
 119 # This failure was to be expected because the subtest #2 failed.
 120 #
 121 EOM
 122     }
 123
 124     my($rmsgtype,$rmsgtext);
 125     ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf);
 126     unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
 127         print "not ";
 128         $test6bad = 1;
 129     }
 130     print "ok 6\n";
 131     if ($test6bad && $test2bad) {
 132         print <<EOM;
 133 #
 134 # This failure was to be expected because the subtest #2 failed.
 135 #
 136 EOM
 137      }
 138 } else {
 139     for (1..6) {
 140         print "ok $_\n"; # fake it
 141     }
 142 }
 143
 144 if($Config{'d_semget'} eq 'define' &&
 145    $Config{'d_semctl'} eq 'define') {
 146
 147     if ($Config{'d_semctl_semid_ds'} eq 'define' ||
 148         $Config{'d_semctl_semun'}    eq 'define') {
 149
 150         use IPC::SysV qw(IPC_CREAT GETALL SETALL);
 151
 152         $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
 153         # Very first time called after machine is booted value may be 0
 154         die "semget: $!\n" unless defined($sem) && $sem >= 0;
 155
 156         print "ok 7\n";
 157
 158         my $data;
 159         semctl($sem,0,IPC_STAT,$data) or print "not ";
 160         print "ok 8\n";
 161
 162         print "not " unless length($data);
 163         print "ok 9\n";
 164
 165         my $nsem = 10;
 166
 167         semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
 168         print "ok 10\n";
 169
 170         $data = "";
 171         semctl($sem,0,GETALL,$data) or print "not ";
 172         print "ok 11\n";
 173
 174         print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
 175         print "ok 12\n";
 176
 177         my @data = unpack("s!*",$data);
 178
 179         my $adata = "0" x $nsem;
 180
 181         print "not " unless @data == $nsem and join("",@data) eq $adata;
 182         print "ok 13\n";
 183
 184         my $poke = 2;
 185
 186         $data[$poke] = 1;
 187         semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
 188         print "ok 14\n";
 189
 190         $data = "";
 191         semctl($sem,0,GETALL,$data) or print "not ";
 192         print "ok 15\n";
 193
 194         @data = unpack("s!*",$data);
 195
 196         my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
 197
 198         print "not " unless join("",@data) eq $bdata;
 199         print "ok 16\n";
 200     } else {
 201         for (7..16) {
 202             print "ok $_ # skipped, no semctl possible\n";
 203         }
 204     }
 205 } else {
 206     for (7..16) {
 207         print "ok $_\n"; # fake it
 208     }
 209 }
 210
 211 sub cleanup {
 212     msgctl($msg,IPC_RMID,0)       if defined $msg;
 213     semctl($sem,0,IPC_RMID,undef) if defined $sem;
 214 }
 215
 216 cleanup;