t/optional/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/var" if -d "$FindBin::Bin/../../t/var";\r
  23 \r
  24 # create a TestApp and copy the test libs into it\r
  25 mkdir "$FindBin::Bin/../../t/var";\r
  26 chdir "$FindBin::Bin/../../t/var";\r
  27 system "$FindBin::Bin/../../script/catalyst.pl TestApp";\r
  28 chdir "$FindBin::Bin/../..";\r
  29 File::Copy::Recursive::dircopy( 't/live/lib', 't/var/TestApp/lib' );\r
  30 \r
  31 # spawn the standalone HTTP server\r
  32 my $port = 30000 + int rand(1 + 10000);\r
  33 my $pid = open my $server, \r
  34     "$FindBin::Bin/../../t/var/TestApp/script/testapp_server.pl -port $port -restart 2>&1 |"\r
  35     or die "Unable to spawn standalone HTTP server: $!";\r
  36 \r
  37 # wait for it to start\r
  38 print "Waiting for server to start...\n";\r
  39 while ( check_port( 'localhost', $port ) != 1 ) {\r
  40     sleep 1;\r
  41 }\r
  42 \r
  43 # change various files\r
  44 my @files = (\r
  45     "$FindBin::Bin/../../t/var/TestApp/lib/TestApp.pm",\r
  46     "$FindBin::Bin/../../t/var/TestApp/lib/TestApp/Controller/Action/Begin.pm",\r
  47     "$FindBin::Bin/../../t/var/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm",\r
  48 );\r
  49 \r
  50 # change some files and make sure the server restarts itself\r
  51 for ( 1..20 ) {\r
  52     my $index = rand @files;\r
  53     open my $pm, '>>', $files[$index]\r
  54         or die "Unable to open $files[$index] for writing: $!";\r
  55     print $pm "\n";\r
  56     close $pm;\r
  57     \r
  58     # give the server time to notice the change and restart\r
  59     my $count = 0;\r
  60     sleep 1;\r
  61     while ( check_port( 'localhost', $port ) != 1 ) {\r
  62         # wait for it to restart\r
  63         sleep 0.1;\r
  64         die "Server appears to have died" if $count++ > 50;\r
  65     }\r
  66     my $response = get("http://localhost:$port/action/default");\r
  67     like( $response, qr/Catalyst::Request/, 'Request OK' );\r
  68     \r
  69     #print $server->getline;\r
  70 }\r
  71 \r
  72 # add errors to the file and make sure server does not die or restart\r
  73 for ( 1..20 ) {\r
  74     my $index = rand @files;\r
  75     open my $pm, '>>', $files[$index]\r
  76         or die "Unable to open $files[$index] for writing: $!";\r
  77     print $pm "bleh";\r
  78     close $pm;\r
  79     \r
  80     # give the server time to notice the change\r
  81     my $count = 0;\r
  82     sleep 1;\r
  83     if ( check_port( 'localhost', $port ) != 1 ) {\r
  84         die "Server appears to have died";\r
  85     }\r
  86     my $response = get("http://localhost:$port/action/default");\r
  87     like( $response, qr/Catalyst::Request/, 'Request OK' );\r
  88     \r
  89     #print $server->getline;\r
  90 }\r
  91 \r
  92 # shut it down\r
  93 kill 2, $pid;\r
  94 close $server;\r
  95 \r
  96 # clean up\r
  97 rmtree "$FindBin::Bin/../../t/var" if -d "$FindBin::Bin/../../t/var";\r
  98 \r
  99 sub check_port {\r
 100     my ( $host, $port ) = @_;\r
 101 \r
 102     my $remote = IO::Socket::INET->new(\r
 103         Proto    => "tcp",\r
 104         PeerAddr => $host,\r
 105         PeerPort => $port\r
 106     );\r
 107     if ($remote) {\r
 108         close $remote;\r
 109         return 1;\r
 110     }\r
 111     else {\r
 112         return 0;\r
 113     }\r
 114 }\r