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=f4fef51a6420014dc1e4197662a99fac8260baf5;hb=536bee890cf24e0e4bcda7562e7b70cc03ca0620;hpb=1b45d7e568761cc47399c1dffab8ce983d076b6f diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index f4fef51..a41912c 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -1,13 +1,13 @@ 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 (); @@ -19,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 @@ -52,59 +62,52 @@ sub finalize_headers { 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} + if ( $self->options->{keepalive} && $connection && $connection =~ /^keep-alive$/i ) { - $c->response->headers->header( Connection => 'keep-alive' ); - $self->{_keepalive} = 1; + $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, ''); + $self->_header_buf( join("\x0D\x0A", @headers, '') ); } =head2 $self->finalize_read($c) =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 ) = @_; - +before 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) @@ -142,34 +145,34 @@ sub read_chunk { =head2 $self->write($c, $buffer) -Writes the buffer to the client. Can only be called once for a request. +Writes the buffer to the client. =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(); - - my $ret; - - # Prepend the headers if they have not yet been sent - if ( my $headers = delete $self->{_header_buf} ) { - DEBUG && warn "write: Wrote headers and first chunk (" . length($headers . $buffer) . " bytes)\n"; - $ret = $self->NEXT::write( $c, $headers . $buffer ); + + # Avoid 'print() on closed filehandle Remote' warnings when using IE + return unless *STDOUT->opened(); + + # Prepend the headers if they have not yet been sent + if ( $self->_has_header_buf ) { + $buffer = $self->_clear_header_buf . $buffer; } - else { - DEBUG && warn "write: Wrote chunk (" . length($buffer) . " bytes)\n"; - $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"; } - - if ( !$ret ) { - $self->{_write_error} = $!; + else { + DEBUG && warn "write: Wrote response ($ret bytes)\n"; } - + return $ret; -} +}; =head2 run @@ -180,13 +183,13 @@ sub run { my ( $self, $class, $port, $host, $options ) = @_; $options ||= {}; - - $self->{options} = $options; + + $self->options($options); if ($options->{background}) { my $child = fork; die "Can't fork: $!" unless defined($child); - exit if $child; + return $child if $child; } my $restart = 0; @@ -213,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; @@ -240,43 +245,43 @@ sub run { } 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; next LISTEN; } my ( $method, $uri, $protocol ) = $self->_parse_request_line; - + 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; @@ -284,11 +289,10 @@ sub run { } $self->_handler( $class, $port, $method, $uri, $protocol ); - - if ( my $error = delete $self->{_write_error} ) { - DEBUG && warn "Write error: $error\n"; + + if ( $self->_has_write_error ) { close Remote; - + if ( !defined $pid ) { next LISTEN; } @@ -320,9 +324,9 @@ sub run { close Remote; } } - + $daemon->close; - + DEBUG && warn "Shutting down\n"; if ($restart) { @@ -333,9 +337,9 @@ sub run { ### 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; - - exec $^X . ' "' . $0 . '" ' . join( ' ', @{ $options->{argv} } ); + $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; + + exec $^X, $0, @{ $options->{argv} }; } exit; @@ -365,7 +369,6 @@ sub _handler { 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, @@ -379,13 +382,21 @@ 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"; @@ -418,46 +429,51 @@ sub _handler { sub _read_headers { my $self = shift; - + while (1) { my $read = sysread Remote, my $buf, CHUNKSIZE; - - if ( !$read ) { - DEBUG && warn "EOF or error: $!\n"; + + if ( !defined $read ) { + next if $! == EWOULDBLOCK; + DEBUG && warn "Error reading headers: $!\n"; + return; + } 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 - if ( $self->{inputbuf} !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { + # Parse request line + # Leading CRLF sometimes sent by buggy IE versions + if ( $self->{inputbuf} !~ s/^(?:\x0D\x0A)?(\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); @@ -512,9 +528,6 @@ sub _socket_data { # This mess is necessary to keep IE from crashing the server my $data = { - peername => $iaddr - ? ( gethostbyaddr( $iaddr, AF_INET ) || 'localhost' ) - : 'localhost', peeraddr => $iaddr ? ( inet_ntoa($iaddr) || '127.0.0.1' ) : '127.0.0.1', @@ -527,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 @@ -547,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