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