1 # XXX - These tests seem to be somewhat flaky and timing-dependent. I
2 # have seen them all run to completion, and I've seen them fail
3 # partway through. If someone can come up with a better way to test
4 # this stuff that'd be great.
11 plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
14 use File::Spec::Functions qw(updir catdir);
16 use File::Basename qw(dirname);
17 use File::Temp qw(tempdir);
18 use File::Path qw(rmtree);
21 use IPC::Open3 qw(open3);
22 use Time::HiRes qw/sleep/;
24 use File::Copy::Recursive qw(dircopy);
28 my $helper_lib = abs_path(catdir(dirname($INC{'Catalyst/Helper.pm'}), updir));
30 my $tmpdir = tempdir(CLEANUP => 1);
31 my $appdir = catdir($tmpdir, 'TestApp');
35 my $helper = Catalyst::Helper->new(
42 $helper->mk_app('TestApp');
46 # remove TestApp's tests
49 # spawn the standalone HTTP server
50 my $port = 30000 + int rand( 1 + 10000 );
52 my ( $pid, $server ) = start_server($port);
54 # change various files
56 "$appdir/lib/TestApp.pm",
57 "$appdir/lib/TestApp/Controller/Foo.pm",
58 "$appdir/lib/TestApp/Controller/Root.pm",
61 # change some files and make sure the server restarts itself
65 my $index = rand @files;
66 open my $pm, '>>', $files[$index]
67 or die "Unable to open $files[$index] for writing: $!";
71 if ( ! look_for_restart() ) {
72 skip "Server did not restart, no sense in checking further", 1;
75 my $response = get("http://localhost:$port/");
76 like( $response, qr/Welcome to the world of Catalyst/,
77 'Non-error restart, request OK' );
81 # add errors to the file and make sure server does die
85 my $index = rand @files;
86 open my $pm, '>>', $files[$index]
87 or die "Unable to open $files[$index] for writing: $!";
91 if ( ! look_for_death() ) {
92 skip "Server restarted, no sense in checking further", 2;
97 if ( ! look_for_restart() ) {
98 skip "Server did not restart, no sense in checking further", 1;
101 my $response = get("http://localhost:$port/");
102 like( $response, qr/Welcome to the world of Catalyst/,
103 'Non-error restart after death, request OK' );
107 # multiple restart directories
109 # we need different options so we have to rebuild most
110 # of the testing environment
112 kill 9, $pid or die "Cannot send kill signal to $pid: $!";
113 close $server or die "Cannot close handle to server process: $!";
116 # pick next port because the last one might still be blocked from
117 # previous server. This might fail if this port is unavailable
118 # but picking the first one has the same problem so this is acceptable
125 "$appdir/lib/TestApp/Controller/Subdir1/Foo.pm",
126 "$appdir/lib/TestApp/Controller/Subdir2/Foo.pm",
129 ( $pid, $server ) = start_server($port);
134 my $index = rand @files;
135 open my $pm, '>>', $files[$index]
136 or die "Unable to open $files[$index] for writing: $!";
140 if ( ! look_for_restart() ) {
141 skip "Server did not restart, no sense in checking further", 1;
144 my $response = get("http://localhost:$port/");
145 like( $response, qr/Welcome to the world of Catalyst/,
146 'Non-error restart with multiple watched dirs' );
155 local $File::Copy::Recursive::RMTrgFil = 1;
156 dircopy( 't/lib/TestApp', "$appdir/lib/TestApp" );
164 undef, $server, undef,
165 $^X, "-I$helper_lib",
166 "$appdir/script/testapp_server.pl", '--port',
168 ) or die "Unable to spawn standalone HTTP server: $!";
170 # switch to non-blocking reads so we can fail gracefully instead
171 # of just hanging forever
172 $server->blocking(0);
176 diag('Waiting for server to start...');
177 while ( check_port( 'localhost', $port ) != 1 ) {
181 if ( $waited >= 10 ) {
182 die 'Waited 10 seconds for server to start, to no avail';
186 return ($pid, $server);
190 my ( $host, $port ) = @_;
192 my $remote = IO::Socket::INET->new(
206 sub look_for_restart {
207 # give the server time to notice the change and restart
211 while ( ( $line || '' ) !~ /can connect/ ) {
212 $line = $server->getline;
214 if ( $count++ > 300 ) {
215 fail "Server restarted";
220 pass "Server restarted";
226 # give the server time to notice the change and restart
230 while ( ( $line || '' ) !~ /failed/ ) {
231 $line = $server->getline;
233 if ( $count++ > 300 ) {