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