A simple select() server.

First we adapt the non-forking server from Perl Cookbook recipe 17.13. The changes that have been made here are for compactness and to ease the translation into POE. We also give the server some minor purpose so that the samples are a little interesting to run.

As usual, we start by loading necessary modules and initializing global data structures.

#!/usr/bin/perl

use warnings;
use strict;

use IO::Socket;
use IO::Select;
use Tie::RefHash;

my %inbuffer  = ();
my %outbuffer = ();
my %ready     = ();

tie %ready, "Tie::RefHash";

Next we create the server socket. It's set non-blocking so its operations won't stop this single-process server.

my $server = IO::Socket::INET->new
  ( LocalPort => 12345,
    Listen => 10,
  ) or die "can't make server socket: $@\n";

$server->blocking(0);

Then comes the main loop. We create an IO::Select object to watch our sockets, and then we use it to detect activity on them. Whenever something interesting happens to a socket, we call a function to process it.

my $select = IO::Select->new($server);

while (1) {

    # Process sockets that are ready for reading.
    foreach my $client ( $select->can_read(1) ) {
        handle_read($client);
    }

    # Process any complete requests.  Echo the data back to the client,
    # by putting the ready lines into the client's output buffer.
    foreach my $client ( keys %ready ) {
        foreach my $request ( @{ $ready{$client} } ) {
            print "Got request: $request";
            $outbuffer{$client} .= $request;
        }
        delete $ready{$client};
    }

    # Process sockets that are ready for writing.
    foreach my $client ( $select->can_write(1) ) {
        handle_write($client);
    }
}

exit;

That concludes the main loop. Next we have functions that process different forms of socket activity.

The first function handles sockets that are ready to be read from. If the ready socket is the main server's, we accept a new connection and register it with the IO::Select object. If it's a client socket with some input for us, we read it, parse it, and enter complete new lines into the %ready structure. The main loop will catch data from %ready and echo it back to the client.

sub handle_read {
    my $client = shift;

    if ( $client == $server ) {
        my $new_client = $server->accept();
        $new_client->blocking(0);
        $select->add($new_client);
        return;
    }

    my $data = "";
    my $rv   = $client->recv( $data, POSIX::BUFSIZ, 0 );

    unless ( defined($rv) and length($data) ) {
        handle_error($client);
        return;
    }

    $inbuffer{$client} .= $data;
    while ( $inbuffer{$client} =~ s/(.*\n)// ) {
        push @{ $ready{$client} }, $1;
    }
}
The method accept([PKG]) perform the system call accept on the socket and return a new object. The new object will be created in the same class as the listen socket, unless PKG is specified. This object can be used to communicate with the client that was trying to connect.

In a scalar context the new socket is returned, or undef upon failure. In a list context a two-element array is returned containing the new socket and the peer address; the list will be empty upon failure.

Next we have a function that handles writable sockets. Data waiting to be sent to a client is written to its socket and removed from its output buffer.

sub handle_write {
    my $client = shift;

    return unless exists $outbuffer{$client};

    my $rv = $client->send( $outbuffer{$client}, 0 );
    unless ( defined $rv ) {
        warn "I was told I could write, but I can't.\n";
        return;
    }

    if ( $rv == length( $outbuffer{$client} ) or
        $! == POSIX::EWOULDBLOCK
      ) {
        substr( $outbuffer{$client}, 0, $rv ) = "";
        delete $outbuffer{$client} unless length $outbuffer{$client};
        return;
    }

    handle_error($client);
}

Finally we have a function to handle read or write errors on the client sockets. It cleans up after dead sockets and makes sure they have been closed.

sub handle_error {
    my $client = shift;

    delete $inbuffer{$client};
    delete $outbuffer{$client};
    delete $ready{$client};

    $select->remove($client);
    close $client;
}

