Commit | Line | Data |
0a4876c2 |
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. |
5 | |
6 | use strict; |
7 | use warnings; |
8 | |
9 | use Test::More; |
10 | BEGIN { |
11 | plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP}; |
12 | } |
13 | |
99e40d91 |
14 | use File::Spec::Functions qw(updir catdir); |
15 | use Cwd qw(abs_path); |
16 | use File::Basename qw(dirname); |
17 | use File::Temp qw(tempdir); |
18 | use File::Path qw(rmtree); |
0a4876c2 |
19 | use LWP::Simple; |
20 | use IO::Socket; |
99e40d91 |
21 | use IPC::Open3 qw(open3); |
0a4876c2 |
22 | use Time::HiRes qw/sleep/; |
23 | use Catalyst::Helper; |
99e40d91 |
24 | use File::Copy::Recursive qw(dircopy); |
0a4876c2 |
25 | |
26 | plan tests => 35; |
27 | |
99e40d91 |
28 | my $helper_lib = abs_path(catdir(dirname($INC{'Catalyst/Helper.pm'}), updir)); |
0a4876c2 |
29 | |
99e40d91 |
30 | my $tmpdir = tempdir(CLEANUP => 1); |
31 | my $appdir = catdir($tmpdir, 'TestApp'); |
0a4876c2 |
32 | |
99e40d91 |
33 | mkdir $appdir; |
0a4876c2 |
34 | |
35 | my $helper = Catalyst::Helper->new( |
36 | { |
99e40d91 |
37 | dir => $appdir, |
0a4876c2 |
38 | '.newfiles' => 1, |
39 | } |
40 | ); |
41 | |
42 | $helper->mk_app('TestApp'); |
43 | |
0a4876c2 |
44 | copy_test_app(); |
45 | |
46 | # remove TestApp's tests |
99e40d91 |
47 | rmtree "$appdir/t"; |
0a4876c2 |
48 | |
49 | # spawn the standalone HTTP server |
50 | my $port = 30000 + int rand( 1 + 10000 ); |
51 | |
52 | my ( $pid, $server ) = start_server($port); |
53 | |
54 | # change various files |
55 | my @files = ( |
99e40d91 |
56 | "$appdir/lib/TestApp.pm", |
57 | "$appdir/lib/TestApp/Controller/Foo.pm", |
58 | "$appdir/lib/TestApp/Controller/Root.pm", |
0a4876c2 |
59 | ); |
60 | |
61 | # change some files and make sure the server restarts itself |
62 | NON_ERROR_RESTART: |
63 | for ( 1 .. 5 ) { |
64 | my $index = rand @files; |
65 | open my $pm, '>>', $files[$index] |
66 | or die "Unable to open $files[$index] for writing: $!"; |
67 | print $pm "\n"; |
68 | close $pm; |
69 | |
70 | if ( ! look_for_restart() ) { |
71 | SKIP: |
72 | { |
73 | skip "Server did not restart, no sense in checking further", 1; |
74 | } |
75 | next NON_ERROR_RESTART; |
76 | } |
77 | |
78 | my $response = get("http://localhost:$port/"); |
79 | like( $response, qr/Welcome to the world of Catalyst/, |
80 | 'Non-error restart, request OK' ); |
81 | } |
82 | |
83 | # add errors to the file and make sure server does die |
84 | DIES_ON_ERROR: |
85 | for ( 1 .. 5 ) { |
86 | my $index = rand @files; |
87 | open my $pm, '>>', $files[$index] |
88 | or die "Unable to open $files[$index] for writing: $!"; |
89 | print $pm "bleh"; |
90 | close $pm; |
91 | |
92 | if ( ! look_for_death() ) { |
93 | SKIP: |
94 | { |
95 | skip "Server restarted, no sense in checking further", 2; |
96 | } |
97 | next DIES_ON_ERROR; |
98 | } |
99 | copy_test_app(); |
100 | |
101 | if ( ! look_for_restart() ) { |
102 | SKIP: |
103 | { |
104 | skip "Server did not restart, no sense in checking further", 1; |
105 | } |
106 | next DIES_ON_ERROR; |
107 | } |
108 | |
109 | my $response = get("http://localhost:$port/"); |
110 | like( $response, qr/Welcome to the world of Catalyst/, |
111 | 'Non-error restart after death, request OK' ); |
112 | } |
113 | |
114 | # multiple restart directories |
115 | |
116 | # we need different options so we have to rebuild most |
117 | # of the testing environment |
118 | |
56828b49 |
119 | kill 9, $pid or die "Cannot send kill signal to $pid: $!"; |
0a4876c2 |
120 | close $server or die "Cannot close handle to server process: $!"; |
121 | wait; |
122 | |
123 | # pick next port because the last one might still be blocked from |
124 | # previous server. This might fail if this port is unavailable |
125 | # but picking the first one has the same problem so this is acceptable |
126 | |
127 | $port += 1; |
128 | |
129 | copy_test_app(); |
130 | |
131 | @files = ( |
99e40d91 |
132 | "$appdir/lib/TestApp/Controller/Subdir1/Foo.pm", |
133 | "$appdir/lib/TestApp/Controller/Subdir2/Foo.pm", |
0a4876c2 |
134 | ); |
135 | |
0a4876c2 |
136 | ( $pid, $server ) = start_server($port); |
137 | |
138 | MULTI_DIR_RESTART: |
139 | for ( 1 .. 5 ) { |
99e40d91 |
140 | SKIP : { |
141 | my $index = rand @files; |
142 | open my $pm, '>>', $files[$index] |
143 | or die "Unable to open $files[$index] for writing: $!"; |
144 | print $pm "\n"; |
145 | close $pm; |
146 | |
147 | if ( ! look_for_restart() ) { |
0a4876c2 |
148 | skip "Server did not restart, no sense in checking further", 1; |
149 | } |
0a4876c2 |
150 | |
99e40d91 |
151 | my $response = get("http://localhost:$port/"); |
152 | like( $response, qr/Welcome to the world of Catalyst/, |
153 | 'Non-error restart with multiple watched dirs' ); |
154 | } |
0a4876c2 |
155 | } |
156 | |
56828b49 |
157 | kill 9, $pid; |
0a4876c2 |
158 | close $server; |
159 | wait; |
160 | |
0a4876c2 |
161 | sub copy_test_app { |
99e40d91 |
162 | local $File::Copy::Recursive::RMTrgFil = 1; |
163 | dircopy( 't/lib/TestApp', "$appdir/lib/TestApp" ); |
0a4876c2 |
164 | } |
165 | |
166 | sub start_server { |
167 | my $port = shift; |
168 | |
169 | my $server; |
170 | my $pid = open3( |
171 | undef, $server, undef, |
99e40d91 |
172 | $^X, "-I$helper_lib", |
173 | "$appdir/script/testapp_server.pl", '--port', |
56828b49 |
174 | $port, '--restart' |
0a4876c2 |
175 | ) or die "Unable to spawn standalone HTTP server: $!"; |
176 | |
177 | # switch to non-blocking reads so we can fail gracefully instead |
178 | # of just hanging forever |
179 | $server->blocking(0); |
180 | |
181 | my $waited = 0; |
182 | |
183 | diag('Waiting for server to start...'); |
184 | while ( check_port( 'localhost', $port ) != 1 ) { |
185 | sleep 1; |
186 | $waited++; |
187 | |
188 | if ( $waited >= 10 ) { |
189 | BAIL_OUT('Waited 10 seconds for server to start, to no avail'); |
190 | } |
191 | } |
192 | |
193 | return ($pid, $server); |
194 | } |
195 | |
196 | sub check_port { |
197 | my ( $host, $port ) = @_; |
198 | |
199 | my $remote = IO::Socket::INET->new( |
200 | Proto => "tcp", |
201 | PeerAddr => $host, |
202 | PeerPort => $port |
203 | ); |
204 | if ($remote) { |
205 | close $remote; |
206 | return 1; |
207 | } |
208 | else { |
209 | return 0; |
210 | } |
211 | } |
212 | |
213 | sub look_for_restart { |
214 | # give the server time to notice the change and restart |
215 | my $count = 0; |
216 | my $line; |
217 | |
218 | while ( ( $line || '' ) !~ /can connect/ ) { |
219 | $line = $server->getline; |
220 | sleep 0.1; |
221 | if ( $count++ > 300 ) { |
222 | fail "Server restarted"; |
223 | return 0; |
224 | } |
225 | }; |
226 | |
227 | pass "Server restarted"; |
228 | |
229 | return 1; |
230 | } |
231 | |
232 | sub look_for_death { |
233 | # give the server time to notice the change and restart |
234 | my $count = 0; |
235 | my $line; |
236 | |
237 | while ( ( $line || '' ) !~ /failed/ ) { |
238 | $line = $server->getline; |
239 | sleep 0.1; |
240 | if ( $count++ > 300 ) { |
241 | fail "Server died"; |
242 | return 0; |
243 | } |
244 | }; |
245 | |
246 | pass "Server died"; |
247 | |
248 | return 1; |
249 | } |