The mod_perl protocol handler sample code have some problem!

Wed, 20 Jul 2005 12:14:03 -0700

The sample code have some problem. When i telnet then CommandServer in win32 everything is ok.
But if i close then console window(terminal)  immediate, the apache is hang. CPU use 100% resource.
 
I  try to use
$c->aborted()
OR
($@ == APR::Const::ECONNABORTED )
to check the connect but it can not  detect the client is disconnect.
 
How can i solve the problem?
 
ps: OS:WIN32   VERSION:APACHE/2.053  mod_perl/v2.01
    
 
 
  package MyApache::CommandServer;
 
  use strict;
  use warnings FATAL => 'all';
 
  use Apache2::Connection ();
  use Apache2::RequestUtil ();
  use Apache2::HookRun ();
  use Apache2::Access ();
  use APR::Socket ();
 
  use Apache2::Const -compile => qw(OK DONE DECLINED);
 
  my @cmds = qw(motd date who quit);
  my %commands = map { $_, \&{$_} } @cmds;
 
  sub handler {
      my $c = shift;
      my $socket = $c->client_socket;
 
      if ((my $rc = login($c)) != Apache2::Const::OK) {
          $socket->send("Access Denied\n");
          return $rc;
      }
 
      $socket->send("Welcome to " . __PACKAGE__ .
                    "\nAvailable commands: @cmds\n");
 
      while (1) {
          my $cmd;
          next unless $cmd = getline($socket);
 
          if (my $sub = $commands{$cmd}) {
              last unless $sub->($socket) == Apache2::Const::OK;
          }
          else {
              $socket->send("Commands: @cmds\n");
          }
      }
 
      return Apache2::Const::OK;
  }
 
  sub login {
      my $c = shift;
 
      my $r = Apache2::RequestRec->new($c);
      $r->location_merge(__PACKAGE__);
 
      for my $method (qw(run_access_checker run_check_user_id
                         run_auth_checker)) {
          my $rc = $r->$method();
 
          if ($rc != Apache2::Const::OK and $rc != Apache2::Const::DECLINED) {
              return $rc;
          }
 
          last unless $r->some_auth_required;
 
          unless ($r->user) {
              my $socket = $c->client_socket;
              my $username = prompt($socket, "Login");
              my $password = prompt($socket, "Password");
 
              $r->set_basic_credentials($username, $password);
          }
      }
 
      return Apache2::Const::OK;
  }
 
  sub getline {
      my $socket = shift;
 
      my $line;
      $socket->recv($line, 1024);
      return unless $line;
      $line =~ s/[\r\n]*$//;
 
      return $line;
  }
 
  sub prompt {
      my($socket, $msg) = @_;
 
      $socket->send("$msg: ");
      getline($socket);
  }
 
  sub motd {
      my $socket = shift;
 
      open my $fh, '/etc/motd' or return;
      local $/;
      $socket->send(scalar <$fh>);
      close $fh;
 
      return Apache2::Const::OK;
  }
 
  sub date {
      my $socket = shift;
 
      $socket->send(scalar(localtime) . "\n");
 
      return Apache2::Const::OK;
  }
 
  sub who {
      my $socket = shift;
 
      # make -T happy
      local $ENV{PATH} = "/bin:/usr/bin";
 
      $socket->send(scalar `who`);
 
      return Apache2::Const::OK;
  }
 
  sub quit { Apache2::Const::DONE }
 
  1;
  __END__

Reply via email to