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