$SIG{PIPE} = sub {close $active; exit (3)};
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;
}


##</code><code>##

#!/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));
}

##</code><code>##

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

use IO::Socket;

my $RW_BUF_LEN = 256;
my $TERMINATOR = 01;   #CTRL-A

$SIG{'PIPE'} = sub{print "Server Disconnected! Write to server failed!\n"; exit(1);};
$SIG{'INT'}  = \&terminal_handler;
$SIG{'QUIT'} = \&terminal_handler;
$SIG{'USR1'} = sub{print "Communications Error - read from server failed!\n"; exit(3);};

my ($socket) = IO::Socket::INET->new(
                                       PeerAddr => 'voyager.deanza.edu',
                                       PeerPort => 12455,
                                       Proto    => 'tcp',
                                       Type     => SOCK_STREAM
                                     )
   || die "Cannot connect to server! $!\n";
  
my $input;
while ( (print "Enter username (or *quit): "),
        ($input = <STDIN>) !~ m/^\s*\*quit\s*$/)
{
   next if $input =~ /^\s*$/;  # blank line, re-prompt
   my ($username, $kruft) = split /\s+/, $input;
   
   if ($kruft)
   {
      print "Only one username per line allowed!\n";
      next;
   }
   
   my $pad = $RW_BUF_LEN - length ($username);
   my $buf = $username.pack("x$pad");    # pads $buf with null \000 chars 
   #print "length of username packet=",length $buf,"\n";  # for debug
   
   writen ($socket,substr($buf,0,1));             
   writen ($socket,substr($buf,1,$RW_BUF_LEN-1));
   
   open (my $more, "|more") || die "cannot open pipe to more! $!\n";
   
   while (($buf) = readn($socket, $RW_BUF_LEN),
          $TERMINATOR != ord(unpack("a1",$buf)) )
   {     
       my ($temp) = $buf =~ m/^(.*?\n)/; #needed for "more"
                                         #regular "print $buf;" is fine
                                         #but trailing nulls drive "more" crazy!
       print $more $temp;
   }
   close $more;
}

send_quit_packet();  #tell server we are "hanging up"
close $socket;
exit(0);

##################
sub terminal_handler
{
   my $signame = shift;
   print "\nClient: received signal: $signame\n";   #debugging statement
   print "Client: Disconnecting from server!\n";    #debugging statement

   send_quit_packet();  #say, "bye, bye"
   close $socket;
   exit(2);
}

sub send_quit_packet
{   
   my $pad = $RW_BUF_LEN - length ('*quit');
   my $buf = '*quit'.pack("x$pad");
   #print "length of quit packet buffer = ",length $buf,"\n"; #debug
   
   writen ($socket,substr($buf,0,1));             
   writen ($socket,substr($buf,1,$RW_BUF_LEN-1));
}

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 'USR1',$$ unless (defined $nread);  ## undef is like -1 unix return
      last if ($nread ==0);                    ## EOF
      
      $offset += $nread;
   }
   
  # print "length of received buff=",length $buf,"\n";
  # print $buf;
   return $buf;
}

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;
   }
   
   #print "num bytes written to server: $offset\n";
   return $offset;
}

##</code><code>##

writen ($socket,substr($buf,0,1));             
writen ($socket,substr($buf,1,$RW_BUF_LEN-1));