test for available data in filehandle

Question

For some reason I am implementing some specific network protocol similar to STOMP in plain pure Perl.

The connection can be either a direct network socket, or an SSL tunnel provided by openssl s_client created by a call to open3 (no IO::Socket::SSL available on the host).

Depending on the dialog a request to the server may or may not have a response, or may have multiple responses. How can I test the file descriptors for the existence of data? Currently when no data is available, it waits until the defined timeout.

EDIT : I have probably a vocabulary issue between file handle vs. file descriptor to perform my research. I just found that eof() may help but cannot use it correctly yet.

While it is a bit complicated to provide an SCCCE, here is the interesting parts of the code:

# creation of a direct socket connection 
sub connect_direct_socket {
    my ($host, $port) = @_;
    my $sock = new IO::Socket::INET(PeerAddr => $host,
                                    PeerPort => $port,
                                    Proto    => 'tcp') or die "Can't connect to $host:$port\n";
    $sock->autoflush(1);
    say STDERR "* connected to $host port $port" if $args{verbose} || $args{debug};
    
    return $sock, $sock, undef;
}

# for HTTPS, we are "cheating" by creating a tunnel with OpenSSL in s_client mode
my $tunnel_pid;
sub connect_ssl_tunnel {
    my ($dest) = @_;
    my ($host, $port);
    $host = $dest->{host};
    $port = $dest->{port};
    
    my $cmd = "openssl s_client -connect ${host}:${port} -servername ${host} -quiet";# -quiet -verify_quiet -partial_chain';
    $tunnel_pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $cmd);
    say STDERR "* connected via OpenSSL to $host:$port" if $args{verbose} || $args{debug};
    say STDERR "* command = $cmd" if $args{debug};

    $SIG{CHLD} = sub {
        print STDERR "* REAPER: status $? on ${tunnel_pid}\n" if waitpid($tunnel_pid, 0) > 0 && $args{debug};
    };
    return *CMD_IN, *CMD_OUT, *CMD_ERR;
}

# later
($OUT, $IN, $ERR) = connect_direct_socket($url->{host}, $url->{port});
# or
($OUT, $IN, $ERR) = connect_ssl_tunnel($url);

# then I am sending with a
print $OUT $request;
# and read the response with
my $selector = IO::Select->new();
$selector->add($IN);

FRAME:
while (my @ready = $selector->can_read($args{'max-wait'} || $def_max_wait)) {
    last unless @ready;
    foreach my $fh (@ready) {
        if (fileno($fh) == fileno($IN)) {
            my $buf_size = 1024 * 1024;
            my $block = $fh->sysread(my $buf, $buf_size);
            if($block){
                if ($buf =~ s/^\n*([^\n].*?)\n\n//s){
                    # process data here
                }
                if ($buf =~ s/^(.*?)\000\n*//s ){
                    goto EOR;
                    # next FRAME;
                }                }
            $selector->remove($fh) if eof($fh);
        }
    }
}
EOR:    

Answer 1

Do not use eof in conjunction with select (which can_read wraps). It performs a buffered read, which breaks select .

select will mark a handle as ready for reading when it reaches EOF, which is detected by sysread returning 0 .

Using a new buffer for every pass was a mistake. The following fixes this, and shows how to handle errors and EOF from sysread .

Globals:

my %clients_by_fd;

When you get a new connection:

$selector->add( $fh );
$clients_by_fd{ fileno( $fh ) } = {
   buf => "",
   # Any other info you want here.
};

Event loop:

while ( my @ready = $selector->can_read() ) {
   for my $fh ( @ready ) {
      my $client = $clients_by_fd{ fileno( $fh ) };

      my $buf_ref = \$client->{ buf };

      my $rv = sysread( $fh, $$buf_ref, 1024*1024, length( $$buf_ref ) );
      if ( !$rv ) {
         if ( defined( $rv ) {
            # EOF
            if ( length( $$buf_ref ) ) {
               warn( "Error reading: Incomplete message\n" );
            }
         } else {
            # Error
            warn( "Error reading: $!\n" );
         }

         $select->remove( $fh );
         delete $clients_by_fd{ fileno( $fh ) };
      }

      while ( $buf =~ s/^.*?\n\n//s ) {
         process_message( $client, $& );
      }
   }
}