contrib/perl5/t/lib/ipc_sysv.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5
   6     @INC = '../lib';
   7
   8     require Config; import Config;
   9
  10     unless ($Config{'d_msg'} eq 'define' &&
  11             $Config{'d_sem'} eq 'define') {
  12         print "1..0\n";
  13         exit;
  14     }
  15 }
  16
  17 # These constants are common to all tests.
  18 # Later the sem* tests will import more for themselves.
  19
  20 use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID
  21                  S_IRWXU S_IRWXG S_IRWXO);
  22 use strict;
  23
  24 print "1..16\n";
  25
  26 my $msg;
  27 my $sem;
  28
  29 $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
  30
  31 # FreeBSD is known to throw this if there's no SysV IPC in the kernel.
  32 $SIG{SYS} = sub {
  33     print STDERR <<EOM;
  34 SIGSYS caught.
  35 It may be that your kernel does not have SysV IPC configured.
  36
  37 EOM
  38     if ($^O eq 'freebsd') {
  39         print STDERR <<EOM;
  40 You must have following options in your kernel:
  41
  42 options         SYSVSHM
  43 options         SYSVSEM
  44 options         SYSVMSG
  45
  46 See config(8).
  47 EOM
  48     }
  49     exit(1);
  50 };
  51
  52 if ($Config{'d_msgget'} eq 'define' &&
  53     $Config{'d_msgctl'} eq 'define' &&
  54     $Config{'d_msgsnd'} eq 'define' &&
  55     $Config{'d_msgrcv'} eq 'define') {
  56     $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
  57     # Very first time called after machine is booted value may be 0
  58     die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
  59
  60     print "ok 1\n";
  61
  62     #Putting a message on the queue
  63     my $msgtype = 1;
  64     my $msgtext = "hello";
  65
  66     msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not ";
  67     print "ok 2\n";
  68
  69     my $data;
  70     msgctl($msg,IPC_STAT,$data) or print "not ";
  71     print "ok 3\n";
  72
  73     print "not " unless length($data);
  74     print "ok 4\n";
  75
  76     my $msgbuf;
  77     msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not ";
  78     print "ok 5\n";
  79
  80     my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf);
  81
  82     print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext);
  83     print "ok 6\n";
  84 } else {
  85     for (1..6) {
  86         print "ok $_\n"; # fake it
  87     }
  88 }
  89
  90 if($Config{'d_semget'} eq 'define' &&
  91    $Config{'d_semctl'} eq 'define') {
  92
  93     use IPC::SysV qw(IPC_CREAT GETALL SETALL);
  94
  95     $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
  96     # Very first time called after machine is booted value may be 0
  97     die "semget: $!\n" unless defined($sem) && $sem >= 0;
  98
  99     print "ok 7\n";
 100
 101     my $data;
 102     semctl($sem,0,IPC_STAT,$data) or print "not ";
 103     print "ok 8\n";
 104
 105     print "not " unless length($data);
 106     print "ok 9\n";
 107
 108     my $template;
 109
 110     # Find the pack/unpack template capable of handling native C shorts.
 111
 112     if      ($Config{shortsize} == 2) {
 113         $template = "s";
 114     } elsif ($Config{shortsize} == 4) {
 115         $template = "l";
 116     } elsif ($Config{shortsize} == 8) {
 117         # Try quad last because not supported everywhere.
 118         foreach my $t (qw(i q)) {
 119             # We could trap the unsupported quad template with eval
 120             # but if we get this far we should have quad support anyway.
 121             if (length(pack($t, 0)) == 8) {
 122                 $template = $t;
 123                 last;
 124             }
 125         }
 126     }
 127
 128     die "$0: cannot pack native shorts\n" unless defined $template;
 129
 130     $template .= "*";
 131
 132     my $nsem = 10;
 133
 134     semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not ";
 135     print "ok 10\n";
 136
 137     $data = "";
 138     semctl($sem,0,GETALL,$data) or print "not ";
 139     print "ok 11\n";
 140
 141     print "not " unless length($data) == length(pack($template,(0) x $nsem));
 142     print "ok 12\n";
 143
 144     my @data = unpack($template,$data);
 145
 146     my $adata = "0" x $nsem;
 147
 148     print "not " unless @data == $nsem and join("",@data) eq $adata;
 149     print "ok 13\n";
 150
 151     my $poke = 2;
 152
 153     $data[$poke] = 1;
 154     semctl($sem,0,SETALL,pack($template,@data)) or print "not ";
 155     print "ok 14\n";
 156
 157     $data = "";
 158     semctl($sem,0,GETALL,$data) or print "not ";
 159     print "ok 15\n";
 160
 161     @data = unpack($template,$data);
 162
 163     my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
 164
 165     print "not " unless join("",@data) eq $bdata;
 166     print "ok 16\n";
 167 } else {
 168     for (7..16) {
 169         print "ok $_\n"; # fake it
 170     }
 171 }
 172
 173 sub cleanup {
 174     msgctl($msg,IPC_RMID,0)       if defined $msg;
 175     semctl($sem,0,IPC_RMID,undef) if defined $sem;
 176 }
 177
 178 cleanup;