Discerning an Open and Closed Socket... 
Author Message
 Discerning an Open and Closed Socket...

I am attempting to create a server application in Perl that offers a simple
keyword-based data access system to be used by a separate, Windows-GUI
client application.  Although I have included the entirety of the developing
application below (which is based closely upon the example found at
http://www.*-*-*.com/ ), I am most concerned
with the server_run() routine.

This method within the script is in essence the "base location" of execution
following a fork() from the parent application.  Provided that the client
terminates a session with the "QUIT" or "LOGOFF" keywords, the child script
quits cooperatively and the parent releases any resources that had been
consumed by the sub-session.  HOWEVER, if the client disconnects WITHOUT
first sending a termination keyword, the child is flung into an infinite
(and *exceptionally* resource-demanding!) loop; the code fragment referenced
by SIG{CHLD} is never executed either.  I am presuming that this is the
result of server_run()'s while loop, which encounters an infinitely-true
statement and is then unable to realize that STDIN is no longer linked to
the client (which was previously DUPed from Client).  Thus my ultimate
question is rather straightforward:  how would I determine if STDIN (or
Client) is still open?  Note that I have tried (-S STDIN) and (-S Client);
neither have worked as I intended.

Any help would be greatly appreciated!

Regards,
Brad Galiette

--------------------------------------------------------------------------
#!/usr/bin/perl
use strict;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
use Socket;
use Carp;
my $EOL = "\015\012";


my $data_id = "";
my $port = 2323;
my $proto = getprotobyname('tcp');
my $active_user = 1;

sub spawn;  # forward declaration

sub logmsg
{
open(ID, ">>id.txt");

close(ID);

Quote:
}

($port) = $port =~ /^(\d+)$/                        or die "invalid port";

socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
     pack("l", 1))  || die "setsockopt: $!";
bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
listen(Server,SOMAXCONN)     || die "listen: $!";

logmsg "Server started";
&parse_data();

my $waitedpid = 0;
my $paddr;

sub REAPER {
 $waitedpid = wait;
 $SIG{CHLD} = \&REAPER;  # loathe sysV
 logmsg "Terminated...";

Quote:
}

$SIG{CHLD} = \&REAPER;

for ( $waitedpid = 0; ($paddr = accept(Client,Server)) || $waitedpid;
$waitedpid = 0, close Client)
 {
 next if $waitedpid and not $paddr;
 my($port,$iaddr) = sockaddr_in($paddr);
 my $name = gethostbyaddr($iaddr,AF_INET);

 logmsg "Client connected!";

  spawn sub {
   $| = 1;
   select(STDOUT);
   $| = 1;

   &server_run();
  };
 }

    sub spawn {
 my $coderef = shift;


     confess "usage: spawn CODEREF";
 }

 my $pid;
 if (!defined($pid = fork)) {
     logmsg "cannot fork: $!";
     return;
 } elsif ($pid) {
     logmsg "begat $pid";
     return; # I'm the parent
 }
 # else I'm the child -- go spawn

 open(STDIN,  "<&Client")   || die "can't dup client to stdin";
 open(STDOUT, ">&Client")   || die "can't dup client to stdout";
 ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
 exit &$coderef();
    }

sub server_run
{
my $line = "";

print "200 Welcome\n";
my $timeout_stage = 0;

while ($active_user == 1)
 {
 eval{
  logmsg "Waiting for input";
  local $SIG{ALRM} = sub{die "\n" };
  alarm 10;
  $line = &read_args();
  alarm 0;
 };


  {
  $timeout_stage++;

  if ($timeout_stage == 3)
   {
   logmsg "Timeout 30";
   &update_data();
   $timeout_stage = 0;
   }

  else
   {
   logmsg "Timeout 10";
   }
  }

 else
  {
  logmsg "Evaluating";
  &evaluate($line);
  }
 }

Quote:
}

sub update_data
{

Quote:
}

sub read_args
{
my $line = <STDIN>;
chop($line);

return $line;

Quote:
}

sub evaluate
{

logmsg $line;


 {
 logmsg $arg_ele[$i];

 if ($line_ele[0] =~ /^ANNC$/i)
  {
  #&annc_respond($line_ele[1]);
  if ($line_ele[1] eq "" || $line_ele[1] ne $data_id)
   {
   #$socket->send("231 " . $data_id . "\n");
   print "231 " . $data_id . "";

    {

    #$socket->send($indiv_ele[3] . "|" . $indiv_ele[1] . "|" . $indiv_ele[2]
. "|" . $indiv_ele[4] . "\n");
    print $indiv_ele[3] . "|" . $indiv_ele[1] . "|" . $indiv_ele[2] . "|" .
$indiv_ele[4] . "\n";
    #print $indiv_ele[3] . "|" . $indiv_ele[1] . "|" . $indiv_ele[2] . "|" .
$indiv_ele[4] . "\n";
    }

   #$socket->send(".");
   print ".";
   }

  else
   {
   #$socket->send("230 " . $data_id . "\n");
   print "230 " . $data_id . "";
   }
  logmsg "ANNC SENT";
  }

 elsif ($line_ele[0] =~ /^TIME$/i)
  {
  #&time_respond();
  my($sec, $min, $hour, $day, $mon, $year) = (localtime(time))[0,1,2,3,4,5];
  print "210 " . $hour . "|" . $min . "|" . $sec . "|" . $mon . "|" . $day .
"|" . $year . "\r\n";
  logmsg "210 " . $hour . "|" . $min . "|" . $sec . "|" . $mon . "|" . $day
. "|" . $year;
  logmsg "TIME SENT";
  }

 elsif ($line_ele[0] =~ /^STATUS$/i)
  {
  #&status_respond();
  print "220 1|HELLO\n";
  logmsg "STATUS SENT";
  }

 elsif ($line_ele[0] =~ /^QUIT$/i || $line_ele[0] =~ /^LOGOFF$/i)
  {
  logmsg "Client logoff...\n";
  $active_user = 0;
  last;
  }
 }

