Data commit

Task/Chat-server/Perl/chat-server-1.pl

@@ -0,0 +1,108 @@
+use 5.010;
+use strict;
+use warnings;
+
+use threads;
+use threads::shared;
+
+use IO::Socket::INET;
+use Time::HiRes qw(sleep ualarm);
+
+my $HOST = "localhost";
+my $PORT = 4004;
+
+my @open;
+my %users : shared;
+
+sub broadcast {
+    my ($id, $message) = @_;
+    print "$message\n";
+    foreach my $i (keys %users) {
+        if ($i != $id) {
+            $open[$i]->send("$message\n");
+        }
+    }
+}
+
+sub sign_in {
+    my ($conn) = @_;
+
+    state $id = 0;
+
+    threads->new(
+        sub {
+            while (1) {
+                $conn->send("Please enter your name: ");
+                $conn->recv(my $name, 1024, 0);
+
+                if (defined $name) {
+                    $name = unpack('A*', $name);
+
+                    if (exists $users{$name}) {
+                        $conn->send("Name entered is already in use.\n");
+                    }
+                    elsif ($name ne '') {
+                        $users{$id} = $name;
+                        broadcast($id, "+++ $name arrived +++");
+                        last;
+                    }
+                }
+            }
+        }
+    );
+
+    ++$id;
+    push @open, $conn;
+}
+
+my $server = IO::Socket::INET->new(
+                                   Timeout   => 0,
+                                   LocalPort => $PORT,
+                                   Proto     => "tcp",
+                                   LocalAddr => $HOST,
+                                   Blocking  => 0,
+                                   Listen    => 1,
+                                   Reuse     => 1,
+                                  );
+
+local $| = 1;
+print "Listening on $HOST:$PORT\n";
+
+while (1) {
+    my ($conn) = $server->accept;
+
+    if (defined($conn)) {
+        sign_in($conn);
+    }
+
+    foreach my $i (keys %users) {
+
+        my $conn = $open[$i];
+        my $message;
+
+        eval {
+            local $SIG{ALRM} = sub { die "alarm\n" };
+            ualarm(500);
+            $conn->recv($message, 1024, 0);
+            ualarm(0);
+        };
+
+        if ($@ eq "alarm\n") {
+            next;
+        }
+
+        if (defined($message)) {
+            if ($message ne '') {
+                $message = unpack('A*', $message);
+                broadcast($i, "$users{$i}> $message");
+            }
+            else {
+                broadcast($i, "--- $users{$i} leaves ---");
+                delete $users{$i};
+                undef $open[$i];
+            }
+        }
+    }
+
+    sleep(0.1);
+}

Task/Chat-server/Perl/chat-server-2.pl

@@ -0,0 +1,80 @@
+#!/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} = '';
+      }
+    }
+  }