t/optional_http-server-restart.t

   1 # This test tests the standalone server's auto-restart feature.
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 BEGIN {
   8     plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
   9 }
  10
  11 use File::Path;
  12 use FindBin;
  13 use LWP::Simple;
  14 use IO::Socket;
  15 use IPC::Open3;
  16 use Time::HiRes qw/sleep/;
  17 eval {require Catalyst::Devel; Catalyst::Devel->VERSION(1.0);};
  18
  19 plan skip_all => 'Catalyst::Devel required' if $@;
  20 plan skip_all => 'Catalyst::Devel >= 1.04 required' if $Catalyst::Devel::VERSION <= 1.03;
  21 eval "use File::Copy::Recursive";
  22 plan skip_all => 'File::Copy::Recursive required' if $@;
  23
  24 my $tmpdir = "$FindBin::Bin/../t/tmp";
  25
  26 # clean up
  27 rmtree $tmpdir if -d $tmpdir;
  28
  29 # create a TestApp and copy the test libs into it
  30 mkdir $tmpdir;
  31 chdir $tmpdir;
  32
  33 system( $^X, "-I$FindBin::Bin/../lib", '-MFile::Spec', '-e', "\@ARGV=('TestApp'); my \$devnull = File::Spec->devnull; open my \$fh, '>', \$devnull or die \"Cannot write to \$devnull: \$!\"; *STDOUT = \$fh; do \"$FindBin::Bin/../script/catalyst.pl\"");
  34
  35 chdir "$FindBin::Bin/..";
  36 File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
  37
  38 # remove TestApp's tests
  39 rmtree 't/tmp/TestApp/t';
  40
  41 # spawn the standalone HTTP server
  42 my $port = 30000 + int rand( 1 + 10000 );
  43
  44 my( $server, $pid );
  45 my @cmd = ($^X, "-I$FindBin::Bin/../lib", "-I$FindBin::Bin/lib",
  46   "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '--port',
  47   $port, '--restart');
  48
  49 $pid = open3( undef, $server, undef, @cmd )
  50     or die "Unable to spawn standalone HTTP server: $!";
  51
  52 # switch to non-blocking reads so we can fail
  53 # gracefully instead of just hanging forever
  54
  55 $server->blocking( 0 );
  56
  57 # wait for it to start
  58 print "Waiting for server to start...\n";
  59 while ( check_port( 'localhost', $port ) != 1 ) {
  60     sleep 1;
  61 }
  62
  63 # change various files
  64 my @files = (
  65     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm",
  66     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",
  67     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable.pm",
  68     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable/HardToReload.pm",
  69 );
  70
  71 # change some files and make sure the server restarts itself
  72 NON_ERROR_RESTART:
  73 for ( 1 .. 20 ) {
  74     my $index = rand @files;
  75     open my $pm, '>>', $files[$index]
  76       or die "Unable to open $files[$index] for writing: $!";
  77     print $pm "\n";
  78     close $pm;
  79
  80     # give the server time to notice the change and restart
  81     my $count = 0;
  82     my $line;
  83     while ( ( $line || '' ) !~ /ttempting to restart the server/ ) {
  84         # wait for restart message
  85         $line = $server->getline;
  86         sleep 0.1;
  87         if ( $count++ > 100 ) {
  88             fail "Server restarted";
  89             SKIP: {
  90                 skip "Server didn't restart, no sense in checking response", 1;
  91             }
  92             next NON_ERROR_RESTART;
  93         }
  94     };
  95     pass "Server restarted";
  96
  97     $count = 0;
  98     while ( check_port( 'localhost', $port ) != 1 ) {
  99         # wait for it to restart
 100         sleep 0.1;
 101         die "Server appears to have died" if $count++ > 100;
 102     }
 103     my $response = get("http://localhost:$port/action/default");
 104     like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' );
 105
 106     # give the server some time to reindex its files
 107     sleep 1;
 108 }
 109
 110 # multiple restart directories
 111
 112 # we need different options so we have to rebuild most
 113 # of the testing environment
 114
 115 kill 'KILL', $pid;
 116 close $server;
 117
 118 # clean up
 119 rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
 120
 121 done_testing;
 122
 123 sub check_port {
 124     my ( $host, $port ) = @_;
 125
 126     my $remote = IO::Socket::INET->new(
 127         Proto    => "tcp",
 128         PeerAddr => $host,
 129         PeerPort => $port
 130     );
 131     if ($remote) {
 132         close $remote;
 133         return 1;
 134     }
 135     else {
 136         return 0;
 137     }
 138 }