Quote:
}

sub annc_respond
{

if ($input_arg eq "" || $input_arg ne $data_id)
 {
 #$socket->send("231 " . $data_id . "\n");
 print "231 " . $data_id . "\n";

  {

  #$socket->send($indiv_ele[3] . "|" . $indiv_ele[1] . "|" . $indiv_ele[2] .
"|" . $indiv_ele[4] . "\n");
  print $indiv_ele[3] . "|" . $indiv_ele[1] . "|" . $indiv_ele[2] . "|" .
$indiv_ele[4] . "\n";
  #print $indiv_ele[3] . "|" . $indiv_ele[1] . "|" . $indiv_ele[2] . "|" .
$indiv_ele[4] . "\n";
  }

 #$socket->send(".");
 print ".";
 }

else
 {
 #$socket->send("230 " . $data_id . "\n");
 print "230 " . $data_id . "\n";
 }
#print "Sending anncs...\n";
logmsg "Anncs sent";

Quote:
}

sub time_respond
{

my($sec, $min, $hour, $day, $mon, $year) = (localtime(time))[0,1,2,3,4,5];
print "210 " . $hour . "|" . $min . "|" . $sec . "|" . $mon . "|" . $day .
"|" . $year;
#print "Sending time...\n";
logmsg "Time sent";

Quote:
}

sub status_respond
{

print "220 1|HELLO";
#print "Sending status...\n";
logmsg "Status sent";

Quote:
}

sub parse_data
{
my $data_line = "";
my $temp_data_id = "";
my $data_inc = 0;

open(DATA, "data.txt");
$temp_data_id = <DATA>;
chop($temp_data_id);

if ($temp_data_id ne $data_id)
 {
 $data_line = <DATA>;
 chop($data_line);

 while ($data_line ne "")
  {
  $data_lines[$data_inc] = $data_line;
  $data_line = <DATA>;
  chop($data_line);
  $data_inc++;
  }

 $data_id = $temp_data_id;
 }

close(DATA);
logmsg "Data parsed";

Quote:
}



Thu, 26 May 2005 22:09:16 GMT  
 Discerning an Open and Closed Socket...
How would one go about determining if a client is still active on a
server-based socket? (i.e., does the socket remain open and is there a
computer at the other end? :-)

Brad



Fri, 27 May 2005 03:02:30 GMT  
 Discerning an Open and Closed Socket...
Quote:

> I am attempting to create a server application in Perl that offers a
> simpleeyword-based data access system to be used by a separate,
> Windows-GUI

[snip]

When you said, "Windows/GUI", did you meant a GUI in a window, or a GUI
on the Windows Operating System?

Your code uses a number of outdated and/or unportable programming
constructs.

All of your socket stuff should be replaced with IO::Socket.  Direct use
of the functions in Socket.pm is very outdated.



important.

You cannot use the alarm() function on the Windows OS -- it doesn't work
there.  Also, on Windows, fork() is emulated using threads and thus has
a fairly high overhead -- much more overhead than there would be if you
multiplexed your sockets using IO::Select.

Even if you're not on windows, it's a good idea to learn to multiplex
with IO::Select.

