contrib/perl5/ext/IPC/SysV/Semaphore.pm

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