[Mpls-pm] Perl Socket programming problem with Windows

Wed Aug 17 11:18:27 PDT 2005

Hello,

I'm writing a TCP Server program that polls waits for socket connections
on a specified port.  The connection will be coming from a "black box"
test harness written in C#.Net.  The connection hand-shake design is as
follow:

Black Box requests to connect to the Server
Server responds back with a "Challenge" with a hardcode string
"1001|1000"
The Black Box reads the Challenge, then returns another request as
"1001|1100"
The Server will then processes the second request.

On my Server end, I can start the server and wait for connections. When
the Client makes a request to the Server, the Server accepts the
connections, but I can't read the data being sent. When I attempt to
read the data stream on the Server, it wait about 5 seconds, then the
Client hangs. I'm using IO::Socket and IO::Select, and I've tried read,
recv, <>, Open(filehandle), all attempts result with the same error.

Here's my Server code:

use IO::Socket qw(:DEFAULT :crlf);
#use IO::Socket;
#use IO::Socket::INET;
use IO::Handle;
use IO::Select;
use POSIX;
use Socket;
use Fcntl;
use Tie::RefHash;
use Net::Socket::NonBlock;
local($/) = LF;

# Setup global variables
$ViewServer = "M:\\paul.krcma_csm_test\\PaulsTest\\release1";
#$ServerName = 'EPWS3001';
$ServerName = 'RCSLMN10L3CNMW6';
$port_num = '8003';
$ReqId = "1000";
$client = "";

# Create socket object
$server = IO::Socket::INET->new('LocalPort' => $port_num,
				   'Proto' => 'tcp',
				   'Type' => SOCK_STREAM,
				   'Block' => 0,
				   'Listen' => 16,
                                   'Reuse' => 1)
    or die "Can't create socket ($!)\n";

%inbuffer = ();
%outbuffer = ();
%ready = ();

tie %ready, 'Tie::RefHash';
#nonblock($server);

   # Create a new IO::Socket Object
$select = IO::Select->new;
$select->add($server);
#my $select->add($socket);          # Add a Listener to the IO::Socket
object

print "Server listening\n";

# Wait for incoming requests, and open new sockets when needed
while (1) {
  $client;
  $rv;
  $data;
  $sn;
  foreach $client ($select->can_read()) {
    print "Creating TCPSocketListener\n";
    print "Checking for client = server\n";
    if($client == $server) {
      #my $new;
      # Level 1 If
        # Create a new socket and add the handles to the Select object
        $client = $server->accept();
        $select->add($client);
        $client->autoflush(1);
        $client->blocking(false);
        $ClientName = gethostbyaddr($client->peeraddr, AF_INET);

        #print "data is $rv{$client}\n";
        #print "New Socket opened\n";
          #print "Generating RequestId and sending Challenge to back to
Core\n";
          $buffer = '';
          $rv = recv($client, $buffer, 1024,0);     ###########  This
line causes the Client to hang  ######################
          &Generate_ReqId($ReqId);
          #print "Req ID = $ReqId\n";
          print "Reading data\n";
          #$sn = $client->send($ReqId);
          #while(<$client>) {
          #  chop $_;
          #  $data = $_;
          #}
          print "Data received is $data\n";
         #$SendPack = $ReqId."|1000\015\012";
         #$sn = $client->send($SendPack);
          #$client "$ReqId|1000";

      #print "Inside level 1 if\n";
      #print "Authorizing user\n";
      #print $new "$ReqId|0|";
      print "Leaving the client-server loop\n";
    }
    else {
      # Fork the incoming connection from the parent
      print "A separate connection\n";
      print "Packet is $packet\n";
      #&process_connection;
      $data = '';
      $rv = $client->recv($data, POSIX::BUFSIZ, 0);
       unless (defined($rv) && length $data) {
          # Client disconnected so do some cleanup
          print "Going to delete the buffers\n";
          print $client "OK";
          delete $inbuffer{$client};
          delete $outbuffer{$client};
          delete $ready{$client};
          $select->remove($client);
          close $client;
          next;
       }
       $inbuffer{$client} .= $data;

        #print "    Existing Connection\n";
        #print "Received Authentication string from Core\n";
        #print $rv{$client};
        #print "Sending Authentication approval back to Core\n";
        #print $client "$ReqId|0|";
        #&process_connection;
      while ($inbuffer{$client} =~ s/(.*\n)//) {
        print "building array of requests\n";
        push( @{$ready{$client}}, $1 );
      }
    }
    print "Outside If\n";
  }
  # Any complete requests to process ?
  foreach $client (keys %ready) {
    print "Handling a request\n";
    handle($client);
  }

  # Buffers to flush ?
  foreach $client ($select->can_write(1)) {
    print "Flushing the buffers\n";
    #next unless exists $outbuffer{$client};
    print "Sending information to the outbuffer\n";
    $rv = $client->send($outbuffer{$client}, 0);
    unless (defined $rv) {
        warn "I can't write\n";
        next;
    }
    print "Reading the length of the outbuffer\n";
    if ($rv == length $outbuffer{$client} ||
    $! == POSIX::EWOULDBLOCK) {
      print "Doing some stuff with the outbuffer\n";
      substr($outbuffer{$client}, 0 , $rv) = '';
      delete $outbuffer{$client} unless length $outbuffer{$client};
    }
    else {
      print "Cleaning up the flush buffers\n";
      delete $inbuffer{$client};
      delete $outbuffer{$client};
      delete $read{$client};
      select->remove($client);
      close($client);
      next;
    }
    print "Leaving Flush Buffers\n";
    #$select->remove($client);               
    #close $client;                                    
  }
  print "Leaving the Listener\n";
  #close $client or die "Can't close ($!)\n";
} die "Can't accept socket ($!)\n";

