Commit | Line | Data |
---|---|---|
86530b38 AT |
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_00"; | |
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 | my $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_IRWXU IPC_CREAT); | |
158 | use IPC::Semaphore; | |
159 | ||
160 | $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | 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. | |
202 | ||
203 | =item getall | |
204 | ||
205 | Returns the values of the semaphore set as an array. | |
206 | ||
207 | =item getncnt ( SEM ) | |
208 | ||
209 | Returns the number of processes waiting for the semaphore C<SEM> to | |
210 | become greater than its current value | |
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 | ||
223 | Returns the number of processes waiting for the semaphore C<SEM> to | |
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 | |
255 | mode (only the permission bits) | |
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 | |
273 | of these fields see your system documentation. | |
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 |