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