Engine::HTTP - Fix paths for HTTP requests with scheme and domain in URI.

[catagits/Catalyst-Runtime.git] / lib / Catalyst / Engine / HTTP.pm

diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm
index 1163244..91fb0a8 100644 (file)
--- a/lib/Catalyst/Engine/HTTP.pm
+++ b/lib/Catalyst/Engine/HTTP.pm
@@ -19,12 +19,12 @@ 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 +72,8 @@ 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' );
@@ -116,7 +116,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 +158,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($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 +175,8 @@ around write => sub {
     else {
         DEBUG && warn "write: Wrote response ($ret bytes)\n";
     }
-
     return $ret;
-};
+}
 
 =head2 run
 
@@ -183,7 +187,7 @@ sub run {
     my ( $self, $class, $port, $host, $options ) = @_;
 
     $options ||= {};
-    
+
     $self->options($options);
 
     if ($options->{background}) {
@@ -216,7 +220,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;
@@ -287,10 +293,10 @@ sub run {
                 }
 
                 $self->_handler( $class, $port, $method, $uri, $protocol );
-            
+
                 if ( $self->_has_write_error ) {
                     close Remote;
-                    
+
                     if ( !defined $pid ) {
                         next LISTEN;
                     }
@@ -322,9 +328,9 @@ sub run {
             close Remote;
         }
     }
-    
+
     $daemon->close;
-    
+
     DEBUG && warn "Shutting down\n";
 
     if ($restart) {
@@ -335,8 +341,8 @@ 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; 
-        
+        $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
+
         exec $^X, $0, @{ $options->{argv} };
     }
 
@@ -357,11 +363,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         || '',
@@ -380,39 +389,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 ( $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;
@@ -484,19 +500,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";
         }
@@ -510,16 +526,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 = {
-        peeraddr  => $iaddr 
+        peeraddr  => $iaddr
             ? ( inet_ntoa($iaddr) || '127.0.0.1' )
             : '127.0.0.1',
         localname => gethostbyaddr( $localiaddr, AF_INET ) || 'localhost',
@@ -531,8 +547,6 @@ sub _socket_data {
 
 sub _inet_addr { unpack "N*", inet_aton( $_[0] ) }
 
-no Moose;
-
 =head2 options
 
 Options hash passed to the http engine to control things like if keepalive
@@ -552,7 +566,7 @@ Many parts are ripped out of C<HTTP::Server::Simple> 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