t/op/ipcsem.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     $SIG{__DIE__} = 'cleanup';
   7 }
   8
   9 use Config;
  10
  11 BEGIN {
  12     unless($Config{'d_semget'} eq 'define' &&
  13            $Config{'d_semctl'} eq 'define') {
  14         print "1..0\n";
  15         exit;
  16     }
  17 }
  18
  19 use strict;
  20
  21 use IPC::SysV qw(IPC_PRIVATE IPC_CREAT IPC_STAT IPC_RMID
  22                  GETALL SETALL
  23                  S_IRWXU S_IRWXG S_IRWXO);
  24
  25 print "1..10\n";
  26
  27 my $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
  28 # Very first time called after machine is booted value may be 0
  29 die "semget: $!\n" unless defined($sem) && $sem >= 0;
  30
  31 print "ok 1\n";
  32
  33 my $data;
  34 semctl($sem,0,IPC_STAT,$data) or print "not ";
  35 print "ok 2\n";
  36
  37 print "not " unless length($data);
  38 print "ok 3\n";
  39
  40 my $template;
  41
  42 # Find the pack/unpack template capable of handling native C shorts.
  43
  44 if      ($Config{shortsize} == 2) {
  45     $template = "s";
  46 } elsif ($Config{shortsize} == 4) {
  47     $template = "l";
  48 } elsif ($Config{shortsize} == 8) {
  49     foreach my $t (qw(i q)) { # Try quad last because not supported everywhere.
  50         # We could trap the unsupported quad template with eval
  51         # but if we get this far we should have quad support anyway.
  52         if (length(pack($t, 0)) == 8) {
  53             $template = $t;
  54             last;
  55         }
  56     }
  57 }
  58
  59 die "$0: cannot pack native shorts\n" unless defined $template;
  60
  61 $template .= "*";
  62
  63 my $nsem = 10;
  64
  65 semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not ";
  66 print "ok 4\n";
  67
  68 $data = "";
  69 semctl($sem,0,GETALL,$data) or print "not ";
  70 print "ok 5\n";
  71
  72 print "not " unless length($data) == length(pack($template,(0) x $nsem));
  73 print "ok 6\n";
  74
  75 my @data = unpack($template,$data);
  76
  77 my $adata = "0" x $nsem;
  78
  79 print "not " unless @data == $nsem and join("",@data) eq $adata;
  80 print "ok 7\n";
  81
  82 my $poke = 2;
  83
  84 $data[$poke] = 1;
  85 semctl($sem,0,SETALL,pack($template,@data)) or print "not ";
  86 print "ok 8\n";
  87
  88 $data = "";
  89 semctl($sem,0,GETALL,$data) or print "not ";
  90 print "ok 9\n";
  91
  92 @data = unpack($template,$data);
  93
  94 my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
  95
  96 print "not " unless join("",@data) eq $bdata;
  97 print "ok 10\n";
  98
  99 sub cleanup { semctl($sem,0,IPC_RMID,undef) if defined $sem }
 100
 101 cleanup;