Consider the following [untested] code:

   #!/usr/bin/perl
   use strict;
   use warnings;
   use IO::Socket qw(CRLF);
   use IO::Select;

   # These are the only global variables.
   my ($r, $w) = map IO::Select->new, 1, 2;
   my %callbacks;

   {
      my $listener = IO::Socket::INET->new(
         LocalPort => 2323,
         Reuse => 1,
         Listen => SOMAXCONN,

      $r->add($listener);
      $callbacks{$listener}{read_callback} = \&do_accept;
   }

   while( 1 ) {
      my $timeout;
      if( !$w->count ) {
         my $expire;
         foreach my $info (values %callbacks) {
            my $e = $info->{expire_at} or next;
            $expire = $e if !$expire or $e < $expire;
         }
         $timeout = $expire ? time() - $expire : undef;
         $timeout = 0 if defined($timeout) and $timeout < 0;
      }


         # Yes, $w is passed in, and the corresponding
         # arrayref is indeed ignored.  This is on purpose;
         # it has an effect on how long select() blocks.
         (IO::Select->select($r, $w, undef, $timeout))[0]
            or die "Error in select: $!";
      }) {
         $callbacks{$r}{read_callback}->($rrr);
      }

      for my $ww ($w->can_write(0)) {
         $callbacks{$ww}{write_callback}->($ww);
      }

      my $now = time;
      while( my ($sock_stringified, $info) = each %callbacks) ) {
         next unless $info->{expire_callback};
         $info->{expire_cb}->($sock_stringified);
      }

   }
   # end of main loop.
   sub do_accept {
      my $listener = shift;
      my $newsock = $listener->accept or die "Error in accept: $!\n";
      $r->add($newsock);
      $callbacks{$newsock} = {
         fd => fileno($newsock),
         read_callback = \&read_command,
         input_buffer = "",
         write_callback = \&do_write,
         output_buffer = "",
         data_id => "",
         expire_at => (time() + 10),
         expire_callback => \&do_expire,
      };
      # but don't add $newsock to $w.
   }

   sub closeit {

      warn "Error $action socket: $!\n" if $e;
      $_->remove($client) for $r, $w;
      delete $callbacks{$client};
   }

   # ok, here's one more global variable.
   my %commands = map { no strict 'refs'; \&{"do_$_"} }
      qw(ANNC TIME STATUS QUIT LOGOFF);

   sub read_command {
      my $client = shift;
      my $buffer = \ $callbacks{$client}{input_buffer};
      my $n = sysread( $client, $$buffer, 8192, length $$buffer );
      $n or return closeit( $client, "reading from", defined $n );
      while( $$buffer =~ s/^((?s).*?)$CRLF// ) {
         my ($command, $data) = $1 =~ /^(\w*)(.*)/s;
         if( my $f = $commands{ uc $command } ) {
            $f->($client, $data);
            return if $f == \&do_QUIT or $f == \&do_LOGOFF;
         } else {
            my_print($client, "501 Command not recognized" . CRLF);
         }
      }
      $callbacks{$client}{expire_at} = time() + 10;
   }

   sub my_print {

      $callbacks{$client}{outgoing_buffer} .= $message;
      $w->add($client};
   }

   sub do_write {
      my $client = shift;
      my $buffer = \ $callbacks{$client}{outgoing_buffer};
      local $SIG{PIPE} = 'IGNORE';
      my $n = syswrite( $client, $$buffer )
         or return closeit($client, "writing to", 1);
      substr( $$buffer, 0, $n ) = "";
      $w->remove($client) unless length $$buffer;
      delete $callbacks{$client} unless $r->exists($client);
   }

   sub do_ANCC {

      my $data_id = \ $callbacks{$client}{data_id};
      $args = "" unless defined $args;
      if( length($args) and $$data_id eq $args ) {
         my_print( $client, "230 $data_id" . CRLF );
         return;
      }
      $$data_id = $args;
      my_print( $client, "231 $$data_id" . CRLF );



      }
      my_print( $client, "." . CRLF );
   }

   sub do_TIME {

      my_print($client, join("|", (localtime)[2,1,0,4,3,5] ) . CRLF );
   }

   sub do_STATUS {

      my_print($client, "220 1|HELLO" . CRLF );
   }

   sub do_QUIT { closeit( shift(), "", 0 ) }
   BEGIN { *do_LOGOFF = \&do_quit }

   sub do_expire {
      my $callback_key = shift;
      warn "Socket timed out\n";
      my $fd = $callbacks{$callback_key}{$fd};
      $_->remove($fd) for $r, $w;
      delete $callbacks{$callback_key};
   }

   __END__

This is typed off the top of my head, and quite untested.  But I think
that you get the idea, and perhaps more important, I think that this
*type* of program should be more understandable than that stuff you'd
had.

For a serious implementation, I would use a min-heap to keep track of
the timeouts.  In addition, each warn()ing that I output would include
some info such as the results of gethostbyaddr or inet_aton upon
$client->peeraddr... maybe include $client->peerport, too.

--
$..='(?:(?{local$^C=$^C|'.(1<<$_).'})|)'for+a..4;
$..='(?{print+substr"\n !,$^C,1 if $^C<26})(?!)';
$.=~s'!'haktrsreltanPJ,r  coeueh"';BEGIN{${"\cH"}
|=(1<<21)}""=~$.;qw(Just another Perl hacker,\n);



Tue, 31 May 2005 07:22:35 GMT  
 
 [ 3 post ] 

 Relevant Pages 

1. Opening/closing sockets

2. PERLFUNC: close - close file (or pipe or socket) handle

3. PERLFUNC: close - close file (or pipe or socket) handle

4. open() not closing open filehandle before reopening

5. Proper way to close an IO::Socket or IO::Socket::INET

6. Script for discerning US postal codes

7. Perlbug 20010213.008 status update open->closed but nothing else

8. Questions about $%, $=, $-, and write vs open and close

9. open() close() same file many times

10. regex match for same number of opening and closing brackets

11. Any reason not to use close() with open()?

12. open and close a program from Perl

 

 
Powered by phpBB® Forum Software