package Catalyst::Engine::HTTP;
-use strict;
-use base 'Catalyst::Engine::CGI';
+use Moose;
+extends 'Catalyst::Engine::CGI';
use Data::Dump qw(dump);
use Errno 'EWOULDBLOCK';
use HTTP::Date ();
use HTTP::Headers;
use HTTP::Status;
-use NEXT;
use Socket;
use IO::Socket::INET ();
use IO::Select ();
my $protocol = $c->request->protocol;
my $status = $c->response->status;
my $message = status_message($status);
-
+ my $res_headers = $c->response->headers;
+
my @headers;
push @headers, "$protocol $status $message";
-
- $c->response->headers->header( Date => HTTP::Date::time2str(time) );
- $c->response->headers->header( Status => $status );
-
+
+ $res_headers->header( Date => HTTP::Date::time2str(time) );
+ $res_headers->header( Status => $status );
+
# Should we keep the connection open?
my $connection = $c->request->header('Connection');
- if ( $self->{options}->{keepalive}
- && $connection
+ if ( $self->{options}->{keepalive}
+ && $connection
&& $connection =~ /^keep-alive$/i
) {
- $c->response->headers->header( Connection => 'keep-alive' );
+ $res_headers->header( Connection => 'keep-alive' );
$self->{_keepalive} = 1;
}
else {
- $c->response->headers->header( Connection => 'close' );
+ $res_headers->header( Connection => 'close' );
}
-
- push @headers, $c->response->headers->as_string("\x0D\x0A");
-
+
+ push @headers, $res_headers->as_string("\x0D\x0A");
+
# Buffer the headers so they are sent with the first write() call
# This reduces the number of TCP packets we are sending
$self->{_header_buf} = join("\x0D\x0A", @headers, '');
=cut
-sub finalize_read {
- my ( $self, $c ) = @_;
-
+before finalize_read => sub {
# Never ever remove this, it would result in random length output
# streams if STDIN eq STDOUT (like in the HTTP engine)
*STDIN->blocking(1);
-
- return $self->NEXT::finalize_read($c);
-}
+};
=head2 $self->prepare_read($c)
=cut
-sub prepare_read {
- my ( $self, $c ) = @_;
-
+befpre prepare_read => sub {
# Set the input handle to non-blocking
*STDIN->blocking(0);
-
- return $self->NEXT::prepare_read($c);
-}
+};
=head2 $self->read_chunk($c, $buffer, $length)
sub read_chunk {
my $self = shift;
my $c = shift;
-
+
# If we have any remaining data in the input buffer, send it back first
if ( $_[0] = delete $self->{inputbuf} ) {
my $read = length( $_[0] );
=cut
-sub write {
+around write => sub {
+ my $orig = shift;
my ( $self, $c, $buffer ) = @_;
-
+
# Avoid 'print() on closed filehandle Remote' warnings when using IE
return unless *STDOUT->opened();
if ( my $headers = delete $self->{_header_buf} ) {
$buffer = $headers . $buffer;
}
-
- my $ret = $self->NEXT::write( $c, $buffer );
-
+
+ my $ret = $self->$orig( $c, $buffer );
+
if ( !defined $ret ) {
$self->{_write_error} = $!;
DEBUG && warn "write: Failed to write response ($!)\n";
else {
DEBUG && warn "write: Wrote response ($ret bytes)\n";
}
-
+
return $ret;
-}
+};
=head2 run
my ( $self, $class, $port, $host, $options ) = @_;
$options ||= {};
-
+
$self->{options} = $options;
if ($options->{background}) {
}
my $pid = undef;
-
+
# Ignore broken pipes as an HTTP server should
local $SIG{PIPE} = 'IGNORE';
-
+
# Restart on HUP
- local $SIG{HUP} = sub {
+ local $SIG{HUP} = sub {
$restart = 1;
warn "Restarting server on SIGHUP...\n";
};
-
+
LISTEN:
while ( !$restart ) {
- while ( accept( Remote, $daemon ) ) {
+ while ( accept( Remote, $daemon ) ) {
DEBUG && warn "New connection\n";
select Remote;
Remote->blocking(1);
-
+
# Read until we see all headers
$self->{inputbuf} = '';
-
+
if ( !$self->_read_headers ) {
# Error reading, give up
close Remote;
}
my ( $method, $uri, $protocol ) = $self->_parse_request_line;
-
- next unless $method;
-
+
DEBUG && warn "Parsed request: $method $uri $protocol\n";
+ next unless $method;
unless ( uc($method) eq 'RESTART' ) {
# Fork
- if ( $options->{fork} ) {
+ if ( $options->{fork} ) {
if ( $pid = fork ) {
DEBUG && warn "Forked child $pid\n";
next;
}
$self->_handler( $class, $port, $method, $uri, $protocol );
-
+
if ( my $error = delete $self->{_write_error} ) {
close Remote;
-
+
if ( !defined $pid ) {
next LISTEN;
}
close Remote;
}
}
-
+
$daemon->close;
-
+
DEBUG && warn "Shutting down\n";
if ($restart) {
### those include dirs upon re-exec. So add them to PERL5LIB, so they
### are available again for the exec'ed process --kane
use Config;
- $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
-
+ $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
+
exec $^X, $0, @{ $options->{argv} };
}
my $sel = IO::Select->new;
$sel->add( \*STDIN );
-
+
REQUEST:
while (1) {
my ( $path, $query_string ) = split /\?/, $uri, 2;
-
+
# Initialize CGI environment
local %ENV = (
PATH_INFO => $path || '',
# Pass flow control to Catalyst
$class->handle_request;
-
+
DEBUG && warn "Request done\n";
-
+
# Allow keepalive requests, this is a hack but we'll support it until
# the next major release.
if ( delete $self->{_keepalive} ) {
-
+
DEBUG && warn "Reusing previous connection for keep-alive request\n";
-
- if ( $sel->can_read(1) ) {
+
+ if ( $sel->can_read(1) ) {
if ( !$self->_read_headers ) {
# Error reading, give up
last REQUEST;
}
( $method, $uri, $protocol ) = $self->_parse_request_line;
-
+
DEBUG && warn "Parsed request: $method $uri $protocol\n";
-
+
# Force HTTP/1.0
$protocol = '1.0';
-
+
next REQUEST;
}
-
+
DEBUG && warn "No keep-alive request within 1 second\n";
}
-
+
last REQUEST;
}
-
+
DEBUG && warn "Closing connection\n";
close Remote;
sub _read_headers {
my $self = shift;
-
+
while (1) {
my $read = sysread Remote, my $buf, CHUNKSIZE;
-
+
if ( !defined $read ) {
next if $! == EWOULDBLOCK;
DEBUG && warn "Error reading headers: $!\n";
return;
- }
- elsif ( $read == 0 ) {
+ } elsif ( $read == 0 ) {
DEBUG && warn "EOF\n";
return;
}
-
+
DEBUG && warn "Read $read bytes\n";
$self->{inputbuf} .= $buf;
last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s;
}
-
+
return 1;
}
sub _parse_request_line {
my $self = shift;
- # Parse request line
+ # Parse request line
if ( $self->{inputbuf} !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) {
return ();
}
-
+
my $method = $1;
my $uri = $2;
my $proto = $3 || 'HTTP/0.9';
-
+
return ( $method, $uri, $proto );
}
sub _parse_headers {
my $self = shift;
-
+
# Copy the buffer for header parsing, and remove the header block
# from the content buffer.
my $buf = $self->{inputbuf};
$self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s;
-
+
# Parse headers
my $headers = HTTP::Headers->new;
my ($key, $val);
}
}
$headers->push_header( $key, $val ) if $key;
-
+
DEBUG && warn "Parsed headers: " . dump($headers) . "\n";
# Convert headers into ENV vars
$headers->scan( sub {
my ( $key, $val ) = @_;
-
+
$key = uc $key;
$key = 'COOKIE' if $key eq 'COOKIES';
$key =~ tr/-/_/;
$key = 'HTTP_' . $key
unless $key =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
-
+
if ( exists $ENV{$key} ) {
$ENV{$key} .= ", $val";
}
my ( $self, $handle ) = @_;
my $remote_sockaddr = getpeername($handle);
- my ( undef, $iaddr ) = $remote_sockaddr
- ? sockaddr_in($remote_sockaddr)
+ my ( undef, $iaddr ) = $remote_sockaddr
+ ? sockaddr_in($remote_sockaddr)
: (undef, undef);
-
+
my $local_sockaddr = getsockname($handle);
my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
# This mess is necessary to keep IE from crashing the server
my $data = {
- peername => $iaddr
+ peername => $iaddr
? ( gethostbyaddr( $iaddr, AF_INET ) || 'localhost' )
: 'localhost',
- peeraddr => $iaddr
+ peeraddr => $iaddr
? ( inet_ntoa($iaddr) || '127.0.0.1' )
: '127.0.0.1',
localname => gethostbyaddr( $localiaddr, AF_INET ) || 'localhost',
projects / catagits/Catalyst-Runtime.git / blobdiff