Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | # IO::Select.pm |
2 | # | |
3 | # Copyright (c) 1997-8 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 IO::Select; | |
8 | ||
9 | use strict; | |
10 | use warnings::register; | |
11 | use vars qw($VERSION @ISA); | |
12 | require Exporter; | |
13 | ||
14 | $VERSION = "1.17"; | |
15 | ||
16 | @ISA = qw(Exporter); # This is only so we can do version checking | |
17 | ||
18 | sub VEC_BITS () {0} | |
19 | sub FD_COUNT () {1} | |
20 | sub FIRST_FD () {2} | |
21 | ||
22 | sub new | |
23 | { | |
24 | my $self = shift; | |
25 | my $type = ref($self) || $self; | |
26 | ||
27 | my $vec = bless [undef,0], $type; | |
28 | ||
29 | $vec->add(@_) | |
30 | if @_; | |
31 | ||
32 | $vec; | |
33 | } | |
34 | ||
35 | sub add | |
36 | { | |
37 | shift->_update('add', @_); | |
38 | } | |
39 | ||
40 | ||
41 | sub remove | |
42 | { | |
43 | shift->_update('remove', @_); | |
44 | } | |
45 | ||
46 | ||
47 | sub exists | |
48 | { | |
49 | my $vec = shift; | |
50 | my $fno = $vec->_fileno(shift); | |
51 | return undef unless defined $fno; | |
52 | $vec->[$fno + FIRST_FD]; | |
53 | } | |
54 | ||
55 | ||
56 | sub _fileno | |
57 | { | |
58 | my($self, $f) = @_; | |
59 | return unless defined $f; | |
60 | $f = $f->[0] if ref($f) eq 'ARRAY'; | |
61 | ($f =~ /^\d+$/) ? $f : fileno($f); | |
62 | } | |
63 | ||
64 | sub _update | |
65 | { | |
66 | my $vec = shift; | |
67 | my $add = shift eq 'add'; | |
68 | ||
69 | my $bits = $vec->[VEC_BITS]; | |
70 | $bits = '' unless defined $bits; | |
71 | ||
72 | my $count = 0; | |
73 | my $f; | |
74 | foreach $f (@_) | |
75 | { | |
76 | my $fn = $vec->_fileno($f); | |
77 | next unless defined $fn; | |
78 | my $i = $fn + FIRST_FD; | |
79 | if ($add) { | |
80 | if (defined $vec->[$i]) { | |
81 | $vec->[$i] = $f; # if array rest might be different, so we update | |
82 | next; | |
83 | } | |
84 | $vec->[FD_COUNT]++; | |
85 | vec($bits, $fn, 1) = 1; | |
86 | $vec->[$i] = $f; | |
87 | } else { # remove | |
88 | next unless defined $vec->[$i]; | |
89 | $vec->[FD_COUNT]--; | |
90 | vec($bits, $fn, 1) = 0; | |
91 | $vec->[$i] = undef; | |
92 | } | |
93 | $count++; | |
94 | } | |
95 | $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; | |
96 | $count; | |
97 | } | |
98 | ||
99 | sub can_read | |
100 | { | |
101 | my $vec = shift; | |
102 | my $timeout = shift; | |
103 | my $r = $vec->[VEC_BITS]; | |
104 | ||
105 | defined($r) && (select($r,undef,undef,$timeout) > 0) | |
106 | ? handles($vec, $r) | |
107 | : (); | |
108 | } | |
109 | ||
110 | sub can_write | |
111 | { | |
112 | my $vec = shift; | |
113 | my $timeout = shift; | |
114 | my $w = $vec->[VEC_BITS]; | |
115 | ||
116 | defined($w) && (select(undef,$w,undef,$timeout) > 0) | |
117 | ? handles($vec, $w) | |
118 | : (); | |
119 | } | |
120 | ||
121 | sub has_exception | |
122 | { | |
123 | my $vec = shift; | |
124 | my $timeout = shift; | |
125 | my $e = $vec->[VEC_BITS]; | |
126 | ||
127 | defined($e) && (select(undef,undef,$e,$timeout) > 0) | |
128 | ? handles($vec, $e) | |
129 | : (); | |
130 | } | |
131 | ||
132 | sub has_error | |
133 | { | |
134 | warnings::warn("Call to deprecated method 'has_error', use 'has_exception'") | |
135 | if warnings::enabled(); | |
136 | goto &has_exception; | |
137 | } | |
138 | ||
139 | sub count | |
140 | { | |
141 | my $vec = shift; | |
142 | $vec->[FD_COUNT]; | |
143 | } | |
144 | ||
145 | sub bits | |
146 | { | |
147 | my $vec = shift; | |
148 | $vec->[VEC_BITS]; | |
149 | } | |
150 | ||
151 | sub as_string # for debugging | |
152 | { | |
153 | my $vec = shift; | |
154 | my $str = ref($vec) . ": "; | |
155 | my $bits = $vec->bits; | |
156 | my $count = $vec->count; | |
157 | $str .= defined($bits) ? unpack("b*", $bits) : "undef"; | |
158 | $str .= " $count"; | |
159 | my @handles = @$vec; | |
160 | splice(@handles, 0, FIRST_FD); | |
161 | for (@handles) { | |
162 | $str .= " " . (defined($_) ? "$_" : "-"); | |
163 | } | |
164 | $str; | |
165 | } | |
166 | ||
167 | sub _max | |
168 | { | |
169 | my($a,$b,$c) = @_; | |
170 | $a > $b | |
171 | ? $a > $c | |
172 | ? $a | |
173 | : $c | |
174 | : $b > $c | |
175 | ? $b | |
176 | : $c; | |
177 | } | |
178 | ||
179 | sub select | |
180 | { | |
181 | shift | |
182 | if defined $_[0] && !ref($_[0]); | |
183 | ||
184 | my($r,$w,$e,$t) = @_; | |
185 | my @result = (); | |
186 | ||
187 | my $rb = defined $r ? $r->[VEC_BITS] : undef; | |
188 | my $wb = defined $w ? $w->[VEC_BITS] : undef; | |
189 | my $eb = defined $e ? $e->[VEC_BITS] : undef; | |
190 | ||
191 | if(select($rb,$wb,$eb,$t) > 0) | |
192 | { | |
193 | my @r = (); | |
194 | my @w = (); | |
195 | my @e = (); | |
196 | my $i = _max(defined $r ? scalar(@$r)-1 : 0, | |
197 | defined $w ? scalar(@$w)-1 : 0, | |
198 | defined $e ? scalar(@$e)-1 : 0); | |
199 | ||
200 | for( ; $i >= FIRST_FD ; $i--) | |
201 | { | |
202 | my $j = $i - FIRST_FD; | |
203 | push(@r, $r->[$i]) | |
204 | if defined $rb && defined $r->[$i] && vec($rb, $j, 1); | |
205 | push(@w, $w->[$i]) | |
206 | if defined $wb && defined $w->[$i] && vec($wb, $j, 1); | |
207 | push(@e, $e->[$i]) | |
208 | if defined $eb && defined $e->[$i] && vec($eb, $j, 1); | |
209 | } | |
210 | ||
211 | @result = (\@r, \@w, \@e); | |
212 | } | |
213 | @result; | |
214 | } | |
215 | ||
216 | ||
217 | sub handles | |
218 | { | |
219 | my $vec = shift; | |
220 | my $bits = shift; | |
221 | my @h = (); | |
222 | my $i; | |
223 | my $max = scalar(@$vec) - 1; | |
224 | ||
225 | for ($i = FIRST_FD; $i <= $max; $i++) | |
226 | { | |
227 | next unless defined $vec->[$i]; | |
228 | push(@h, $vec->[$i]) | |
229 | if !defined($bits) || vec($bits, $i - FIRST_FD, 1); | |
230 | } | |
231 | ||
232 | @h; | |
233 | } | |
234 | ||
235 | 1; | |
236 | __END__ | |
237 | ||
238 | =head1 NAME | |
239 | ||
240 | IO::Select - OO interface to the select system call | |
241 | ||
242 | =head1 SYNOPSIS | |
243 | ||
244 | use IO::Select; | |
245 | ||
246 | $s = IO::Select->new(); | |
247 | ||
248 | $s->add(\*STDIN); | |
249 | $s->add($some_handle); | |
250 | ||
251 | @ready = $s->can_read($timeout); | |
252 | ||
253 | @ready = IO::Select->new(@handles)->can_read(0); | |
254 | ||
255 | =head1 DESCRIPTION | |
256 | ||
257 | The C<IO::Select> package implements an object approach to the system C<select> | |
258 | function call. It allows the user to see what IO handles, see L<IO::Handle>, | |
259 | are ready for reading, writing or have an exception pending. | |
260 | ||
261 | =head1 CONSTRUCTOR | |
262 | ||
263 | =over 4 | |
264 | ||
265 | =item new ( [ HANDLES ] ) | |
266 | ||
267 | The constructor creates a new object and optionally initialises it with a set | |
268 | of handles. | |
269 | ||
270 | =back | |
271 | ||
272 | =head1 METHODS | |
273 | ||
274 | =over 4 | |
275 | ||
276 | =item add ( HANDLES ) | |
277 | ||
278 | Add the list of handles to the C<IO::Select> object. It is these values that | |
279 | will be returned when an event occurs. C<IO::Select> keeps these values in a | |
280 | cache which is indexed by the C<fileno> of the handle, so if more than one | |
281 | handle with the same C<fileno> is specified then only the last one is cached. | |
282 | ||
283 | Each handle can be an C<IO::Handle> object, an integer or an array | |
284 | reference where the first element is an C<IO::Handle> or an integer. | |
285 | ||
286 | =item remove ( HANDLES ) | |
287 | ||
288 | Remove all the given handles from the object. This method also works | |
289 | by the C<fileno> of the handles. So the exact handles that were added | |
290 | need not be passed, just handles that have an equivalent C<fileno> | |
291 | ||
292 | =item exists ( HANDLE ) | |
293 | ||
294 | Returns a true value (actually the handle itself) if it is present. | |
295 | Returns undef otherwise. | |
296 | ||
297 | =item handles | |
298 | ||
299 | Return an array of all registered handles. | |
300 | ||
301 | =item can_read ( [ TIMEOUT ] ) | |
302 | ||
303 | Return an array of handles that are ready for reading. C<TIMEOUT> is | |
304 | the maximum amount of time to wait before returning an empty list, in | |
305 | seconds, possibly fractional. If C<TIMEOUT> is not given and any | |
306 | handles are registered then the call will block. | |
307 | ||
308 | =item can_write ( [ TIMEOUT ] ) | |
309 | ||
310 | Same as C<can_read> except check for handles that can be written to. | |
311 | ||
312 | =item has_exception ( [ TIMEOUT ] ) | |
313 | ||
314 | Same as C<can_read> except check for handles that have an exception | |
315 | condition, for example pending out-of-band data. | |
316 | ||
317 | =item count () | |
318 | ||
319 | Returns the number of handles that the object will check for when | |
320 | one of the C<can_> methods is called or the object is passed to | |
321 | the C<select> static method. | |
322 | ||
323 | =item bits() | |
324 | ||
325 | Return the bit string suitable as argument to the core select() call. | |
326 | ||
327 | =item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] ) | |
328 | ||
329 | C<select> is a static method, that is you call it with the package name | |
330 | like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or | |
331 | C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as | |
332 | for the core select call. | |
333 | ||
334 | The result will be an array of 3 elements, each a reference to an array | |
335 | which will hold the handles that are ready for reading, writing and have | |
336 | exceptions respectively. Upon error an empty list is returned. | |
337 | ||
338 | =back | |
339 | ||
340 | =head1 EXAMPLE | |
341 | ||
342 | Here is a short example which shows how C<IO::Select> could be used | |
343 | to write a server which communicates with several sockets while also | |
344 | listening for more connections on a listen socket | |
345 | ||
346 | use IO::Select; | |
347 | use IO::Socket; | |
348 | ||
349 | $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); | |
350 | $sel = new IO::Select( $lsn ); | |
351 | ||
352 | while(@ready = $sel->can_read) { | |
353 | foreach $fh (@ready) { | |
354 | if($fh == $lsn) { | |
355 | # Create a new socket | |
356 | $new = $lsn->accept; | |
357 | $sel->add($new); | |
358 | } | |
359 | else { | |
360 | # Process socket | |
361 | ||
362 | # Maybe we have finished with the socket | |
363 | $sel->remove($fh); | |
364 | $fh->close; | |
365 | } | |
366 | } | |
367 | } | |
368 | ||
369 | =head1 AUTHOR | |
370 | ||
371 | Graham Barr. Currently maintained by the Perl Porters. Please report all | |
372 | bugs to <perl5-porters@perl.org>. | |
373 | ||
374 | =head1 COPYRIGHT | |
375 | ||
376 | Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. | |
377 | This program is free software; you can redistribute it and/or | |
378 | modify it under the same terms as Perl itself. | |
379 | ||
380 | =cut | |
381 |