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