1 # This test tests the standalone server's auto-restart feature.
12 use Time::HiRes qw/sleep/;
13 eval "use Catalyst::Devel 1.0;";
15 plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
16 plan skip_all => 'Catalyst::Devel required' if $@;
17 plan skip_all => 'Catalyst::Devel >= 1.04 required' if $Catalyst::Devel::VERSION <= 1.03;
18 eval "use File::Copy::Recursive";
19 plan skip_all => 'File::Copy::Recursive required' if $@;
23 my $tmpdir = "$FindBin::Bin/../t/tmp";
26 rmtree $tmpdir if -d $tmpdir;
28 # create a TestApp and copy the test libs into it
32 system( 'perl', "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/catalyst.pl", 'TestApp' );
34 chdir "$FindBin::Bin/..";
35 File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
37 # remove TestApp's tests
38 rmtree 't/tmp/TestApp/t';
40 # spawn the standalone HTTP server
41 my $port = 30000 + int rand( 1 + 10000 );
44 $pid = open3( undef, $server, undef,
45 'perl', "-I$FindBin::Bin/../lib",
46 "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port',
48 or die "Unable to spawn standalone HTTP server: $!";
50 # switch to non-blocking reads so we can fail
51 # gracefully instead of just hanging forever
53 $server->blocking( 0 );
55 # wait for it to start
56 print "Waiting for server to start...\n";
57 while ( check_port( 'localhost', $port ) != 1 ) {
61 # change various files
63 "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm",
64 "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",
65 "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm",
68 # change some files and make sure the server restarts itself
71 my $index = rand @files;
72 open my $pm, '>>', $files[$index]
73 or die "Unable to open $files[$index] for writing: $!";
77 # give the server time to notice the change and restart
81 while ( ( $line || '' ) !~ /can connect/ ) {
82 # wait for restart message
83 $line = $server->getline;
85 if ( $count++ > 100 ) {
86 fail "Server restarted";
88 skip "Server didn't restart, no sense in checking response", 1;
90 next NON_ERROR_RESTART;
93 pass "Server restarted";
96 while ( check_port( 'localhost', $port ) != 1 ) {
97 # wait for it to restart
99 die "Server appears to have died" if $count++ > 100;
101 my $response = get("http://localhost:$port/action/default");
102 like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' );
104 # give the server some time to reindex its files
108 # add errors to the file and make sure server does not die or restart
111 my $index = rand @files;
112 open my $pm, '>>', $files[$index]
113 or die "Unable to open $files[$index] for writing: $!";
120 while ( ( $line || '' ) !~ /failed/ ) {
121 # wait for restart message
122 $line = $server->getline;
124 if ( $count++ > 100 ) {
125 fail "Server restarted";
127 skip "Server didn't restart, no sense in checking response", 1;
129 next NO_RESTART_ON_ERROR;
133 pass "Server refused to restart";
135 if ( check_port( 'localhost', $port ) != 1 ) {
136 die "Server appears to have died";
138 my $response = get("http://localhost:$port/action/default");
139 like( $response, qr/Catalyst::Request/,
140 'Syntax error, no restart, request OK' );
142 # give the server some time to reindex its files
147 # multiple restart directories
149 # we need different options so we have to rebuild most
150 # of the testing environment
155 # pick next port because the last one might still be blocked from
156 # previous server. This might fail if this port is unavailable
157 # but picking the first one has the same problem so this is acceptable
161 { no warnings 'once'; $File::Copy::Recursive::RMTrgFil = 1; }
162 File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
164 # change various files
166 "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",
167 "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm",
170 my $app_root = "$FindBin::Bin/../t/tmp/TestApp";
171 my $restartdirs = join ' ', map{
172 "-restartdirectory $app_root/lib/TestApp/Controller/$_"
175 $pid = open3( undef, $server, undef,
176 'perl', "-I$FindBin::Bin/../lib",
177 "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port',
178 $port, '-restart', $restartdirs )
179 or die "Unable to spawn standalone HTTP server: $!";
180 $server->blocking( 0 );
183 # wait for it to start
184 print "Waiting for server to start...\n";
185 while ( check_port( 'localhost', $port ) != 1 ) {
191 my $index = rand @files;
192 open my $pm, '>>', $files[$index]
193 or die "Unable to open $files[$index] for writing: $!";
197 # give the server time to notice the change and restart
201 while ( ( $line || '' ) !~ /can connect/ ) {
202 # wait for restart message
203 $line = $server->getline;
205 if ( $count++ > 100 ) {
206 fail "Server restarted";
208 skip "Server didn't restart, no sense in checking response", 1;
210 next MULTI_DIR_RESTART;
213 pass "Server restarted with multiple restartdirs";
216 while ( check_port( 'localhost', $port ) != 1 ) {
217 # wait for it to restart
219 die "Server appears to have died" if $count++ > 100;
221 my $response = get("http://localhost:$port/action/default");
222 like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' );
224 # give the server some time to reindex its files
234 rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
237 my ( $host, $port ) = @_;
239 my $remote = IO::Socket::INET->new(