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