t/optinal_http-server-restart.t

   1 #!perl\r
   2 \r
   3 # This test tests the standalone server's auto-restart feature.\r
   4 \r
   5 use strict;\r
   6 use warnings;\r
   7 \r
   8 use File::Path;\r
   9 use FindBin;\r
  10 use LWP::Simple;\r
  11 use IO::Socket;\r
  12 use Test::More;\r
  13 use Time::HiRes qw/sleep/;\r
  14 eval "use File::Copy::Recursive";\r
  15 \r
  16 plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};\r
  17 plan skip_all => 'File::Copy::Recursive required' if $@;\r
  18 \r
  19 plan tests => 40;\r
  20 \r
  21 # clean up\r
  22 rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";\r
  23 \r
  24 # create a TestApp and copy the test libs into it\r
  25 mkdir "$FindBin::Bin/../../t/tmp";\r
  26 chdir "$FindBin::Bin/../../t/tmp";\r
  27 system "perl -I$FindBin::Bin/../../lib $FindBin::Bin/../../script/catalyst.pl TestApp";\r
  28 chdir "$FindBin::Bin/../..";\r
  29 File::Copy::Recursive::dircopy( 't/live/lib', 't/tmp/TestApp/lib' );\r
  30 \r
  31 # remove TestApp's tests\r
  32 rmtree 't/tmp/TestApp/t';\r
  33 \r
  34 # spawn the standalone HTTP server\r
  35 my $port = 30000 + int rand(1 + 10000);\r
  36 my $pid = open my $server, \r
  37     "perl -I$FindBin::Bin/../../lib $FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl -port $port -restart 2>&1 |"\r
  38     or die "Unable to spawn standalone HTTP server: $!";\r
  39 \r
  40 # wait for it to start\r
  41 print "Waiting for server to start...\n";\r
  42 while ( check_port( 'localhost', $port ) != 1 ) {\r
  43     sleep 1;\r
  44 }\r
  45 \r
  46 # change various files\r
  47 my @files = (\r
  48     "$FindBin::Bin/../../t/tmp/TestApp/lib/TestApp.pm",\r
  49     "$FindBin::Bin/../../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",\r
  50     "$FindBin::Bin/../../t/tmp/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm",\r
  51 );\r
  52 \r
  53 # change some files and make sure the server restarts itself\r
  54 for ( 1..20 ) {\r
  55     my $index = rand @files;\r
  56     open my $pm, '>>', $files[$index]\r
  57         or die "Unable to open $files[$index] for writing: $!";\r
  58     print $pm "\n";\r
  59     close $pm;\r
  60     \r
  61     # give the server time to notice the change and restart\r
  62     my $count = 0;\r
  63     sleep 1;\r
  64     while ( check_port( 'localhost', $port ) != 1 ) {\r
  65         # wait for it to restart\r
  66         sleep 0.1;\r
  67         die "Server appears to have died" if $count++ > 50;\r
  68     }\r
  69     my $response = get("http://localhost:$port/action/default");\r
  70     like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' );\r
  71     \r
  72     #print $server->getline;\r
  73 }\r
  74 \r
  75 # add errors to the file and make sure server does not die or restart\r
  76 for ( 1..20 ) {\r
  77     my $index = rand @files;\r
  78     open my $pm, '>>', $files[$index]\r
  79         or die "Unable to open $files[$index] for writing: $!";\r
  80     print $pm "bleh";\r
  81     close $pm;\r
  82     \r
  83     # give the server time to notice the change\r
  84     sleep 1;\r
  85     if ( check_port( 'localhost', $port ) != 1 ) {\r
  86         die "Server appears to have died";\r
  87     }\r
  88     my $response = get("http://localhost:$port/action/default");\r
  89     like( $response, qr/Catalyst::Request/, 'Syntax error, no restart, request OK' );\r
  90     \r
  91     #print $server->getline;\r
  92 }\r
  93 \r
  94 # shut it down\r
  95 kill 'INT', $pid;\r
  96 close $server;\r
  97 \r
  98 # clean up\r
  99 rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";\r
 100 \r
 101 sub check_port {\r
 102     my ( $host, $port ) = @_;\r
 103 \r
 104     my $remote = IO::Socket::INET->new(\r
 105         Proto    => "tcp",\r
 106         PeerAddr => $host,\r
 107         PeerPort => $port\r
 108     );\r
 109     if ($remote) {\r
 110         close $remote;\r
 111         return 1;\r
 112     }\r
 113     else {\r
 114         return 0;\r
 115     }\r
 116 }\r