| 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 |