#!/usr/bin/perl -w 
use strict;  

use IO::Socket;
use POSIX ":sys_wait_h";

my $RW_BUF_LEN = 256;
my $SERVER_TIMEOUT_SECS = 20;
my $active;

#note SOMAXCONN is system max of queue for incoming clients
#Listen=>1 would have also have been just fine

$SIG{PIPE} = sub {close $active; exit (3)};
$SIG{ALRM} = sub {close $active; exit (7)};
$SIG{CHLD} = sub {local ($!, $?); while (waitpid(-1, WNOHANG) > 0){} };

my $passive = IO::Socket::INET->new( Proto     => 'tcp',
                                     LocalPort => 12455,
                                     Listen    => SOMAXCONN,
                                     Reuse     => 1,
                                     Type      => SOCK_STREAM
                                   )
     or die "Server is unable to start: $!\n";

while(1)
{
    $active = $passive->accept() or next; # next not really necessary
                                          # Perl > 5.8 has deferred signals by default on
                                          # so a signal cannot occur within accept()!
                                          

    die "Bad Fork! $!\n" if ( !defined(my $pid = fork()) );
    
    if ($pid != 0)     #Parent  note: Windows has a negative $pid (fork emulation)
    {
       close $active;  #parents do not talk to anybody
       next;
    }
    
    ####### we are the child #########
    close $passive;  #Client's don't listen for connections!
    
    my %whoData;
    open (WHO, "who|") or die "can't open pipe from who command $!\n";
    while ( my $line = <WHO>)
    {
       my ($user) = $line =~ m/^(\w+)/;
       push @{$whoData{$user}}, $line; 
    }
    close WHO; 
    
    my $buf;
    while(alarm($SERVER_TIMEOUT_SECS), ($buf) = readn($active, $RW_BUF_LEN), 
          $buf !~ m/^\*quit/ )
    {  
        alarm(0);
        if ($buf =~ m/^\*all/)
        {
           DumpAllWhoData($active,\%whoData);
           next;
        }
        
        my ($username) = $buf =~ m/^(\w+)/;
        if (exists $whoData{$username})
        {
            foreach my $line ( @{$whoData{$username}} )
            {                    
                SendStringToClient($active,$line);
            }
            SendStringToClient($active,"\01");
        }
        else
        {
            SendStringToClient ($active, "username not found!\n");
            SendStringToClient ($active, "\01");
        }  
    }
    
    close $active;
    exit(0);  #prevent grandchildren!  #### Very important!!!    
}

sub readn
{
   my ($socket, $bytes ) = @_;
   my $offset = 0;
   
   my $buf = "";
   while ($offset < $bytes)
   {
      my $nread;
      my $nleft = $bytes-$offset;
      
      $nread = sysread($socket,$buf,$nleft,$offset);
      kill 'PIPE',$$ unless (defined $nread);  ## undef is like -1 unix return
      last if ($nread ==0);                    ## EOF
      
      $offset += $nread;
   }
   
   return ($buf,$offset);;
}

sub writen
{
   my ($socket, $buf) = @_;
   my $bytes = length $buf;
   my $offset =0;
     
   while ($offset < $bytes)
   {
       my $nwritten;
       my $nleft = $bytes-$offset;
       
       $nwritten = syswrite($socket,$buf,$nleft,$offset);
       kill 'PIPE',$$ unless (defined $nwritten);  # undef is like -1 unix return
       
       $offset += $nwritten;
   }
   
   return $offset;
}

sub DumpAllWhoData
{
   my ($socket, $href) = @_;
   
   foreach my $user (keys %$href)
   {
      foreach my $line ( @{$href->{$user}} )
      {         
         SendStringToClient($socket,$line);
      }
   }
   
   SendStringToClient($socket,"\01");
}

sub SendStringToClient
{
   my ($socket, $string) = @_;

   my $pad = $RW_BUF_LEN - length $string;
   my $buf = $string.pack("x$pad");
   writen ($socket,substr($buf,0,1));
   writen ($socket,substr($buf,1,$RW_BUF_LEN-1));
}