Re: The mod_perl protocol handler sample code have some problem!

[Randy Kobes <ra...@theoryx5.uwinnipeg.ca>]

On Sun, 31 Jul 2005, Randy Kobes wrote:

> On Sun, 31 Jul 2005, Randy Kobes wrote:
[ ... ]
> Here's a scaled-down version of the problem - I used
> commands with single letters, as my Win32 console sent a \r\n after each 
> letter.
[ ... ]
> sub handler {
>  my $c = shift;
>  $| = 1;
>  my $socket = $c->client_socket;
>  $socket->opt_set(APR::Const::SO_NONBLOCK, 0);
>
>  $socket->send("Welcome to " . __PACKAGE__ .
>                "\r\nAvailable commands: @cmds\r\n");
>
>  while (1) {
>    my $cmd;
>    next unless $cmd = getline($socket);
[ ... ]
I found that if I change that last line to
      last unless $cmd = getline($socket);
then one can interrupt the telnet session with 'CTRL ]'
and close the connection without the Apache process
consuming 100% cpu.

-- 
best regards,
randy

Re: The mod_perl protocol handler sample code have some problem!

[Randy Kobes <ra...@theoryx5.uwinnipeg.ca>]

On Fri, 12 Aug 2005, Stas Bekman wrote:

> OK, I wrote a test case that reproduces the problem.
>
> If you run:
>
> perl Makefile.PL
> make test
>
> things work, but if you do:
>
> t/TEST -start
> t/TEST -run
>
> the process starts spinning in the getline() call, as $sock->recv doesn't 
> fail.
[ ... ]
> Here is a rewrite that doesn't spin. Notice that I've 
> dropped the $c-aborted check, I don't know if it's needed, 
> since recv() should have caught that anyway. But please 
> restore it if needed.

Works great on Win32, without modification - thanks!

-- 
best regards,
randy

Re: The mod_perl protocol handler sample code have some problem!

[Stas Bekman <st...@stason.org>]

Randy Kobes wrote:
> On Sun, 31 Jul 2005, Randy Kobes wrote:
> 
>> On Sun, 31 Jul 2005, Randy Kobes wrote:
> 
> [ ... ]
> 
>> Here's a scaled-down version of the problem - I used
>> commands with single letters, as my Win32 console sent a \r\n after 
>> each letter.
> 
> [ ... ]
> 
>> sub handler {
>>  my $c = shift;
>>  $| = 1;
>>  my $socket = $c->client_socket;
>>  $socket->opt_set(APR::Const::SO_NONBLOCK, 0);
>>
>>  $socket->send("Welcome to " . __PACKAGE__ .
>>                "\r\nAvailable commands: @cmds\r\n");
>>
>>  while (1) {
>>    my $cmd;
>>    next unless $cmd = getline($socket);
> 
> [ ... ]
> I found that if I change that last line to
>      last unless $cmd = getline($socket);
> then one can interrupt the telnet session with 'CTRL ]'
> and close the connection without the Apache process
> consuming 100% cpu.

OK, I wrote a test case that reproduces the problem.

If you run:

perl Makefile.PL
make test

things work, but if you do:

t/TEST -start
t/TEST -run

the process starts spinning in the getline() call, as $sock->recv doesn't 
fail. This is our "bug", well it was supposed to be a feature as the 
internals are going as:

     rc = apr_socket_recv(socket, SvPVX(buffer), &len);

     if (!(rc == APR_SUCCESS || rc == APR_EOF)) {
         modperl_croak(aTHX_ rc, "APR::Socket::recv");
     }

So if recv has returned EOF, the call was always successful. So basically 
we eat the EOF event and user tries to read again and again.

I think as long as we are in the blocking mode that approach is fine, i.e.:

- if $sock->recv was successful:
    * if you received some string, you are good
    * if you received nothing, that means you've got EOF
- otherwise handle the error

and that getline code doesn't seem to do the right thing anyway, since it 
may return an error code but the caller expects a string.

Here is a rewrite that doesn't spin. Notice that I've dropped the 
$c-aborted check, I don't know if it's needed, since recv() should have 
caught that anyway. But please restore it if needed.

package MyTest::Protocol;

use strict;
use warnings FATAL => 'all';

use Apache2::Connection ();
use APR::Socket ();
use APR::Status ();

use Apache2::Const -compile => qw(OK DONE DECLINED);
use APR::Const     -compile => qw(SO_NONBLOCK);

my @cmds = qw(d q);
my %commands = map { $_, \&{$_} } @cmds;

sub handler {
     my $c = shift;
     $| = 1;
     my $socket = $c->client_socket;

     $socket->opt_set(APR::Const::SO_NONBLOCK, 0);

     $socket->send("Welcome to " . __PACKAGE__ .
                   "\r\nAvailable commands: @cmds\r\n");

     while (1) {
         my $cmd;
         eval {
             $cmd = getline($socket);
         };
         if ($@) {
             return Apache2::Const::DONE if APR::Status::is_ECONNABORTED($@);
         }

         last unless defined $cmd; # EOF

         next unless length $cmd;  # new line with no commands

         warn "READ: $cmd\n";

         if (my $sub = $commands{$cmd}) {
             last unless $sub->($socket) == Apache2::Const::OK;
         } else {
             $socket->send("Commands: @cmds\r\n");
         }
     }

     return Apache2::Const::OK;
}

# returns either of:
# - undef on EOF
# - CRLF stripped line on normal read
#
# may throw an exception (via recv())
sub getline {
     my $socket = shift;
     $socket->recv(my $line, 1024);
     return undef unless length $line;
     $line =~ s/[\r\n]*$//;
     return $line;
}

sub d {
     my $socket = shift;
     $socket->send(scalar(localtime) . "\r\n");
     return Apache2::Const::OK;
}

sub q { Apache2::Const::DONE }

1;
__END__

<NoAutoConfig>
<VirtualHost MyTest::Protocol>
     PerlProcessConnectionHandler MyTest::Protocol
     <Location MyTest__Protocol>
         Order Deny,Allow
         Allow from all
     </Location>
</VirtualHost>
</NoAutoConfig>


-- 
__________________________________________________________________
Stas Bekman            JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/     mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org   http://ticketmaster.com