perl-modperl mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From "LUKE" <l...@tc.program.com.tw>
Subject Tesing Protocol Handlers got strange result!
Date Sat, 18 Feb 2006 06:25:07 GMT
Then code is from http://perl.apache.org/docs/2.0/user/handlers/protocols.html Command Server.
When i start to test. It will not response Welcome Message until i type enter. Why?

The FTP Server or SMTP Server will response Welcome Message first. If i want to implement
those protocol using Apache2's Protocol Handlers. It will fail.

PS. You can connect telnet se2.program.com.tw 25 to testing the program.
PS. linux(Red Hat) + apache2.0.55 + mod_perlv2.02 + perl 5.8.7


package TestPH;

  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;
          }
      }
  
      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__
  
Mime
View raw message