—

              
# IO::Select.pm
#
# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
# software; you can redistribute it and/or modify it under the same terms
# as Perl itself.
package IO::Select;
HideShow 147 lines of Pod
=head1 NAME
IO::Select - OO interface to the select system call
=head1 SYNOPSIS
    use IO::Select;
    $s = IO::Select->new();
    $s->add(\*STDIN);
    $s->add($some_handle);
    @ready = $s->can_read($timeout);
    @ready = IO::Select->new(@handles)->read(0);
=head1 DESCRIPTION
The C<IO::Select> package implements an object approach to the system C<select>
function call. It allows the user to see what IO handles, see L<IO::Handle>,
are ready for reading, writing or have an error condition pending.
=head1 CONSTRUCTOR
=over 4
=item new ( [ HANDLES ] )
The constructor creates a new object and optionally initialises it with a set
of handles.
=back
=head1 METHODS
=over 4
=item add ( HANDLES )
Add the list of handles to the C<IO::Select> object. It is these values that
will be returned when an event occurs. C<IO::Select> keeps these values in a
cache which is indexed by the C<fileno> of the handle, so if more than one
handle with the same C<fileno> is specified then only the last one is cached.
Each handle can be an C<IO::Handle> object, an integer or an array
reference where the first element is a C<IO::Handle> or an integer.
=item remove ( HANDLES )
Remove all the given handles from the object. This method also works
by the C<fileno> of the handles. So the exact handles that were added
need not be passed, just handles that have an equivalent C<fileno>
=item exists ( HANDLE )
Returns a true value (actually the handle itself) if it is present.
Returns undef otherwise.
=item handles
Return an array of all registered handles.
=item can_read ( [ TIMEOUT ] )
Return an array of handles that are ready for reading. C<TIMEOUT> is
the maximum amount of time to wait before returning an empty list. If
C<TIMEOUT> is not given and any handles are registered then the call
will block.
=item can_write ( [ TIMEOUT ] )
Same as C<can_read> except check for handles that can be written to.
=item has_error ( [ TIMEOUT ] )
Same as C<can_read> except check for handles that have an error
condition, for example EOF.
=item count ()
Returns the number of handles that the object will check for when
one of the C<can_> methods is called or the object is passed to
the C<select> static method.
=item bits()
Return the bit string suitable as argument to the core select() call.
=item bits()
Return the bit string suitable as argument to the core select() call.
=item select ( READ, WRITE, ERROR [, TIMEOUT ] )
C<select> is a static method, that is you call it with the package
name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef>
or C<IO::Select> objects. C<TIMEOUT> is optional and has the same
effect as for the core select call.
The result will be an array of 3 elements, each a reference to an array
which will hold the handles that are ready for reading, writing and have
error conditions respectively. Upon error an empty array is returned.
=back
=head1 EXAMPLE
Here is a short example which shows how C<IO::Select> could be used
to write a server which communicates with several sockets while also
listening for more connections on a listen socket
    use IO::Select;
    use IO::Socket;
    $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
    $sel = new IO::Select( $lsn );
     
    while(@ready = $sel->can_read) {
        foreach $fh (@ready) {
            if($fh == $lsn) {
                # Create a new socket
                $new = $lsn->accept;
                $sel->add($new);
            }
            else {
                # Process socket
                # Maybe we have finished with the socket
                $sel->remove($fh);
                $fh->close;
            }
        }
    }
