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