contrib/perl5/ext/IO/lib/IO/Select.pm

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