|
ru.perl
- RU.PERL ----------------------------------------------------------------------
From : Oleg Plotnikov 2:5011/111 07 Dec 2002 00:03:00
To : All
Subject : Сервак без ветвления
--------------------------------------------------------------------------------
Вот набросал сабж, вроде всё правильно по логике, а чего-то не работает...
#!/usr/bin/perl
use IO::Socket;
use IO::Select;
use Socket;
use POSIX;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use Tie::RefHash;
##########################################################################
$port = 1685;
$server = IO::Socket::INET->new(LocalPort => $port,
Listen => 10)
or die "Can't make server socket: $@\n";
%inbuffer = ();
%outbuffer = ();
%ready = ();
tie %ready, 'Tie::RefHash';
nonblock($server);
$select = IO::Select->new($server);
while (1)
{
my $client;
my $rv;
my $data;
foreach $client ($select->can_read(1))
{
if ($client == $server)
{
$client = $server->accept();
$select ->add($client);
nonblock($client);
}
else
{
$data = '';
$rv = $client->recv($data, POSIX::BUFSIZ, 0);
unless (defined($rv) && length $data)
{
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};
$select->remove($client);
close($client);
next;
}
$inbuffer{$client} .= $data;
while ($inbuffer{$client} = ~ s/(.*\n)//)
{
push(@{$ready{$client}}, $1);
}
}
}
foreach $client (keys %ready)
{
handle($client);
}
foreach $client ($select->can_write(1))
{
next unless exists $outbuffer{$client};
$rv = $client->send($outbuffer{$client}, 0);
unless (defined $rv)
{
warn "I was told I could write, but I can't. \n";
next;
}
if ($rv == length $outbuffer{$client} || $! == POSIX::EWOULDBLOCK)
{
substr($outbuffer{$client}, 0, $rv) = '';
delete $outbuffer{$client} unless length $outbuffer{$client};
}
else
{
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};
$select->remove($client);
close($client);
next;
}
}
foreach $client ($select->has_exception(0)) {
# tttt
}
}
sub handle {
my $client = shift;
my $request;
foreach $request (@{$ready{$client}})
{
# $outbuffer{$client};
}
delete $ready{$client};
}
sub nonblock {
my $socket = shift;
my $flags;
$flags = fcntl($socket, F_GETFL, 0) or die "Can't get flags for socket:
$!\n";
$flags = fcntl($socket, F_SETFL, $flags | O_NONBLOCK) or die "Can't make
socket nonblocking: $!\n";
}
Матюгание идет в основном на F_GETFL and F_SETFL, но почему оно на них
матюгается неясно...
ю Усё, ухожу! Счастливо! 06 Дек 02 23:00
--- Contact e-mail: bpilots@ufacom.ru
* Origin: Linux-Mandrake RE User (IPLabs) (2:5011/111)
Вернуться к списку тем, сортированных по: возрастание даты уменьшение даты тема автор
|
