use Data::Dump qw(dump);
use Errno 'EWOULDBLOCK';
use HTTP::Date ();
+use HTTP::Headers;
use HTTP::Status;
use NEXT;
use Socket;
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
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)
=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;
if ($options->{background}) {
my $child = fork;
die "Can't fork: $!" unless defined($child);
- exit if $child;
+ return $child if $child;
}
my $restart = 0;
# 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 ) ) {
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 );
last;
}
}
-
- exit if defined $pid;
}
continue {
close Remote;
use Config;
$ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
- exec $^X . ' "' . $0 . '" ' . join( ' ', @{ $options->{argv} } );
+ exec $^X, $0, @{ $options->{argv} };
}
exit;
REQUEST:
while (1) {
my ( $path, $query_string ) = split /\?/, $uri, 2;
-
+
# Initialize CGI environment
local %ENV = (
PATH_INFO => $path || '',
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;
}
=head1 SEE ALSO
-L<Catalyst>, L<Catalyst::Engine>.
+L<Catalyst>, L<Catalyst::Engine>
=head1 AUTHORS
-Sebastian Riedel, <sri@cpan.org>
-
-Dan Kubb, <dan.kubb-cpan@onautopilot.com>
-
-Sascha Kiefer, <esskar@cpan.org>
-
-Andy Grundman, <andy@hybridized.org>
+Catalyst Contributors, see Catalyst.pm
=head1 THANKS
projects / catagits/Catalyst-Runtime.git / blobdiff