Loading ...
Sorry, an error occurred while loading the content.

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

Expand Messages
  • Stas Bekman
    Aug 12, 2005
    • 0 Attachment
      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@... http://use.perl.org http://apacheweek.com
      http://modperlbook.org http://apache.org http://ticketmaster.com
    • Show all 9 messages in this topic