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