sub Generate_ReqId($Rid) {
  $ReqId++;
  return $ReqId;
}

sub handle {
  my $client = shift;
  print "Inside the Handle sub $client\n";
  my $request;
  foreach $request (@{$ready{$client}}) {
    print "Inside the request for loop $request\n";
    # put the text of reply into the $outbuffer{$client}
    $outbuffer{$client} .= $request;
    $packet = $outbuffer{$client};
    print "Packet is $outbuffer{$client}\n";
  }
  delete $ready{$client};
}

sub process_connection {
  print "Inside process_connection\n";
  #print $client "$.: $_";
  $CoreReqId = "";
  $ReqType = "";
  $CNNum = "";
  $ProjId = "";
  $CdPack = "";
  $CdPackLoc = "";
  #my $ClientName = gethostbyaddr($socket->peeraddr, AF_INET);
  #my $port = $socket->peerport;
  #print "[$ClientName $port]\n";
  # Once a client has been accepted, print out the client information
and the packet it sent
  while (<$client>) {
    $packetname = $_;
    print "Packet is $_\n";
    #print "[$ClientName $port] $_";
    #print $client "$.: $_";
    # Parse the packet
    # NOTE: Don't chop the packet.  The return character needs to remain
imbedded in
    # the packet to return back to the client
    ($CoreRegId,$ReqType,$CNNum,$ProjId,$CdPack,$CdPackLoc) =
split(/\|/,$packetname);
    print "$CoreReqId, $ReqType $CNNum $ProjId $CdPack $CdPackLoc\n";
    # Chop the last entry of the split string and join the CdPackLoc
with CdPack
    chop $CdPackLoc;
    $NewElement = $CdPackLoc.$CdPack;
    #$EndTime = `echo %time%`;
    #print "End Time = $EndTime\n";
    $select->remove($client);
    $client->close;
  }
}

The programmer for the Black Box side assures me that he is not putting
any special end-of-line characters in his output string.  I'm at a total
loss for what is going on here. Any help would be appreciated.

Thanks,

Paul Krcma
CMI Client/Server (EISS)
612-316-3712

-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://mail.pm.org/pipermail/mpls-pm/attachments/20050817/ee9f3bc5/attachment-0001.html