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

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

Expand Messages
  • Randy Kobes
    ... [ ... ] ... [ ... ] ... [ ... ] I found that if I change that last line to last unless $cmd = getline($socket); then one can interrupt the telnet session
    Message 1 of 9 , Jul 31, 2005
    • 0 Attachment
      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
    • Stas Bekman
      ... 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
      Message 2 of 9 , 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
      • Randy Kobes
        ... [ ... ] ... Works great on Win32, without modification - thanks! -- best regards, randy
        Message 3 of 9 , Aug 15, 2005
        • 0 Attachment
          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
        Your message has been successfully submitted and would be delivered to recipients shortly.