418 lines
9.0 KiB
Perl
418 lines
9.0 KiB
Perl
# IO::Select.pm
|
|
#
|
|
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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;
|
|
require Exporter;
|
|
|
|
our $VERSION = "1.45";
|
|
|
|
our @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;
|
|
my $fno = $vec->_fileno(shift);
|
|
return undef unless defined $fno;
|
|
$vec->[$fno + FIRST_FD];
|
|
}
|
|
|
|
|
|
sub _fileno
|
|
{
|
|
my($self, $f) = @_;
|
|
return unless defined $f;
|
|
$f = $f->[0] if ref($f) eq 'ARRAY';
|
|
if($f =~ /^[0-9]+$/) { # plain file number
|
|
return $f;
|
|
}
|
|
elsif(defined(my $fd = fileno($f))) {
|
|
return $fd;
|
|
}
|
|
else {
|
|
# Neither a plain file number nor an opened filehandle; but maybe it was
|
|
# previously registered and has since been closed. ->remove still wants to
|
|
# know what fileno it had
|
|
foreach my $i ( FIRST_FD .. $#$self ) {
|
|
return $i - FIRST_FD if $self->[$i] == $f;
|
|
}
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
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);
|
|
if ($add) {
|
|
next unless defined $fn;
|
|
my $i = $fn + FIRST_FD;
|
|
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
|
|
if ( ! defined $fn ) { # remove if fileno undef'd
|
|
$fn = 0;
|
|
for my $fe (@{$vec}[FIRST_FD .. $#$vec]) {
|
|
if (defined($fe) && $fe == $f) {
|
|
$vec->[FD_COUNT]--;
|
|
$fe = undef;
|
|
vec($bits, $fn, 1) = 0;
|
|
last;
|
|
}
|
|
++$fn;
|
|
}
|
|
}
|
|
else {
|
|
my $i = $fn + FIRST_FD;
|
|
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_exception
|
|
{
|
|
my $vec = shift;
|
|
my $timeout = shift;
|
|
my $e = $vec->[VEC_BITS];
|
|
|
|
defined($e) && (select(undef,undef,$e,$timeout) > 0)
|
|
? handles($vec, $e)
|
|
: ();
|
|
}
|
|
|
|
sub has_error
|
|
{
|
|
warnings::warn("Call to deprecated method 'has_error', use 'has_exception'")
|
|
if warnings::enabled();
|
|
goto &has_exception;
|
|
}
|
|
|
|
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;
|
|
__END__
|
|
|
|
=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)->can_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 exception 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 an 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 (with C<$!>
|
|
unchanged), in seconds, possibly fractional. If C<TIMEOUT> is not given
|
|
and any handles are registered then the call will block indefinitely.
|
|
Upon error, an empty list is returned, with C<$!> set to indicate the
|
|
error. To distinguish between timeout and error, set C<$!> to zero
|
|
before calling this method, and check it after an empty list is returned.
|
|
|
|
=item can_write ( [ TIMEOUT ] )
|
|
|
|
Same as C<can_read> except check for handles that can be written to.
|
|
|
|
=item has_exception ( [ TIMEOUT ] )
|
|
|
|
Same as C<can_read> 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<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 select ( READ, WRITE, EXCEPTION [, 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<EXCEPTION> are either C<undef> or
|
|
C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as
|
|
for the core select call.
|
|
|
|
If at least one handle is ready for the specified kind of operation,
|
|
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 exceptions respectively. Upon timeout, an empty list is returned,
|
|
with C<$!> unchanged. Upon error, an empty list is returned, with C<$!>
|
|
set to indicate the error. To distinguish between timeout and error,
|
|
set C<$!> to zero before calling this method, and check it after an
|
|
empty list 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 = IO::Socket::INET->new(Listen => 1, LocalPort => 8080);
|
|
$sel = IO::Select->new( $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. Currently maintained by the Perl Porters. Please report all
|
|
bugs to <perlbug@perl.org>.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
|
|
=cut
|
|
|