This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3bcbfe78ea55befca37243bb0b3a604bd17ffcd8
[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.04';
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     (semctl($$self,0,IPC_RMID,0), undef $$self)[0];
60 }
61
62 sub 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
70 sub 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
78 sub 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
86 sub 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
94 sub 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
102 sub 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
110 sub 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
131 sub getall {
132     my $self = shift;
133     my $data = "";
134     semctl($$self,0,GETALL,$data)
135         or return ();
136     (unpack("s$N*",$data));
137 }
138
139 sub setall {
140     my $self = shift;
141     my $data = pack("s$N*",@_);
142     semctl($$self,0,SETALL,$data);
143 }
144
145 sub 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
153 1;
154
155 __END__
156
157 =head1 NAME
158
159 IPC::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
182 A 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
190 Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number
191 of semaphores in the set. A new set is created if
192
193 =over 4
194
195 =item *
196
197 C<KEY> is equal to C<IPC_PRIVATE>
198
199 =item *
200
201 C<KEY> does not already have a semaphore identifier
202 associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
203
204 =back
205
206 On creation of a new semaphore set C<FLAGS> is used to set the
207 permissions.  Be careful not to set any flags that the Sys V
208 IPC implementation does not allow: in some systems setting
209 execute bits makes the operations fail.
210
211 =item getall
212
213 Returns the values of the semaphore set as an array.
214
215 =item getncnt ( SEM )
216
217 Returns the number of processes waiting for the semaphore C<SEM> to
218 become greater than its current value
219
220 =item getpid ( SEM )
221
222 Returns the process id of the last process that performed an operation
223 on the semaphore C<SEM>.
224
225 =item getval ( SEM )
226
227 Returns the current value of the semaphore C<SEM>.
228
229 =item getzcnt ( SEM )
230
231 Returns the number of processes waiting for the semaphore C<SEM> to
232 become zero.
233
234 =item id
235
236 Returns the system identifier for the semaphore set.
237
238 =item op ( OPLIST )
239
240 C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is
241 a concatenation of smaller lists, each which has three values. The
242 first is the semaphore number, the second is the operation and the last
243 is 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
252 Remove and destroy the semaphore set from the system.
253
254 =item set ( STAT )
255
256 =item set ( NAME => VALUE [, NAME => VALUE ...] )
257
258 C<set> will set the following values of the C<stat> structure associated
259 with the semaphore set.
260
261     uid
262     gid
263     mode (only the permission bits)
264
265 C<set> accepts either a stat object, as returned by the C<stat> method,
266 or a list of I<name>-I<value> pairs.
267
268 =item setall ( VALUES )
269
270 Sets all values in the semaphore set to those given on the C<VALUES> list.
271 C<VALUES> must contain the correct number of values.
272
273 =item setval ( N , VALUE )
274
275 Set the C<N>th value in the semaphore set to C<VALUE>
276
277 =item stat
278
279 Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of
280 C<Class::Struct>. It provides the following fields. For a description
281 of 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
296 L<IPC::SysV>, L<Class::Struct>, L<semget>, L<semctl>, L<semop> 
297
298 =head1 AUTHORS
299
300 Graham Barr <gbarr@pobox.com>,
301 Marcus Holland-Moritz <mhx@cpan.org>
302
303 =head1 COPYRIGHT
304
305 Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz.
306
307 Version 1.x, Copyright (c) 1997, Graham Barr.
308
309 This program is free software; you can redistribute it and/or
310 modify it under the same terms as Perl itself.
311
312 =cut