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_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 A class providing an object based interface to SysV IPC semaphores.
 176
 177 =head1 METHODS
 178
 179 =over 4
 180
 181 =item new ( KEY , NSEMS , FLAGS )
 182
 183 Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number
 184 of semaphores in the set. A new set is created if
 185
 186 =over 4
 187
 188 =item *
 189
 190 C<KEY> is equal to C<IPC_PRIVATE>
 191
 192 =item *
 193
 194 C<KEY> does not already  have  a  semaphore  identifier
 195 associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
 196
 197 =back
 198
 199 On creation of a new semaphore set C<FLAGS> is used to set the
 200 permissions.
 201
 202 =item getall
 203
 204 Returns the values of the semaphore set as an array.
 205
 206 =item getncnt ( SEM )
 207
 208 Returns the number of processes waiting for the semaphore C<SEM> to
 209 become greater than its current value
 210
 211 =item getpid ( SEM )
 212
 213 Returns the process id of the last process that performed an operation
 214 on the semaphore C<SEM>.
 215
 216 =item getval ( SEM )
 217
 218 Returns the current value of the semaphore C<SEM>.
 219
 220 =item getzcnt ( SEM )
 221
 222 Returns the number of processes waiting for the semaphore C<SEM> to
 223 become zero.
 224
 225 =item id
 226
 227 Returns the system identifier for the semaphore set.
 228
 229 =item op ( OPLIST )
 230
 231 C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is
 232 a concatenation of smaller lists, each which has three values. The
 233 first is the semaphore number, the second is the operation and the last
 234 is a flags value. See L<semop> for more details. For example
 235
 236     $sem->op(
 237         0, -1, IPC_NOWAIT,
 238         1,  1, IPC_NOWAIT
 239     );
 240
 241 =item remove
 242
 243 Remove and destroy the semaphore set from the system.
 244
 245 =item set ( STAT )
 246
 247 =item set ( NAME => VALUE [, NAME => VALUE ...] )
 248
 249 C<set> will set the following values of the C<stat> structure associated
 250 with the semaphore set.
 251
 252     uid
 253     gid
 254     mode (only the permission bits)
 255
 256 C<set> accepts either a stat object, as returned by the C<stat> method,
 257 or a list of I<name>-I<value> pairs.
 258
 259 =item setall ( VALUES )
 260
 261 Sets all values in the semaphore set to those given on the C<VALUES> list.
 262 C<VALUES> must contain the correct number of values.
 263
 264 =item setval ( N , VALUE )
 265
 266 Set the C<N>th value in the semaphore set to C<VALUE>
 267
 268 =item stat
 269
 270 Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of
 271 C<Class::Struct>. It provides the following fields. For a description
 272 of these fields see your system documentation.
 273
 274     uid
 275     gid
 276     cuid
 277     cgid
 278     mode
 279     ctime
 280     otime
 281     nsems
 282
 283 =back
 284
 285 =head1 SEE ALSO
 286
 287 L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop>
 288
 289 =head1 AUTHOR
 290
 291 Graham Barr <gbarr@pobox.com>
 292
 293 =head1 COPYRIGHT
 294
 295 Copyright (c) 1997 Graham Barr. All rights reserved.
 296 This program is free software; you can redistribute it and/or modify it
 297 under the same terms as Perl itself.
 298
 299 =cut