cpan/IPC-SysV/lib/IPC/Semaphore.pm

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