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