Chat server: Difference between revisions
Content added Content deleted
Line 2,140: | Line 2,140: | ||
sleep(0.1); |
sleep(0.1); |
||
}</lang> |
}</lang> |
||
===Alternate with both read and write queuing=== |
|||
<lang perl>#!/usr/bin/perl |
|||
use strict; # http://www.rosettacode.org/wiki/Chat_server |
|||
use warnings; |
|||
use IO::Socket; |
|||
use IO::Select; # with write queueing |
|||
my $port = shift // 6666; |
|||
my (%nicks, @users, %data); |
|||
my $listen = IO::Socket::INET->new(LocalPort => $port, Listen => 9, |
|||
Reuse => 1) or die "$@ opening socket on port $port"; |
|||
my $rsel = IO::Select->new($listen); |
|||
my $wsel = IO::Select->new(); |
|||
print "ready on $port...\n"; |
|||
sub to |
|||
{ |
|||
my $text = pop; |
|||
for ( @_ ) |
|||
{ |
|||
length $data{$_}{out} or $wsel->add( $_ ); |
|||
length( $data{$_}{out} .= $text ) > 1e4 and left( $_ ); |
|||
} |
|||
return $text; |
|||
} |
|||
sub left |
|||
{ |
|||
my $h = shift; |
|||
@users = grep $h != $_, @users; |
|||
if( defined( my $nick = delete $nicks{$h} ) ) |
|||
{ |
|||
print to @users, "$nick has left\n"; |
|||
} |
|||
delete $data{$h}; |
|||
$rsel->remove($h); |
|||
} |
|||
while( 1 ) |
|||
{ |
|||
my ($reads, $writes) = IO::Select->select($rsel, $wsel, undef, 5); |
|||
for my $h ( @{ $writes // [] } ) |
|||
{ |
|||
my $len = syswrite $h, $data{$h}{out}; |
|||
$len and substr $data{$h}{out}, 0, $len, ''; |
|||
length $data{$h}{out} or $wsel->remove( $h ); |
|||
} |
|||
for my $h ( @{ $reads // [] } ) |
|||
{ |
|||
if( $h == $listen ) # new connection |
|||
{ |
|||
$rsel->add( my $client = $h->accept ); |
|||
$data{$client} = { h => $client, out => "enter nick: ", in => '' }; |
|||
$wsel->add( $client ); |
|||
} |
|||
elsif( not sysread $h, $data{$h}{in}, 4096, length $data{$h}{in} ) # closed |
|||
{ |
|||
left $h; |
|||
} |
|||
elsif( exists $nicks{$h} ) # user is signed in |
|||
{ |
|||
my @others = grep $h != $_, @users; |
|||
to @others, "$nicks{$h}> $&" while $data{$h}{in} =~ s/.*\n//; |
|||
} |
|||
elsif( $data{$h}{in} =~ s/^(\w+)\r?\n.*//s and |
|||
not grep lc $1 eq lc, values %nicks ) |
|||
{ # user has joined |
|||
my $all = join ' ', sort values %nicks; |
|||
$nicks{$h} = $1; |
|||
push @users, $h; |
|||
print to @users, "$nicks{$h} has joined $all\n"; |
|||
} |
|||
else # bad nick |
|||
{ |
|||
to $h, "nick invalid or in use, enter nick: "; |
|||
$data{$h}{in} = ''; |
|||
} |
|||
} |
|||
}</lang> |
|||
=={{header|Perl 6}}== |
=={{header|Perl 6}}== |