X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FHTTP.pm;h=a41912c41b5cfad7a2ffcdd2e50a62cae6428834;hp=30c5201c87d332a50ceb633777e13c8bc420e511;hb=536bee890cf24e0e4bcda7562e7b70cc03ca0620;hpb=7fa2c9c1b85c98786655ad5169708d8dc84e8353 diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 30c5201..a41912c 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -2,6 +2,7 @@ package Catalyst::Engine::HTTP; use Moose; extends 'Catalyst::Engine::CGI'; + use Data::Dump qw(dump); use Errno 'EWOULDBLOCK'; use HTTP::Date (); @@ -18,6 +19,16 @@ 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' ); + +# 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 :) + =head1 NAME Catalyst::Engine::HTTP - Catalyst HTTP Engine @@ -61,12 +72,12 @@ sub finalize_headers { # 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 ) { $res_headers->header( Connection => 'keep-alive' ); - $self->{_keepalive} = 1; + $self->_keepalive(1); } else { $res_headers->header( Connection => 'close' ); @@ -76,7 +87,7 @@ sub finalize_headers { # 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, ''); + $self->_header_buf( join("\x0D\x0A", @headers, '') ); } =head2 $self->finalize_read($c) @@ -93,7 +104,7 @@ before finalize_read => sub { =cut -befpre prepare_read => sub { +before prepare_read => sub { # Set the input handle to non-blocking *STDIN->blocking(0); }; @@ -105,7 +116,7 @@ befpre 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] ); @@ -146,14 +157,14 @@ around write => sub { return unless *STDOUT->opened(); # Prepend the headers if they have not yet been sent - if ( my $headers = delete $self->{_header_buf} ) { - $buffer = $headers . $buffer; + if ( $self->_has_header_buf ) { + $buffer = $self->_clear_header_buf . $buffer; } - my $ret = $self->$orig( $c, $buffer ); + my $ret = $self->$orig($c, $buffer); if ( !defined $ret ) { - $self->{_write_error} = $!; + $self->_write_error($!); DEBUG && warn "write: Failed to write response ($!)\n"; } else { @@ -173,7 +184,7 @@ sub run { $options ||= {}; - $self->{options} = $options; + $self->options($options); if ($options->{background}) { my $child = fork; @@ -205,7 +216,9 @@ sub run { ReuseAddr => 1, Type => SOCK_STREAM, ) - or die "Couldn't create daemon: $!"; + or die "Couldn't create daemon: $@"; + + $port = $daemon->sockport(); my $url = "http://$host"; $url .= ":$port" unless $port == 80; @@ -277,7 +290,7 @@ sub run { $self->_handler( $class, $port, $method, $uri, $protocol ); - if ( my $error = delete $self->{_write_error} ) { + if ( $self->_has_write_error ) { close Remote; if ( !defined $pid ) { @@ -346,17 +359,16 @@ sub _handler { 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 || '', QUERY_STRING => $query_string || '', REMOTE_ADDR => $sockdata->{peeraddr}, - REMOTE_HOST => $sockdata->{peername}, REQUEST_METHOD => $method || '', SERVER_NAME => $sockdata->{localname}, SERVER_PORT => $port, @@ -370,38 +382,46 @@ sub _handler { } # Pass flow control to Catalyst - $class->handle_request; + { + # FIXME: don't ignore SIGCHLD while handling requests so system() + # et al. work within actions. it might be a little risky to do that + # this far out, but then again it's only the dev server anyway. + local $SIG{CHLD} = 'DEFAULT'; + $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 ( delete $self->{_keepalive} ) { - + 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; @@ -434,7 +454,8 @@ sub _parse_request_line { my $self = shift; # Parse request line - if ( $self->{inputbuf} !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { + # Leading CRLF sometimes sent by buggy IE versions + if ( $self->{inputbuf} !~ s/^(?:\x0D\x0A)?(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { return (); } @@ -472,19 +493,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"; } @@ -498,19 +519,16 @@ 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 = { - 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', @@ -522,19 +540,18 @@ sub _socket_data { sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } -=head1 SEE ALSO - -L, L. +=head2 options -=head1 AUTHORS +Options hash passed to the http engine to control things like if keepalive +is supported. -Sebastian Riedel, +=head1 SEE ALSO -Dan Kubb, +L, L -Sascha Kiefer, +=head1 AUTHORS -Andy Grundman, +Catalyst Contributors, see Catalyst.pm =head1 THANKS @@ -542,7 +559,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