<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># IO::Select.pm
#
# Copyright (c) 1997-8 Graham Barr &lt;gbarr@pobox.com&gt;. 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;

use     strict;
use warnings::register;
use     vars qw($VERSION @ISA);
require Exporter;

$VERSION = "1.14";

@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-&gt;add(@_)
    if @_;

 $vec;
}

sub add
{
 shift-&gt;_update('add', @_);
}


sub remove
{
 shift-&gt;_update('remove', @_);
}


sub exists
{
 my $vec = shift;
 my $fno = $vec-&gt;_fileno(shift);
 return undef unless defined $fno;
 $vec-&gt;[$fno + FIRST_FD];
}


sub _fileno
{
 my($self, $f) = @_;
 return unless defined $f;
 $f = $f-&gt;[0] if ref($f) eq 'ARRAY';
 ($f =~ /^\d+$/) ? $f : fileno($f);
}

sub _update
{
 my $vec = shift;
 my $add = shift eq 'add';

 my $bits = $vec-&gt;[VEC_BITS];
 $bits = '' unless defined $bits;

 my $count = 0;
 my $f;
 foreach $f (@_)
  {
   my $fn = $vec-&gt;_fileno($f);
   next unless defined $fn;
   my $i = $fn + FIRST_FD;
   if ($add) {
     if (defined $vec-&gt;[$i]) {
	 $vec-&gt;[$i] = $f;  # if array rest might be different, so we update
	 next;
     }
     $vec-&gt;[FD_COUNT]++;
     vec($bits, $fn, 1) = 1;
     $vec-&gt;[$i] = $f;
   } else {      # remove
     next unless defined $vec-&gt;[$i];
     $vec-&gt;[FD_COUNT]--;
     vec($bits, $fn, 1) = 0;
     $vec-&gt;[$i] = undef;
   }
   $count++;
  }
 $vec-&gt;[VEC_BITS] = $vec-&gt;[FD_COUNT] ? $bits : undef;
 $count;
}

sub can_read
{
 my $vec = shift;
 my $timeout = shift;
 my $r = $vec-&gt;[VEC_BITS];

 defined($r) &amp;&amp; (select($r,undef,undef,$timeout) &gt; 0)
    ? handles($vec, $r)
    : ();
}

sub can_write
{
 my $vec = shift;
 my $timeout = shift;
 my $w = $vec-&gt;[VEC_BITS];

 defined($w) &amp;&amp; (select(undef,$w,undef,$timeout) &gt; 0)
    ? handles($vec, $w)
    : ();
}

sub has_exception
{
 my $vec = shift;
 my $timeout = shift;
 my $e = $vec-&gt;[VEC_BITS];

 defined($e) &amp;&amp; (select(undef,undef,$e,$timeout) &gt; 0)
    ? handles($vec, $e)
    : ();
}

sub has_error
{
 warnings::warn("Call to depreciated method 'has_error', use 'has_exception'")
	if warnings::enabled();
 goto &amp;has_exception;
}

sub count
{
 my $vec = shift;
 $vec-&gt;[FD_COUNT];
}

sub bits
{
 my $vec = shift;
 $vec-&gt;[VEC_BITS];
}

sub as_string  # for debugging
{
 my $vec = shift;
 my $str = ref($vec) . ": ";
 my $bits = $vec-&gt;bits;
 my $count = $vec-&gt;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 &gt; $b
    ? $a &gt; $c
        ? $a
        : $c
    : $b &gt; $c
        ? $b
        : $c;
}

