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 | |
76fbd8c4 |
15 | $VERSION = "1.00_00"; |
105cd853 |
16 | $VERSION = eval $VERSION; |
0ade1984 |
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; |
24342b83 |
92 | my $data = pack("s!*",@_); |
0ade1984 |
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 = @_; |
fcf3e904 |
114 | $ds = $self->stat |
0ade1984 |
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 (); |
24342b83 |
130 | (unpack("s!*",$data)); |
0ade1984 |
131 | } |
132 | |
133 | sub setall { |
134 | my $self = shift; |
24342b83 |
135 | my $data = pack("s!*",@_); |
0ade1984 |
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_IRWXU IPC_CREAT); |
158 | use IPC::Semaphore; |
3cb6de81 |
159 | |
0ade1984 |
160 | $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | IPC_CREAT); |
3cb6de81 |
161 | |
0ade1984 |
162 | $sem->setall( (0) x 10); |
3cb6de81 |
163 | |
0ade1984 |
164 | @sem = $sem->getall; |
3cb6de81 |
165 | |
0ade1984 |
166 | $ncnt = $sem->getncnt; |
3cb6de81 |
167 | |
0ade1984 |
168 | $zcnt = $sem->getzcnt; |
3cb6de81 |
169 | |
0ade1984 |
170 | $ds = $sem->stat; |
3cb6de81 |
171 | |
0ade1984 |
172 | $sem->remove; |
173 | |
174 | =head1 DESCRIPTION |
175 | |
bbc7dcd2 |
176 | A class providing an object based interface to SysV IPC semaphores. |
177 | |
0ade1984 |
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. |
202 | |
203 | =item getall |
204 | |
205 | Returns the values of the semaphore set as an array. |
206 | |
207 | =item getncnt ( SEM ) |
208 | |
dad0832b |
209 | Returns the number of processes waiting for the semaphore C<SEM> to |
022735b4 |
210 | become greater than its current value |
0ade1984 |
211 | |
212 | =item getpid ( SEM ) |
213 | |
214 | Returns the process id of the last process that performed an operation |
215 | on the semaphore C<SEM>. |
216 | |
217 | =item getval ( SEM ) |
218 | |
219 | Returns the current value of the semaphore C<SEM>. |
220 | |
221 | =item getzcnt ( SEM ) |
222 | |
dad0832b |
223 | Returns the number of processes waiting for the semaphore C<SEM> to |
0ade1984 |
224 | become zero. |
225 | |
226 | =item id |
227 | |
228 | Returns the system identifier for the semaphore set. |
229 | |
230 | =item op ( OPLIST ) |
231 | |
232 | C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is |
233 | a concatenation of smaller lists, each which has three values. The |
234 | first is the semaphore number, the second is the operation and the last |
235 | is a flags value. See L<semop> for more details. For example |
236 | |
237 | $sem->op( |
238 | 0, -1, IPC_NOWAIT, |
239 | 1, 1, IPC_NOWAIT |
240 | ); |
241 | |
242 | =item remove |
243 | |
244 | Remove and destroy the semaphore set from the system. |
245 | |
246 | =item set ( STAT ) |
247 | |
248 | =item set ( NAME => VALUE [, NAME => VALUE ...] ) |
249 | |
250 | C<set> will set the following values of the C<stat> structure associated |
251 | with the semaphore set. |
252 | |
253 | uid |
254 | gid |
dad0832b |
255 | mode (only the permission bits) |
0ade1984 |
256 | |
257 | C<set> accepts either a stat object, as returned by the C<stat> method, |
258 | or a list of I<name>-I<value> pairs. |
259 | |
260 | =item setall ( VALUES ) |
261 | |
262 | Sets all values in the semaphore set to those given on the C<VALUES> list. |
263 | C<VALUES> must contain the correct number of values. |
264 | |
265 | =item setval ( N , VALUE ) |
266 | |
267 | Set the C<N>th value in the semaphore set to C<VALUE> |
268 | |
269 | =item stat |
270 | |
271 | Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of |
272 | C<Class::Struct>. It provides the following fields. For a description |
dad0832b |
273 | of these fields see your system documentation. |
0ade1984 |
274 | |
275 | uid |
276 | gid |
277 | cuid |
278 | cgid |
279 | mode |
280 | ctime |
281 | otime |
282 | nsems |
283 | |
284 | =back |
285 | |
286 | =head1 SEE ALSO |
287 | |
288 | L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop> |
289 | |
290 | =head1 AUTHOR |
291 | |
292 | Graham Barr <gbarr@pobox.com> |
293 | |
294 | =head1 COPYRIGHT |
295 | |
296 | Copyright (c) 1997 Graham Barr. All rights reserved. |
297 | This program is free software; you can redistribute it and/or modify it |
298 | under the same terms as Perl itself. |
299 | |
300 | =cut |