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