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
  18 BEGIN {
  19     eval "use File::Copy::Recursive";
  20     plan skip_all => 'File::Copy::Recursive required' if $@;
  21 }
  22
  23 use lib 't/lib';
  24 use MakeTestApp;
  25
  26 make_test_app;
  27
  28 # spawn the standalone HTTP server
  29 my $port = 30000 + int rand( 1 + 10000 );
  30
  31 my( $server, $pid );
  32 my @cmd = ($^X, "-I$FindBin::Bin/../lib", "-I$FindBin::Bin/lib",
  33   "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '--port',
  34   $port, '--restart');
  35
  36 $pid = open3( undef, $server, undef, @cmd )
  37     or die "Unable to spawn standalone HTTP server: $!";
  38
  39 # switch to non-blocking reads so we can fail
  40 # gracefully instead of just hanging forever
  41
  42 $server->blocking( 0 );
  43
  44 # wait for it to start
  45 print "Waiting for server to start...\n";
  46 while ( check_port( 'localhost', $port ) != 1 ) {
  47     sleep 1;
  48 }
  49
  50 # change various files
  51 my @files = (
  52     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm",
  53     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",
  54     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable.pm",
  55     "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable/HardToReload.pm",
  56 );
  57
  58 # change some files and make sure the server restarts itself
  59 NON_ERROR_RESTART:
  60 for ( 1 .. 20 ) {
  61     my $index = rand @files;
  62     open my $pm, '>>', $files[$index]
  63       or die "Unable to open $files[$index] for writing: $!";
  64     print $pm "\n";
  65     close $pm;
  66
  67     # give the server time to notice the change and restart
  68     my $count = 0;
  69     my $line;
  70     while ( ( $line || '' ) !~ /ttempting to restart the server/ ) {
  71         # wait for restart message
  72         $line = $server->getline;
  73         sleep 0.1;
  74         if ( $count++ > 100 ) {
  75             fail "Server restarted";
  76             SKIP: {
  77                 skip "Server didn't restart, no sense in checking response", 1;
  78             }
  79             next NON_ERROR_RESTART;
  80         }
  81     };
  82     pass "Server restarted";
  83
  84     $count = 0;
  85     while ( check_port( 'localhost', $port ) != 1 ) {
  86         # wait for it to restart
  87         sleep 0.1;
  88         die "Server appears to have died" if $count++ > 100;
  89     }
  90     my $response = get("http://localhost:$port/action/default");
  91     like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' );
  92
  93     # give the server some time to reindex its files
  94     sleep 1;
  95 }
  96
  97 # multiple restart directories
  98
  99 # we need different options so we have to rebuild most
 100 # of the testing environment
 101
 102 kill 'KILL', $pid;
 103 close $server;
 104
 105 # clean up
 106 rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
 107
 108 done_testing;
 109
 110 sub check_port {
 111     my ( $host, $port ) = @_;
 112
 113     my $remote = IO::Socket::INET->new(
 114         Proto    => "tcp",
 115         PeerAddr => $host,
 116         PeerPort => $port
 117     );
 118     if ($remote) {
 119         close $remote;
 120         return 1;
 121     }
 122     else {
 123         return 0;
 124     }
 125 }