And after about 107 lines of program, we have an echo server:

  1	#!/usr/bin/perl
  2	use warnings;
  3	use strict;
  4	use POSIX;
  5	use IO::Socket;
  6	use IO::Select;
  7	use Tie::RefHash;
  8	### Create the server socket.
  9	my $server = IO::Socket::INET->new(
 10	  LocalPort => 12345,
 11	  Listen    => 10,
 12	) or die "can't make server socket: $@\n";
 13	$server->blocking(0);
 14	### Set up structures to track input and output data.
 15	my %inbuffer  = ();
 16	my %outbuffer = ();
 17	my %ready     = ();
 18	tie %ready, "Tie::RefHash";
 19	### The select loop itself.
 20	my $select = IO::Select->new($server);
 21	
 22	while (1) {
 23	
 24	  # Process sockets that are ready for reading.
 25	  foreach my $client ($select->can_read(1)) {
 26	    handle_read($client);
 27	  }
 28	
 29	  # Process any complete requests.  Echo the data back to the client,
 30	  # by putting the ready lines into the client's output buffer.
 31	  foreach my $client (keys %ready) {
 32	    foreach my $request (@{$ready{$client}}) {
 33	      print "Got request: $request";
 34	      $outbuffer{$client} .= $request;
 35	    }
 36	    delete $ready{$client};
 37	  }
 38	
 39	  # Process sockets that are ready for writing.
 40	  foreach my $client ($select->can_write(1)) {
 41	    handle_write($client);
 42	  }
 43	}
 44	exit;
 45	### Handle a socket that's ready to be read from.
 46	sub handle_read {
 47	  my $client = shift;
 48	
 49	  # If it's the server socket, accept a new client connection.
 50	  if ($client == $server) {
 51	    my $new_client = $server->accept();
 52	    $new_client->blocking(0);
 53	    $select->add($new_client);
 54	    return;
 55	  }
 56	
 57	  # Read from an established client socket.
 58	  my $data = "";
 59	  my $rv = $client->recv($data, POSIX::BUFSIZ, 0);
 60	
 61	  # Handle socket errors.
 62	  unless (defined($rv) and length($data)) {
 63	    handle_error($client);
 64	    return;
 65	  }
 66	
 67	  # Successful read.  Buffer the data we got, and parse it into lines.
 68	  # Place the lines into %ready, where they will be processed later.
 69	  $inbuffer{$client} .= $data;
 70	  while ($inbuffer{$client} =~ s/(.*\n)//) {
 71	    push @{$ready{$client}}, $1;
 72	  }
 73	}
 74	### Handle a socket that's ready to be written to.
 75	sub handle_write {
 76	  my $client = shift;
 77	
 78	  # Skip this client if there's nothing to write.
 79	  return unless exists $outbuffer{$client};
 80	
 81	  # Attempt to write pending data to the client.
 82	  my $rv = $client->send($outbuffer{$client}, 0);
 83	  unless (defined $rv) {
 84	    warn "I was told I could write, but I can't.\n";
 85	    return;
 86	  }
 87	
 88	  # Successful write.  Remove what was sent from the output buffer.
 89	  if ( $rv == length($outbuffer{$client})
 90	    or $! == POSIX::EWOULDBLOCK) {
 91	    substr($outbuffer{$client}, 0, $rv) = "";
 92	    delete $outbuffer{$client} unless length $outbuffer{$client};
 93	    return;
 94	  }
 95	
 96	  # Otherwise there was an error.
 97	  handle_error($client);
 98	}
 99	### Handle client errors.  Clean up after the dead socket.
100	sub handle_error {
101	  my $client = shift;
102	  delete $inbuffer{$client};
103	  delete $outbuffer{$client};
104	  delete $ready{$client};
105	  $select->remove($client);
106	  close $client;
107	}

Ejecución

En una terminal arrancamos el sercvidor:

$ ./nopoe.pl 
Got request from 'IO::Socket::INET=GLOB(0x913f24)': hola!
Got request from 'IO::Socket::INET=GLOB(0x914014)': que tal?

A continuación arrancamos un cierto número de clientes:

$ gnetcat localhost 12345
hola!
HOLA!

~$ gnetcat localhost 12345
que tal?
QUE TAL?



Subsecciones
Casiano Rodríguez León
Licencia de Creative Commons
Programación Distribuida y Mejora del Rendimiento
por Casiano Rodríguez León is licensed under a Creative Commons Reconocimiento 3.0 Unported License.

Permissions beyond the scope of this license may be available at http://campusvirtual.ull.es/ocw/course/view.php?id=44.
2012-06-19