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