This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update IPC-SysV to CPAN version 2.04
[perl5.git] / cpan / IPC-SysV / lib / IPC / Semaphore.pm
CommitLineData
8f85282b 1################################################################################
0ade1984 2#
dd0df890 3# Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>.
8f85282b
MHM
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################################################################################
0ade1984
JH
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
dd0df890 19$VERSION = '2.04';
0ade1984 20
8f85282b
MHM
21# Figure out if we have support for native sized types
22my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
23
0ade1984
JH
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;
8f85282b 98 my $data = pack("s$N*",@_);
0ade1984
JH
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 = @_;
fcf3e904 120 $ds = $self->stat
0ade1984
JH
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 ();
8f85282b 136 (unpack("s$N*",$data));
0ade1984
JH
137}
138
139sub setall {
140 my $self = shift;
8f85282b 141 my $data = pack("s$N*",@_);
0ade1984
JH
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
7b34eba2 163 use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR IPC_CREAT);
0ade1984 164 use IPC::Semaphore;
3cb6de81 165
8f85282b 166 $sem = IPC::Semaphore->new(IPC_PRIVATE, 10, S_IRUSR | S_IWUSR | IPC_CREAT);
3cb6de81 167
0ade1984 168 $sem->setall( (0) x 10);
3cb6de81 169
0ade1984 170 @sem = $sem->getall;
3cb6de81 171
0ade1984 172 $ncnt = $sem->getncnt;
3cb6de81 173
0ade1984 174 $zcnt = $sem->getzcnt;
3cb6de81 175
0ade1984 176 $ds = $sem->stat;
3cb6de81 177
0ade1984
JH
178 $sem->remove;
179
180=head1 DESCRIPTION
181
bbc7dcd2
MS
182A class providing an object based interface to SysV IPC semaphores.
183
0ade1984
JH
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
8f85282b 201C<KEY> does not already have a semaphore identifier
0ade1984
JH
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
7b34eba2
JH
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.
0ade1984
JH
210
211=item getall
212
213Returns the values of the semaphore set as an array.
214
215=item getncnt ( SEM )
216
dad0832b 217Returns the number of processes waiting for the semaphore C<SEM> to
022735b4 218become greater than its current value
0ade1984
JH
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
dad0832b 231Returns the number of processes waiting for the semaphore C<SEM> to
0ade1984
JH
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
dad0832b 263 mode (only the permission bits)
0ade1984
JH
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
dad0832b 281of these fields see your system documentation.
0ade1984
JH
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
8f85282b 296L<IPC::SysV>, L<Class::Struct>, L<semget>, L<semctl>, L<semop>
0ade1984 297
8f85282b 298=head1 AUTHORS
0ade1984 299
8f85282b
MHM
300Graham Barr <gbarr@pobox.com>,
301Marcus Holland-Moritz <mhx@cpan.org>
0ade1984
JH
302
303=head1 COPYRIGHT
304
dd0df890 305Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz.
8f85282b
MHM
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.
0ade1984
JH
311
312=cut