Reverted restarter change, until some fixes are made

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

diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm
index 27873f2..332e771 100644 (file)
--- a/lib/Catalyst/Engine/HTTP.pm
+++ b/lib/Catalyst/Engine/HTTP.pm
@@ -3,6 +3,9 @@ package Catalyst::Engine::HTTP;
 use strict;
 use base 'Catalyst::Engine::CGI';
 use Errno 'EWOULDBLOCK';
+use FindBin;
+use File::Find;
+use File::Spec;
 use HTTP::Status;
 use NEXT;
 use Socket;
@@ -56,7 +59,7 @@ sub finalize_read {
 
     # Never ever remove this, it would result in random length output
     # streams if STDIN eq STDOUT (like in the HTTP engine)
-    $c->request->handle->blocking(1);
+    *STDIN->blocking(1);
 
     return $self->NEXT::finalize_read($c);
 }
@@ -69,7 +72,7 @@ sub prepare_read {
     my ( $self, $c ) = @_;
 
     # Set the input handle to non-blocking
-    $c->request->handle->blocking(0);
+    *STDIN->blocking(0);
 
     return $self->NEXT::prepare_read($c);
 }
@@ -83,14 +86,13 @@ sub read_chunk {
     my $c    = shift;
 
     # support for non-blocking IO
-    my $handle = $c->request->handle;
-    my $rin    = '';
-    vec( $rin, $handle->fileno, 1 ) = 1;
+    my $rin = '';
+    vec( $rin, *STDIN->fileno, 1 ) = 1;
 
   READ:
     {
         select( $rin, undef, undef, undef );
-        my $rc = $handle->sysread(@_);
+        my $rc = *STDIN->sysread(@_);
         if ( defined $rc ) {
             return $rc;
         }
@@ -107,23 +109,77 @@ sub read_chunk {
 
 # A very very simple HTTP server that initializes a CGI environment
 sub run {
-    my ( $self, $class, $port, $host, $fork ) = @_;
-
+    my ( $self, $class, $port, $host, $options ) = @_;
+
+    $options ||= {};
+
+    # Setup restarter
+    my $restarter;
+    if ( $options->{restart} ) {
+        my $parent = $$;
+        unless ( $restarter = fork ) {
+
+            # Prepare
+            close STDIN;
+            close STDOUT;
+
+            # Index parent directory
+            my $dir = File::Spec->catdir( $FindBin::Bin, '..' );
+
+            my $regex = $options->{restart_regex};
+            my $one   = _index( $dir, $regex );
+          RESTART: while (1) {
+                sleep $options->{restart_delay} || 1;
+                
+                # check if our parent has died
+                exit if ( getppid == 1 );
+                
+                my $two     = _index( $dir,         $regex );
+                my $changes = _compare_index( $one, $two );
+                if (@$changes) {
+                    $one = $two;
+
+                    # Test modified pm's
+                    for my $file (@$changes) {
+                        next unless $file =~ /\.pm$/;
+                        if ( my $error = _test($file) ) {
+                            print STDERR
+                              qq/File "$file" modified, not restarting\n\n/;
+                            print STDERR '*' x 80, "\n";
+                            print STDERR $error;
+                            print STDERR '*' x 80, "\n";
+                            next RESTART;
+                        }
+                    }
+
+                    # Restart
+                    my $files = join ', ', @$changes;
+                    print STDERR qq/File(s) "$files" modified, restarting\n\n/;
+                    kill( 1, $parent );
+                    exit;
+                }
+            }
+        }
+    }
+    
     our $GOT_HUP;
     local $GOT_HUP = 0;
-
+    
     local $SIG{HUP} = sub { $GOT_HUP = 1; };
-
     local $SIG{CHLD} = 'IGNORE';
 
     # Handle requests
 
     # Setup socket
     $host = $host ? inet_aton($host) : INADDR_ANY;
-    socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') );
-    setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) );
-    bind( HTTPDaemon, sockaddr_in( $port, $host ) );
-    listen( HTTPDaemon, SOMAXCONN );
+    socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
+        || die "Couldn't assign TCP socket: $!";
+    setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
+        || die "Couldn't set TCP socket options: $!";
+    bind( HTTPDaemon, sockaddr_in( $port, $host ) )
+        || die "Couldn't bind socket to $port on $host: $!";
+    listen( HTTPDaemon, SOMAXCONN )
+       || die "Couldn't listen to socket on $port on $host: $!";
     my $url = 'http://';
     if ( $host eq INADDR_ANY ) {
         require Sys::Hostname;
@@ -138,13 +194,13 @@ sub run {
     while ( accept( Remote, HTTPDaemon ) ) {
 
         # Fork
-        if ($fork) { next if $pid = fork }
+        if ( $options->{fork} ) { next if $pid = fork }
 
         close HTTPDaemon if defined $pid;
 
         # Ignore broken pipes as an HTTP server should
         local $SIG{PIPE} = sub { close Remote };
-        local $SIG{HUP} = (defined $pid ? 'IGNORE' : $SIG{HUP});
+        local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} );
 
         local *STDIN  = \*Remote;
         local *STDOUT = \*Remote;
@@ -218,7 +274,26 @@ sub run {
         close Remote;
     }
     close HTTPDaemon;
-    exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @ARGV ) if $GOT_HUP;
+
+    if ($GOT_HUP) {
+        $SIG{CHLD} = 'DEFAULT';
+        wait;
+        exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @{ $options->{argv} } );
+    }
+}
+
+sub _compare_index {
+    my ( $one, $two ) = @_;
+    my %clone = %$two;
+    my @changes;
+    while ( my ( $key, $val ) = each %$one ) {
+        if ( !$clone{$key} || ( $clone{$key} ne $val ) ) {
+            push @changes, $key;
+        }
+        delete $clone{$key};
+    }
+    for my $key ( keys %clone ) { push @changes, $key }
+    return \@changes;
 }
 
 sub _get_line {
@@ -236,6 +311,37 @@ sub _get_line {
     return $line;
 }
 
+sub _index {
+    my ( $dir, $regex ) = @_;
+    my %index;
+    finddepth(
+        {
+            wanted => sub {
+                my $file = File::Spec->rel2abs($File::Find::name);
+                return unless $file =~ /$regex/;
+                return unless -f $file;
+                my $time = ( stat $file )[9];
+                $index{$file} = $time;
+            },
+            no_chdir => 1
+        },
+        $dir
+    );
+    return \%index;
+}
+
+sub _test {
+    my $file = shift;
+    delete $INC{$file};
+    local $SIG{__WARN__} = sub { };
+    open my $olderr, '>&STDERR';
+    open STDERR, '>', File::Spec->devnull;
+    eval "require '$file'";
+    open STDERR, '>&', $olderr;
+    return $@ if $@;
+    return 0;
+}
+
 =back
 
 =head1 SEE ALSO