[Summary view] [Print] [Text view]

   1  # IPC::Semaphore
   2  #
   3  # Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
   4  # This program is free software; you can redistribute it and/or
   5  # modify it under the same terms as Perl itself.
   6  
   7  package IPC::Semaphore;
   8  
   9  use IPC::SysV qw(GETNCNT GETZCNT GETVAL SETVAL GETPID GETALL SETALL
  10           IPC_STAT IPC_SET IPC_RMID);
  11  use strict;
  12  use vars qw($VERSION);
  13  use Carp;
  14  
  15  $VERSION = "1.02";
  16  $VERSION = eval $VERSION;
  17  
  18  {
  19      package IPC::Semaphore::stat;
  20  
  21      use Class::Struct qw(struct);
  22  
  23      struct 'IPC::Semaphore::stat' => [
  24      uid    => '$',
  25      gid    => '$',
  26      cuid    => '$',
  27      cgid    => '$',
  28      mode    => '$',
  29      ctime    => '$',
  30      otime    => '$',
  31      nsems    => '$',
  32      ];
  33  }
  34  
  35  sub new {
  36      @_ == 4 || croak 'new ' . __PACKAGE__ . '( KEY, NSEMS, FLAGS )';
  37      my $class = shift;
  38  
  39      my $id = semget($_[0],$_[1],$_[2]);
  40  
  41      defined($id)
  42      ? bless \$id, $class
  43      : undef;
  44  }
  45  
  46  sub id {
  47      my $self = shift;
  48      $$self;
  49  }
  50  
  51  sub remove {
  52      my $self = shift;
  53      (semctl($$self,0,IPC_RMID,0), undef $$self)[0];
  54  }
  55  
  56  sub getncnt {
  57      @_ == 2 || croak '$sem->getncnt( SEM )';
  58      my $self = shift;
  59      my $sem = shift;
  60      my $v = semctl($$self,$sem,GETNCNT,0);
  61      $v ? 0 + $v : undef;
  62  }
  63  
  64  sub getzcnt {
  65      @_ == 2 || croak '$sem->getzcnt( SEM )';
  66      my $self = shift;
  67      my $sem = shift;
  68      my $v = semctl($$self,$sem,GETZCNT,0);
  69      $v ? 0 + $v : undef;
  70  }
  71  
  72  sub getval {
  73      @_ == 2 || croak '$sem->getval( SEM )';
  74      my $self = shift;
  75      my $sem = shift;
  76      my $v = semctl($$self,$sem,GETVAL,0);
  77      $v ? 0 + $v : undef;
  78  }
  79  
  80  sub getpid {
  81      @_ == 2 || croak '$sem->getpid( SEM )';
  82      my $self = shift;
  83      my $sem = shift;
  84      my $v = semctl($$self,$sem,GETPID,0);
  85      $v ? 0 + $v : undef;
  86  }
  87  
  88  sub op {
  89      @_ >= 4 || croak '$sem->op( OPLIST )';
  90      my $self = shift;
  91      croak 'Bad arg count' if @_ % 3;
  92      my $data = pack("s!*",@_);
  93      semop($$self,$data);
  94  }
  95  
  96  sub stat {
  97      my $self = shift;
  98      my $data = "";
  99      semctl($$self,0,IPC_STAT,$data)
 100      or return undef;
 101      IPC::Semaphore::stat->new->unpack($data);
 102  }
 103  
 104  sub set {
 105      my $self = shift;
 106      my $ds;
 107  
 108      if(@_ == 1) {
 109      $ds = shift;
 110      }
 111      else {
 112      croak 'Bad arg count' if @_ % 2;
 113      my %arg = @_;
 114      $ds = $self->stat
 115          or return undef;
 116      my($key,$val);
 117      $ds->$key($val)
 118          while(($key,$val) = each %arg);
 119      }
 120  
 121      my $v = semctl($$self,0,IPC_SET,$ds->pack);
 122      $v ? 0 + $v : undef;
 123  }
 124  
 125  sub getall {
 126      my $self = shift;
 127      my $data = "";
 128      semctl($$self,0,GETALL,$data)
 129      or return ();
 130      (unpack("s!*",$data));
 131  }
 132  
 133  sub setall {
 134      my $self = shift;
 135      my $data = pack("s!*",@_);
 136      semctl($$self,0,SETALL,$data);
 137  }
 138  
 139  sub setval {
 140      @_ == 3 || croak '$sem->setval( SEM, VAL )';
 141      my $self = shift;
 142      my $sem = shift;
 143      my $val = shift;
 144      semctl($$self,$sem,SETVAL,$val);
 145  }
 146  
 147  1;
 148  
 149  __END__
 150  
 151  =head1 NAME
 152  
 153  IPC::Semaphore - SysV Semaphore IPC object class
 154  
 155  =head1 SYNOPSIS
 156  
 157      use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR IPC_CREAT);
 158      use IPC::Semaphore;
 159  
 160      $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRUSR | S_IWUSR | IPC_CREAT);
 161  
 162      $sem->setall( (0) x 10);
 163  
 164      @sem = $sem->getall;
 165  
 166      $ncnt = $sem->getncnt;
 167  
 168      $zcnt = $sem->getzcnt;
 169  
 170      $ds = $sem->stat;
 171  
 172      $sem->remove;
 173  
 174  =head1 DESCRIPTION
 175  
 176  A class providing an object based interface to SysV IPC semaphores.
 177  
 178  =head1 METHODS
 179  
 180  =over 4
 181  
 182  =item new ( KEY , NSEMS , FLAGS )
 183  
 184  Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number
 185  of semaphores in the set. A new set is created if
 186  
 187  =over 4
 188  
 189  =item *
 190  
 191  C<KEY> is equal to C<IPC_PRIVATE>
 192  
 193  =item *
 194  
 195  C<KEY> does not already  have  a  semaphore  identifier
 196  associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
 197  
 198  =back
 199  
 200  On creation of a new semaphore set C<FLAGS> is used to set the
 201  permissions.  Be careful not to set any flags that the Sys V
 202  IPC implementation does not allow: in some systems setting
 203  execute bits makes the operations fail.
 204  
 205  =item getall
 206  
 207  Returns the values of the semaphore set as an array.
 208  
 209  =item getncnt ( SEM )
 210  
 211  Returns the number of processes waiting for the semaphore C<SEM> to
 212  become greater than its current value
 213  
 214  =item getpid ( SEM )
 215  
 216  Returns the process id of the last process that performed an operation
 217  on the semaphore C<SEM>.
 218  
 219  =item getval ( SEM )
 220  
 221  Returns the current value of the semaphore C<SEM>.
 222  
 223  =item getzcnt ( SEM )
 224  
 225  Returns the number of processes waiting for the semaphore C<SEM> to
 226  become zero.
 227  
 228  =item id
 229  
 230  Returns the system identifier for the semaphore set.
 231  
 232  =item op ( OPLIST )
 233  
 234  C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is
 235  a concatenation of smaller lists, each which has three values. The
 236  first is the semaphore number, the second is the operation and the last
 237  is a flags value. See L<semop> for more details. For example
 238  
 239      $sem->op(
 240      0, -1, IPC_NOWAIT,
 241      1,  1, IPC_NOWAIT
 242      );
 243  
 244  =item remove
 245  
 246  Remove and destroy the semaphore set from the system.
 247  
 248  =item set ( STAT )
 249  
 250  =item set ( NAME => VALUE [, NAME => VALUE ...] )
 251  
 252  C<set> will set the following values of the C<stat> structure associated
 253  with the semaphore set.
 254  
 255      uid
 256      gid
 257      mode (only the permission bits)
 258  
 259  C<set> accepts either a stat object, as returned by the C<stat> method,
 260  or a list of I<name>-I<value> pairs.
 261  
 262  =item setall ( VALUES )
 263  
 264  Sets all values in the semaphore set to those given on the C<VALUES> list.
 265  C<VALUES> must contain the correct number of values.
 266  
 267  =item setval ( N , VALUE )
 268  
 269  Set the C<N>th value in the semaphore set to C<VALUE>
 270  
 271  =item stat
 272  
 273  Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of
 274  C<Class::Struct>. It provides the following fields. For a description
 275  of these fields see your system documentation.
 276  
 277      uid
 278      gid
 279      cuid
 280      cgid
 281      mode
 282      ctime
 283      otime
 284      nsems
 285  
 286  =back
 287  
 288  =head1 SEE ALSO
 289  
 290  L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop> 
 291  
 292  =head1 AUTHOR
 293  
 294  Graham Barr <gbarr@pobox.com>
 295  
 296  =head1 COPYRIGHT
 297  
 298  Copyright (c) 1997 Graham Barr. All rights reserved.
 299  This program is free software; you can redistribute it and/or modify it
 300  under the same terms as Perl itself.
 301  
 302  =cut