[BACK]Return to lonc CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/Attic/lonc between versions 1.34 and 1.38

version 1.34, 2002/03/20 03:44:11 version 1.38, 2002/04/04 22:04:54
Line 314  unless ( Line 314  unless (
 %inbuffer  = ();  %inbuffer  = ();
 %outbuffer = ();  %outbuffer = ();
 %ready     = ();  %ready     = ();
   %servers   = (); # To be compatible with make filevector.  indexed by
    # File ids, values are sockets.
    # note that the accept socket is omitted.
   
 tie %ready, 'Tie::RefHash';  tie %ready, 'Tie::RefHash';
   
 nonblock($server);  # nonblock($server);
 $select = IO::Select->new($server);  # $select = IO::Select->new($server);
   
 # Main loop: check reads/accepts, check writes, check ready to process  # Main loop: check reads/accepts, check writes, check ready to process
   
   status("Main loop");
 while (1) {  while (1) {
     my $client;      my $client;
     my $rv;      my $rv;
     my $data;      my $data;
   
     # check for new information on the connections we have      my $infdset; # bit vec of fd's to select on input.
   
     # anything to read or accept?      my $outfdset; # Bit vec of fd's to select on output.
   
     foreach $client ($select->can_read(00.10)) {  
         if ($client == $server) {  
             # accept a new connection  
             &status("Accept new connection: $conserver");  
             $client = $server->accept();  
             $select->add($client);  
             nonblock($client);  
         } else {  
             # read data  
             $data = '';  
             $rv   = $client->recv($data, POSIX::BUFSIZ, 0);  
   
             unless (defined($rv) && length $data) {  
                 # This would be the end of file, so close the client  
                 delete $inbuffer{$client};  
                 delete $outbuffer{$client};  
                 delete $ready{$client};  
   
                 &status("Idle");  
                 $select->remove($client);  
                 close $client;  
                 next;  
             }  
   
             $inbuffer{$client} .= $data;      $infdset = MakeFileVector(\%servers);
       $outfdset= MakeFileVector(\%outbuffer);
       vec($infdset, $server->fileno, 1) = 1;
       if($DEBUG) {
    &logthis("Adding ".$server->fileno.
    " to input select vector (listner)".
    unpack("b*",$infdset)."\n");
       }
       DoSelect(\$infdset, \$outfdset); # Wait for input.
       if($DEBUG) {
    &logthis("Doselect completed!");
    &logthis("ins = ".unpack("b*",$infdset)."\n");
    &logthis("outs= ".unpack("b*",$outfdset)."\n");
     
       }
   
       # Checkfor new connections:
       if (vec($infdset, $server->fileno, 1)) {
    if($DEBUG) {
       &logthis("New connection established");
    }
    # accept a new connection
    &status("Accept new connection: $conserver");
    $client = $server->accept();
    if($DEBUG) {
       &logthis("New client fd = ".$client->fileno."\n");
    }
    $servers{$client->fileno} = $client;
    nonblock($client);
       }
       HandleInput($infdset, \%servers, \%inbuffer, \%outbuffer, \%ready);
       HandleOutput($outfdset, \%servers, \%outbuffer, \%inbuffer,
    \%ready);
   # -------------------------------------------------------- Wow, connection lost
   
             # test whether the data in the buffer or the data we  }
             # just read means there is a complete request waiting     
             # to be fulfilled.  If there is, set $ready{$client}  
             # to the requests waiting to be fulfilled.  
             while ($inbuffer{$client} =~ s/(.*\n)//) {  
                 push( @{$ready{$client}}, $1 );  
             }  
         }  
     }      }
       }
     # Any complete requests to process?  
     foreach $client (keys %ready) {  # ------------------------------------------------------- End of make_new_child
         handle($client);  
   
   #
   #  Make a vector of file descriptors to wait for in a select.
   #  parameters:
   #     \%fdhash  -reference to a hash which has IO::Socket's as indices.  
   #                We only care about the indices, not the values.
   #  A select vector is created from all indices of the hash.
   
   sub MakeFileVector
   {
       my $fdhash = shift;
       my $selvar = "";
   
       foreach $socket (keys %$fdhash) {
    if($DEBUG) {
       &logthis("Adding  ".$socket.
        "to select vector. (client)\n");
    }
    vec($selvar, $socket, 1) = 1;
     }      }
        return $selvar;
     # Buffers to flush?  }
     foreach $client ($select->can_write(1)) {  
         # Skip this client if we have nothing to say  
         next unless exists $outbuffer{$client};  
   
         $rv = $client->send($outbuffer{$client}, 0);  
   
       unless ($outbuffer{$client} eq "con_lost\n") {  
         unless (defined $rv) {  
             # Whine, but move on.  
             &logthis("I was told I could write, but I can't.\n");  
             next;  
         }  
         $errno=$!;  
         if (($rv == length $outbuffer{$client}) ||  
             ($errno == POSIX::EWOULDBLOCK) || ($errno == 0)) {  
             substr($outbuffer{$client}, 0, $rv) = '';  
             delete $outbuffer{$client} unless length $outbuffer{$client};  
         } else {  
             # Couldn't write all the data, and it wasn't because  
             # it would have blocked.  Shutdown and move on.  
   
     &logthis("Dropping data with ".$errno.": ".  
                      length($outbuffer{$client}).", $rv");  
   
             delete $inbuffer{$client};  #
             delete $outbuffer{$client};  #  HandleOutput:
             delete $ready{$client};  #    Processes output on a buffered set of file descriptors which are
   #    ready to be read.
             $select->remove($client);  #  Parameters:
             close($client);  #    $selvector - Vector of file descriptors which are writable.
             next;  #    \%sockets  - Vector of socket references indexed by socket.
         }  #    \%buffers  - Reference to a hash containing output buffers.
       } else {  #                 Hashes are indexed by sockets.  The file descriptors of some
 # -------------------------------------------------------- Wow, connection lost  #                 of those sockets will be present in $selvector.
          &logthis(  #                 For each one of those, we will attempt to write the output
      "<font color=red>CRITICAL: Closing connection</font>");  #                 buffer to the socket.  Note that we will assume that
  &status("Connection lost");  #                 the sockets are being run in non blocking mode.
          $remotesock->shutdown(2);  #   \%inbufs    - Reference to hash containing input buffers.
          &logthis("Attempting to open new connection");  #   \%readys    - Reference to hash containing flags for items with complete
          &openremote($conserver);            #                 requests.
       }  #
   sub HandleOutput
   {
       my $selvector = shift;
       my $sockets   = shift;
       my $buffers   = shift;
       my $inbufs    = shift;
       my $readys    = shift;
       my $sock;
   
       if($DEBUG) {
    &logthis("HandleOutput entered\n");
     }      }
      
       foreach $sock (keys %$sockets) {
    my $socket = $sockets->{$sock};
    if(vec($selvector, $sock, 1)) { # $socket is writable.
       if($DEBUG) {
    &logthis("Sending $buffers->{$sock} \n");
       }
       my $rv = $socket->send($buffers->{$sock}, 0);
       $errno = $!;
       unless ($buffers->{$sock} eq "con_lost\n") {
    unless (defined $rv) { # Write failed... could be EINTR
       unless ($errno == POSIX::EINTR) {
    &logthis("Write failed on writable socket");
       } # EINTR is not an error .. just retry.
       next;
    }
    if( ($rv == length $buffers->{$sock})    ||
       ($errno == POSIX::EWOULDBLOCK)       ||
       ($errno == POSIX::EAGAIN)            || # same as above.
       ($errno == POSIX::EINTR)             || # signal during IO
       ($errno == 0)) {
       substr($buffers->{$sock}, 0, $rv)=""; # delete written part
       delete $buffers->{$sock} unless length $buffers->{$sock};
    } else {
       # For some reason the write failed with an error code
       # we didn't look for.  Shutdown the socket.
       &logthis("Unable to write data with ".$errno.": ".
        "Dropping data: ".length($buffers->{$sock}).
        ", $rv");
       #
       # kill off the buffers in the hash:
   
       delete $buffers->{$sock};
       delete $inbufs->{$sock};
       delete $readys->{$sock};
   
       close($socket); # Close the client socket.
       next;
    }
       } else { # Kludgy way to mark lond connection lost.
    &logthis(
    "<font color=red>CRITICAL lond connection lost</font>");
    status("Connection lost");
    $remotesock->shutdown(2);
    &logthis("Attempting to open a new connection");
    &openremote($conserver);
       }
      
    }
       }
   
 }  }
   #
   #   HandleInput - Deals with input on client sockets.
   #                 Each socket has an associated input buffer.
   #                 For each readable socket, the currently available
   #                 data is appended to this buffer.
   #                 If necessary, the buffer is created.
   #                 On various failures, we may shutdown the client.
   #  Parameters:
   #     $selvec   - Vector of readable sockets.
   #     \%sockets - Refers to the  Hash of sockets indexed by sockets.  
   #                 Each of these may or may not have it's fd bit set 
   #                 in the $selvec.
   #     \%ibufs   - Refers to the hash of input buffers indexed by socket.
   #     \%obufs   - Hash of output buffers indexed by socket. 
   #     \%ready   - Hash of ready flags indicating the existence of a completed
   #                 Request.
   sub HandleInput 
   {
   
       # Marshall the parameters.   Note that the hashes are actually
       # references not values.
   
       my $selvec  = shift;
       my $sockets = shift;
       my $ibufs   = shift;
       my $obufs   = shift;
       my $ready   = shift;
       my $sock;
   
       if($DEBUG) {
    &logthis("Entered HandleInput\n");
       }
       foreach $sock (keys %$sockets) {
    my $socket = $sockets->{$sock};
    if(vec($selvec, $sock, 1)) { # Socket which is readable.
   
       #  Attempt to read the data and do error management.
       my $data = '';
       my $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
       if($DEBUG) {
    &logthis("Received $data from socket");
       }
       unless (defined($rv) && length $data) {
   
    # Read an end of file.. this is a disconnect from the peer.
   
    delete $sockets->{$sock};
    delete $ibufs->{$sock};
    delete $obufs->{$sock};
    delete $ready->{$sock};
   
    status("Idle");
    close $socket;
    next;
       }
       #  Append the read data to the input buffer. If the buffer
       # now contains a \n the request is complete and we can 
       # mark this in the $ready hash (one request for each \n.)
   
       $ibufs->{$sock} .= $data;
       while($ibufs->{$sock} =~ s/(.*\n)//) {
    push(@{$ready->{$sock}}, $1);
       }
       
    }
       }
       #  Now handle any requests which are ready:
   
       foreach $client (keys %ready) {
    handle($client);
       }
 }  }
   
 # ------------------------------------------------------- End of make_new_child  # DoSelect:  does a select with no timeout.  On signal (errno == EINTR), 
   #            the select is retried until there are items in the returned
   #            vectors.  
   #
   # Parameters:
   #   \$readvec   - Reference to a vector of file descriptors to 
   #                 check for readability.
   #   \$writevec  - Reference to a vector of file descriptors to check for
   #                 writability.
   #  On exit, the referents are modified with vectors indicating which 
   #  file handles are readable/writable.
   #
   sub DoSelect {
       my $readvec = shift;
       my $writevec= shift;
       my $outs;
       my $ins;
   
       while (1) {
    my $nfds = select( $ins = $$readvec, $outs = $$writevec, undef, undef);
    if($nfds) {
       if($DEBUG) {
    &logthis("select exited with ".$nfds." fds\n");
    &logthis("ins = ".unpack("b*",$ins).
    " readvec = ".unpack("b*",$$readvec)."\n");
    &logthis("outs = ".unpack("b*",$outs).
    " writevec = ".unpack("b*",$$writevec)."\n");
       }
       $$readvec  = $ins;
       $$writevec = $outs;
       return;
    } else {
       if($DEBUG) {
    &logthis("Select exited with no bits set in mask\n");
       }
       die "Select failed" unless $! == EINTR;
    }
       }
   }
   
 # handle($socket) deals with all pending requests for $client  # handle($socket) deals with all pending requests for $client
   #
 sub handle {  sub handle {
     # requests are in $ready{$client}      # requests are in $ready{$client}
     # send output to $outbuffer{$client}      # send output to $outbuffer{$client}
Line 505  sub handle { Line 681  sub handle {
     }      }
 }  }
 # ---------------------------------------------------------- End make_new_child  # ---------------------------------------------------------- End make_new_child
 }  
   
 # nonblock($socket) puts socket into nonblocking mode  # nonblock($socket) puts socket into nonblocking mode
 sub nonblock {  sub nonblock {
Removed from v.1.34  
changed lines
  Added in v.1.38

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>