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     msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not ";
  81     print "ok 2\n";
  82
  83     my $data;
  84     msgctl($msg,IPC_STAT,$data) or print "not ";
  85     print "ok 3\n";
  86
  87     print "not " unless length($data);
  88     print "ok 4\n";
  89
  90     my $msgbuf;
  91     msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not ";
  92     print "ok 5\n";
  93
  94     my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf);
  95
  96     print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext);
  97     print "ok 6\n";
  98 } else {
  99     for (1..6) {
 100         print "ok $_\n"; # fake it
 101     }
 102 }
 103
 104 if($Config{'d_semget'} eq 'define' &&
 105    $Config{'d_semctl'} eq 'define') {
 106
 107     if ($Config{'d_semctl_semid_ds'} eq 'define' ||
 108         $Config{'d_semctl_semun'}    eq 'define') {
 109
 110         use IPC::SysV qw(IPC_CREAT GETALL SETALL);
 111
 112         $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
 113         # Very first time called after machine is booted value may be 0
 114         die "semget: $!\n" unless defined($sem) && $sem >= 0;
 115
 116         print "ok 7\n";
 117
 118         my $data;
 119         semctl($sem,0,IPC_STAT,$data) or print "not ";
 120         print "ok 8\n";
 121
 122         print "not " unless length($data);
 123         print "ok 9\n";
 124
 125         my $nsem = 10;
 126
 127         semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
 128         print "ok 10\n";
 129
 130         $data = "";
 131         semctl($sem,0,GETALL,$data) or print "not ";
 132         print "ok 11\n";
 133
 134         print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
 135         print "ok 12\n";
 136
 137         my @data = unpack("s!*",$data);
 138
 139         my $adata = "0" x $nsem;
 140
 141         print "not " unless @data == $nsem and join("",@data) eq $adata;
 142         print "ok 13\n";
 143
 144         my $poke = 2;
 145
 146         $data[$poke] = 1;
 147         semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
 148         print "ok 14\n";
 149
 150         $data = "";
 151         semctl($sem,0,GETALL,$data) or print "not ";
 152         print "ok 15\n";
 153
 154         @data = unpack("s!*",$data);
 155
 156         my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
 157
 158         print "not " unless join("",@data) eq $bdata;
 159         print "ok 16\n";
 160     } else {
 161         for (7..16) {
 162             print "ok $_ # skipped, no semctl possible\n";
 163         }
 164     }
 165 } else {
 166     for (7..16) {
 167         print "ok $_\n"; # fake it
 168     }
 169 }
 170
 171 sub cleanup {
 172     msgctl($msg,IPC_RMID,0)       if defined $msg;
 173     semctl($sem,0,IPC_RMID,undef) if defined $sem;
 174 }
 175
 176 cleanup;