sub select
{
 shift
   if defined $_[0] &amp;&amp; !ref($_[0]);

 my($r,$w,$e,$t) = @_;
 my @result = ();

 my $rb = defined $r ? $r-&gt;[VEC_BITS] : undef;
 my $wb = defined $w ? $w-&gt;[VEC_BITS] : undef;
 my $eb = defined $e ? $e-&gt;[VEC_BITS] : undef;

 if(select($rb,$wb,$eb,$t) &gt; 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 &gt;= FIRST_FD ; $i--)
    {
     my $j = $i - FIRST_FD;
     push(@r, $r-&gt;[$i])
        if defined $rb &amp;&amp; defined $r-&gt;[$i] &amp;&amp; vec($rb, $j, 1);
     push(@w, $w-&gt;[$i])
        if defined $wb &amp;&amp; defined $w-&gt;[$i] &amp;&amp; vec($wb, $j, 1);
     push(@e, $e-&gt;[$i])
        if defined $eb &amp;&amp; defined $e-&gt;[$i] &amp;&amp; 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 &lt;= $max; $i++)
  {
   next unless defined $vec-&gt;[$i];
   push(@h, $vec-&gt;[$i])
      if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
  }
 
 @h;
}

1;
__END__

=head1 NAME

IO::Select - OO interface to the select system call

=head1 SYNOPSIS

    use IO::Select;

    $s = IO::Select-&gt;new();

    $s-&gt;add(\*STDIN);
    $s-&gt;add($some_handle);

    @ready = $s-&gt;can_read($timeout);

    @ready = IO::Select-&gt;new(@handles)-&gt;read(0);

=head1 DESCRIPTION

The C&lt;IO::Select&gt; package implements an object approach to the system C&lt;select&gt;
function call. It allows the user to see what IO handles, see L&lt;IO::Handle&gt;,
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&lt;IO::Select&gt; object. It is these values that
will be returned when an event occurs. C&lt;IO::Select&gt; keeps these values in a
cache which is indexed by the C&lt;fileno&gt; of the handle, so if more than one
handle with the same C&lt;fileno&gt; is specified then only the last one is cached.

Each handle can be an C&lt;IO::Handle&gt; object, an integer or an array
reference where the first element is a C&lt;IO::Handle&gt; or an integer.

=item remove ( HANDLES )

Remove all the given handles from the object. This method also works
by the C&lt;fileno&gt; of the handles. So the exact handles that were added
need not be passed, just handles that have an equivalent C&lt;fileno&gt;

=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&lt;TIMEOUT&gt; is
the maximum amount of time to wait before returning an empty list, in
seconds, possibly fractional. If C&lt;TIMEOUT&gt; is not given and any
handles are registered then the call will block.

=item can_write ( [ TIMEOUT ] )

Same as C&lt;can_read&gt; except check for handles that can be written to.

=item has_exception ( [ TIMEOUT ] )

Same as C&lt;can_read&gt; except check for handles that have an exception
condition, for example pending out-of-band data.

=item count ()

Returns the number of handles that the object will check for when
one of the C&lt;can_&gt; methods is called or the object is passed to
the C&lt;select&gt; static method.

=item bits()

Return the bit string suitable as argument to the core select() call.

=item select ( READ, WRITE, ERROR [, TIMEOUT ] )

C&lt;select&gt; is a static method, that is you call it with the package
name like C&lt;new&gt;. C&lt;READ&gt;, C&lt;WRITE&gt; and C&lt;ERROR&gt; are either C&lt;undef&gt;
or C&lt;IO::Select&gt; objects. C&lt;TIMEOUT&gt; 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&lt;IO::Select&gt; 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 =&gt; 1, LocalPort =&gt; 8080);
    $sel = new IO::Select( $lsn );

    while(@ready = $sel-&gt;can_read) {
        foreach $fh (@ready) {
            if($fh == $lsn) {
                # Create a new socket
                $new = $lsn-&gt;accept;
                $sel-&gt;add($new);
            }
            else {
                # Process socket

                # Maybe we have finished with the socket
                $sel-&gt;remove($fh);
                $fh-&gt;close;
            }
        }
    }

=head1 AUTHOR

Graham Barr. Currently maintained by the Perl Porters.  Please report all
bugs to &lt;perl5-porters@perl.org&gt;.

=head1 COPYRIGHT

Copyright (c) 1997-8 Graham Barr &lt;gbarr@pobox.com&gt;. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

</pre></body></html>