X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FHTTP.pm;h=97cd8d618abc6a4ba56274351fd4a499f407a100;hb=c6d27fac181281525ebd34df2a1fb81beaa11698;hp=c3981bb78a919f47b02c99bf1dac66f3ef7da25b;hpb=60f8e66a2a70d94b3fdec7553a0327512fb08259;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index c3981bb..97cd8d6 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -12,19 +12,15 @@ use Socket; use IO::Socket::INET (); use IO::Select (); -# For PAR -require Catalyst::Engine::HTTP::Restarter; -require Catalyst::Engine::HTTP::Restarter::Watcher; - use constant CHUNKSIZE => 64 * 1024; use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0; +use namespace::clean -except => 'meta'; + has options => ( is => 'rw' ); has _keepalive => ( is => 'rw', predicate => '_is_keepalive', clearer => '_clear_keepalive' ); has _write_error => ( is => 'rw', predicate => '_has_write_error' ); -use namespace::clean -except => [qw/meta/]; - # Refactoring note - could/should Eliminate all instances of $self->{inputbuf}, # which I haven't touched as it is used as an lvalue in a lot of places, and I guess # doing it differently could be expensive.. Feel free to refactor and NYTProf :) @@ -72,8 +68,9 @@ sub finalize_headers { # Should we keep the connection open? my $connection = $c->request->header('Connection'); - if ( $self->options->{keepalive} - && $connection + if ( $self->options + && $self->options->{keepalive} + && $connection && $connection =~ /^keep-alive$/i ) { $res_headers->header( Connection => 'keep-alive' ); @@ -116,7 +113,7 @@ before prepare_read => sub { 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] ); @@ -158,11 +155,16 @@ around write => sub { # Prepend the headers if they have not yet been sent if ( $self->_has_header_buf ) { - $buffer = $self->_clear_header_buf . $buffer; + $self->_warn_on_write_error( + $self->$orig($c, $self->_clear_header_buf) + ); } - my $ret = $self->$orig($c, $buffer); + $self->_warn_on_write_error($self->$orig($c, $buffer)); +}; +sub _warn_on_write_error { + my ($self, $ret) = @_; if ( !defined $ret ) { $self->_write_error($!); DEBUG && warn "write: Failed to write response ($!)\n"; @@ -170,9 +172,8 @@ around write => sub { else { DEBUG && warn "write: Wrote response ($ret bytes)\n"; } - return $ret; -}; +} =head2 run @@ -339,7 +340,7 @@ sub run { use Config; $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; - exec $^X, $0, @{ $options->{argv} }; + exec $^X, $0, @{ $options->{argv} || [] }; } exit; @@ -359,11 +360,14 @@ sub _handler { my $sel = IO::Select->new; $sel->add( \*STDIN ); - + REQUEST: while (1) { my ( $path, $query_string ) = split /\?/, $uri, 2; - + + # URI is not the same as path. Remove scheme, domain name and port from it + $path =~ s{^https?://[^/?#]+}{}; + # Initialize CGI environment local %ENV = ( PATH_INFO => $path || '', @@ -388,40 +392,40 @@ sub _handler { # this far out, but then again it's only the dev server anyway. local $SIG{CHLD} = 'DEFAULT'; - $class->handle_request; + $class->handle_request( env => \%ENV ); } - + DEBUG && warn "Request done\n"; - + # Allow keepalive requests, this is a hack but we'll support it until # the next major release. if ( $self->_is_keepalive ) { $self->_clear_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; @@ -493,19 +497,19 @@ sub _parse_headers { } } $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"; } @@ -519,28 +523,34 @@ sub _socket_data { 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 = { - peeraddr => $iaddr + peeraddr => $iaddr ? ( inet_ntoa($iaddr) || '127.0.0.1' ) : '127.0.0.1', - localname => gethostbyaddr( $localiaddr, AF_INET ) || 'localhost', + localname => _gethostbyaddr( $localiaddr ), localaddr => inet_ntoa($localiaddr) || '127.0.0.1', }; return $data; } -sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } +{ # If you have a crappy DNS server then these can be slow, so cache 'em + my %hostname_cache; + sub _gethostbyaddr { + my $ip = shift; + $hostname_cache{$ip} ||= gethostbyaddr( $ip, AF_INET ) || 'localhost'; + } +} -no Moose; +sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } =head2 options @@ -561,7 +571,7 @@ Many parts are ripped out of C by Jesse Vincent. =head1 COPYRIGHT -This program is free software, you can redistribute it and/or modify it under +This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =cut