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__ |
- The mod_perl protocol handler sample code have some problem! 薛共和
- Re: The mod_perl protocol handler sample code have some p... Randy Kobes
- Re: The mod_perl protocol handler sample code have so... LUKE
- Re: The mod_perl protocol handler sample code hav... Stas Bekman
- Re: The mod_perl protocol handler sample code... Randy Kobes
- Re: The mod_perl protocol handler sample... Randy Kobes
- Re: The mod_perl protocol handler sa... Randy Kobes
- Re: The mod_perl protocol handle... Stas Bekman
- Re: The mod_perl protocol handle... Randy Kobes