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=d3d1c6d94f64ba945885cfce22e98172ee7e8454;hp=e1682af9fc6f9b2e86f6c82ecd17ac98fc6cf375;hb=0bf7ab7160f4f2fd0f00cd3d53ac311e9ad50241;hpb=4a2a4aadf2362d76c59a87b105f0dd2237f017cd diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index e1682af..d3d1c6d 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -5,6 +5,7 @@ use base 'Catalyst::Engine::CGI'; use Data::Dump qw(dump); use Errno 'EWOULDBLOCK'; use HTTP::Date (); +use HTTP::Headers; use HTTP::Status; use NEXT; use Socket; @@ -15,9 +16,8 @@ use IO::Select (); require Catalyst::Engine::HTTP::Restarter; require Catalyst::Engine::HTTP::Restarter::Watcher; -sub CHUNKSIZE () { 64 * 1024 } - -sub DEBUG () { $ENV{CATALYST_HTTP_DEBUG} || 0 } +use constant CHUNKSIZE => 64 * 1024; +use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0; =head1 NAME @@ -53,17 +53,30 @@ sub finalize_headers { my $status = $c->response->status; my $message = status_message($status); - print "$protocol $status $message\015\012"; + my @headers; + push @headers, "$protocol $status $message"; $c->response->headers->header( Date => HTTP::Date::time2str(time) ); - $c->response->headers->header( - Connection => $self->_keep_alive ? 'keep-alive' : 'close' ); - $c->response->headers->header( Status => $status ); - - # Avoid 'print() on closed filehandle Remote' warnings when using IE - print $c->response->headers->as_string("\015\012") if *STDOUT->opened(); - print "\015\012" if *STDOUT->opened(); + + # Should we keep the connection open? + my $connection = $c->request->header('Connection'); + if ( $self->{options}->{keepalive} + && $connection + && $connection =~ /^keep-alive$/i + ) { + $c->response->headers->header( Connection => 'keep-alive' ); + $self->{_keepalive} = 1; + } + else { + $c->response->headers->header( Connection => 'close' ); + } + + push @headers, $c->response->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, ''); } =head2 $self->finalize_read($c) @@ -129,30 +142,29 @@ 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 { 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 ); - } - else { - DEBUG && warn "write: Wrote chunk (" . length($buffer) . " bytes)\n"; - $ret = $self->NEXT::write( $c, $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 ( my $headers = delete $self->{_header_buf} ) { + $buffer = $headers . $buffer; } - if ( !$ret ) { + my $ret = $self->NEXT::write( $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; @@ -173,7 +185,7 @@ sub run { if ($options->{background}) { my $child = fork; die "Can't fork: $!" unless defined($child); - exit if $child; + return $child if $child; } my $restart = 0; @@ -231,6 +243,12 @@ sub run { # Ignore broken pipes as an HTTP server should local $SIG{PIPE} = 'IGNORE'; + # Restart on HUP + local $SIG{HUP} = sub { + $restart = 1; + warn "Restarting server on SIGHUP...\n"; + }; + LISTEN: while ( !$restart ) { while ( accept( Remote, $daemon ) ) { @@ -245,29 +263,42 @@ sub run { if ( !$self->_read_headers ) { # Error reading, give up + close Remote; next LISTEN; } 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} ) { next if $pid = 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} ) { - DEBUG && warn "Write error: $error\n"; close Remote; - next LISTEN; + + if ( !defined $pid ) { + next LISTEN; + } } - $daemon->close if defined $pid; + if ( defined $pid ) { + # Child process, close connection and exit + DEBUG && warn "Child process exiting\n"; + $daemon->close; + exit; + } } else { my $sockdata = $self->_socket_data( \*Remote ); @@ -283,8 +314,6 @@ sub run { last; } } - - exit if defined $pid; } continue { close Remote; @@ -305,7 +334,7 @@ sub run { use Config; $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; - exec $^X . ' "' . $0 . '" ' . join( ' ', @{ $options->{argv} } ); + exec $^X, $0, @{ $options->{argv} }; } exit; @@ -329,7 +358,7 @@ sub _handler { REQUEST: while (1) { my ( $path, $query_string ) = split /\?/, $uri, 2; - + # Initialize CGI environment local %ENV = ( PATH_INFO => $path || '', @@ -391,9 +420,14 @@ sub _read_headers { 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; } @@ -499,17 +533,11 @@ sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } =head1 SEE ALSO -L, L. +L, L =head1 AUTHORS -Sebastian Riedel, - -Dan Kubb, - -Sascha Kiefer, - -Andy Grundman, +Catalyst Contributors, see Catalyst.pm =head1 THANKS