=head1 AUTHOR
Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
=head1 COPYRIGHT
Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=cut
use     strict;
use     vars qw($VERSION @ISA);
require Exporter;
$VERSION = "1.10";
@ISA = qw(Exporter); # This is only so we can do version checking
sub VEC_BITS () {0}
sub FD_COUNT () {1}
sub FIRST_FD () {2}
sub new
{
 my $self = shift;
 my $type = ref($self) || $self;
 my $vec = bless [undef,0], $type;
 $vec->add(@_)
    if @_;
 $vec;
}
sub add
{
 shift->_update('add', @_);
}
sub remove
{
 shift->_update('remove', @_);
}
sub exists
{
 my $vec = shift;
 $vec->[$vec->_fileno(shift) + FIRST_FD];
}
sub _fileno
{
 my($self, $f) = @_;
 $f = $f->[0] if ref($f) eq 'ARRAY';
 ($f =~ /^\d+$/) ? $f : fileno($f);
}
sub _update
{
 my $vec = shift;
 my $add = shift eq 'add';
 my $bits = $vec->[VEC_BITS];
 $bits = '' unless defined $bits;
 my $count = 0;
 my $f;
 foreach $f (@_)
  {
   my $fn = $vec->_fileno($f);
   next unless defined $fn;
   my $i = $fn + FIRST_FD;
   if ($add) {
     if (defined $vec->[$i]) {
         $vec->[$i] = $f;  # if array rest might be different, so we update
         next;
     }
     $vec->[FD_COUNT]++;
     vec($bits, $fn, 1) = 1;
     $vec->[$i] = $f;
   } else {      # remove
     next unless defined $vec->[$i];
     $vec->[FD_COUNT]--;
     vec($bits, $fn, 1) = 0;
     $vec->[$i] = undef;
   }
   $count++;
  }
 $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
 $count;
}
sub can_read
{
 my $vec = shift;
 my $timeout = shift;
 my $r = $vec->[VEC_BITS];
 defined($r) && (select($r,undef,undef,$timeout) > 0)
    ? handles($vec, $r)
    : ();
}
sub can_write
{
 my $vec = shift;
 my $timeout = shift;
 my $w = $vec->[VEC_BITS];
 defined($w) && (select(undef,$w,undef,$timeout) > 0)
    ? handles($vec, $w)
    : ();
}
sub has_error
{
 my $vec = shift;
 my $timeout = shift;
 my $e = $vec->[VEC_BITS];
 defined($e) && (select(undef,undef,$e,$timeout) > 0)
    ? handles($vec, $e)
    : ();
}
sub count
{
 my $vec = shift;
 $vec->[FD_COUNT];
}
sub bits
{
 my $vec = shift;
 $vec->[VEC_BITS];
}
sub as_string  # for debugging
{
 my $vec = shift;
 my $str = ref($vec) . ": ";
 my $bits = $vec->bits;
 my $count = $vec->count;
 $str .= defined($bits) ? unpack("b*", $bits) : "undef";
 $str .= " $count";
 my @handles = @$vec;
 splice(@handles, 0, FIRST_FD);
 for (@handles) {
     $str .= " " . (defined($_) ? "$_" : "-");
 }
 $str;
}
sub _max
{
 my($a,$b,$c) = @_;
 $a > $b
    ? $a > $c
        ? $a
        : $c
    : $b > $c
        ? $b
        : $c;
}
sub select
{
 shift
   if defined $_[0] && !ref($_[0]);
 my($r,$w,$e,$t) = @_;
 my @result = ();
 my $rb = defined $r ? $r->[VEC_BITS] : undef;
 my $wb = defined $w ? $w->[VEC_BITS] : undef;
 my $eb = defined $e ? $e->[VEC_BITS] : undef;
 if(select($rb,$wb,$eb,$t) > 0)
  {
   my @r = ();
   my @w = ();
   my @e = ();
   my $i = _max(defined $r ? scalar(@$r)-1 : 0,
                defined $w ? scalar(@$w)-1 : 0,
                defined $e ? scalar(@$e)-1 : 0);
   for( ; $i >= FIRST_FD ; $i--)
    {
     my $j = $i - FIRST_FD;
     push(@r, $r->[$i])
        if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
     push(@w, $w->[$i])
        if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
     push(@e, $e->[$i])
        if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
    }
   @result = (\@r, \@w, \@e);
  }
 @result;
}
sub handles
{
 my $vec = shift;
 my $bits = shift;
 my @h = ();
 my $i;
 my $max = scalar(@$vec) - 1;
 for ($i = FIRST_FD; $i <= $max; $i++)
  {
   next unless defined $vec->[$i];
   push(@h, $vec->[$i])
      if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
  }
  
 @h;
}
1;