# FILE1 & FILE2 is a filehandle opened elsewhere. $read is a list of
# filehandles we are interested in reading
my $read = ''; # Initialise to an empty set
# (NOTE: $read=0 is very wrong)
vec($read, fileno(FILE1), 1) = 1; # Set the appropriate bit
vec($read, fileno(FILE2), 1) = 1; # And for another file...
####
my $nfound = select($read, undef, undef, undef);
##
##
# Does FILE1 have data waiting?
if (vec($read, fileno(FILE1), 1))
{
# ... do stuff ...
}
##
##
#
# Simple multiplexing package
#
# by Andrew Hunter. All rights given away.
#
package Multiplex;
use strict; # De-rigeur
use Carp; # Nicer error reporting
use Time::HiRes qw/time/; # High precision time
# These structures contain the file objects and timers that we are currently
# interested in:
my @files = ();
my @timers = ();
# Function to add a file object to the list to listen to
# A file object should be a blessed reference, providing the functions
# receive(), called when data becomes available, and file(), which should
# return a reference to a filehandle.
sub listen ($)
{
my ($file) = @_;
croak "File object must provide receive and file methods"
if (!defined($file->can('receive')) ||
!defined($file->can('file')));
push @files, $file;
}
# Function to add a timer object to the list to wait for
# A timer object should be a blessed reference, providing the function timeout,
# which is called when it expires.
#
# This function takes two arguments - the timer object and the length of
# time to wait until timing out.
sub timeout ($$)
{
my ($timer, $howlong) = @_;
croak "Timer object must provide timeout method"
if (!defined($timer->can("timeout")));
push @timers, { what => $timer, when => time()+$howlong };
@timers = sort { $a->{when} <=> $b->{when} } @timers;
# Yeah, the sort is probably inefficient with large numbers of timers
}
# This removes a timeout from the list. This takes a reference to a blessed
# timer object. It should be the same as the reference passed to timeout.
sub removetimout ($)
{
my ($timer) = @_;
@timers = grep { $_->{what} ne "$timer" } @timers;
}
# Actually do the select business itself!
# This should be repeatedly called to create a feeling of interactivity
sub despatchevents ()
{
my $now = time();
# Send out any timeouts that have expired
while ($#timers >= 0 and $timers[0]->{when} < $now)
{
$timers[0]->{what}->timeout();
shift @timers;
$now = time();
}
# Set up the file handles to wait for
my $rin = '';
vec($rin, fileno($_->file()), 1) = 1
foreach (@files);
# Actually do the select
my $rout;
select($rout=$rin,
undef,
undef,
$#timers>=0?$timers[0]->{when} - $now:undef);
# Notify any files that have data waiting
foreach (@files)
{
$_->receive()
if (vec($rout, fileno($_->file()), 1));
}
}
# ==
return 1;
##
##
#
# TCP listener socket
#
# by Andrew Hunter. All rights given away.
#
package tcpAccept;
use strict;
use Carp;
use Multiplex;
use Socket;
# Creates a new object. Call like this:
#
# tcpAccept->new(port => 5454), where port specifies the port you want to
# listen on
sub new
{
my $proto = shift;
my $class = ref($proto) || $proto;
my %args = @_;
my $self = \%args;
bless($self, $class);
local *SOCKET; # Filehandle for the socket we're going to create
# Some error checking
croak "You must give a port for the socket"
if (!defined($self->{port}));
# Create a TCP socket
socket(SOCKET, PF_INET, SOCK_STREAM, getprotobyname('tcp'))
or croak "socket: $!";
# Set the 'REUSEADDR' option
setsockopt(SOCKET, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
or croak "setsockopt: $!";
# Bind to the port specified
bind(SOCKET, sockaddr_in($self->{port}, INADDR_ANY))
or croak "bind: $!";
# Listen to the socket
listen(SOCKET, SOMAXCONN)
or croak "listen: $!";
# Store the socket filehandle away for future reference
$self->{_FILE} = *SOCKET;
return $self;
}
# file() function, as defined by the Multiplex module
sub file
{
my ($self) = @_;
return $self->{_FILE};
}
# receive() function, as defined by the Multiplex module
sub receive
{
my ($self) = @_;
my $client;
{
local(*CLIENT); # The client socket we will create
# Accept the connection that is waiting
accept(CLIENT, $self->{_FILE})
or die "accept: $!";
$client = *CLIENT;
}
# Report the accepted socket
$self->accepted($client);
}
# Override this with your own function
sub accepted
{
my ($self, $client) = @_;
# Display a silly message and close the socket
syswrite $client, "Implement me\n", length("Implement me\n");
close $client;
}
# ==
return 1;
##
##
package sillyTimer;
use strict;
use Multiplex;
# Example timer class
sub new
{
my $proto = shift;
my $class = ref($proto) || $proto;
my %args = @_;
my $self = \%args;
bless($self, $class);
}
# Print 'bing' every 5 seconds
sub timeout
{
print "Bing!\n";
Multiplex::timeout(sillyTimer->new(), 5);
}
package Main;
use strict;
use Multiplex;
use tcpAccept;
my $acceptor = tcpAccept->new(port => 20000);
Multiplex::listen($acceptor);
Multiplex::timeout(sillyTimer->new(), 1);
Multiplex::timeout(sillyTimer->new(), 1.5);
for (;;)
{
Multiplex::despatchevents()
}