Sig: Mapping our server to Sup: A Non Forking Echo Ant: A Non Forking Echo
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;
}
}
|
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 }
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?
