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