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 |
48 | rmtree 't/tmp/TestApp/t'; |
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 = ( |
57 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm", |
58 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Foo.pm", |
59 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Root.pm", |
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 = ( |
133 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Subdir1/Foo.pm", |
134 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Subdir2/Foo.pm", |
135 | ); |
136 | |
137 | my $app_root = "$FindBin::Bin/../t/tmp/TestApp"; |
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 | |
169 | rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp"; |
170 | |
171 | sub copy_test_app { |
172 | { no warnings 'once'; $File::Copy::Recursive::RMTrgFil = 1; } |
173 | copy( 't/lib/TestApp.pm', 't/tmp/TestApp/lib/TestApp.pm' ); |
174 | File::Copy::Recursive::dircopy( 't/lib/TestApp', 't/tmp/TestApp/lib/TestApp' ); |
175 | } |
176 | |
177 | sub start_server { |
178 | my $port = shift; |
179 | |
180 | my $server; |
181 | my $pid = open3( |
182 | undef, $server, undef, |
183 | $^X, "-I$FindBin::Bin/../lib", |
56828b49 |
184 | "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '--port', |
185 | $port, '--restart' |
0a4876c2 |
186 | ) or die "Unable to spawn standalone HTTP server: $!"; |
187 | |
188 | # switch to non-blocking reads so we can fail gracefully instead |
189 | # of just hanging forever |
190 | $server->blocking(0); |
191 | |
192 | my $waited = 0; |
193 | |
194 | diag('Waiting for server to start...'); |
195 | while ( check_port( 'localhost', $port ) != 1 ) { |
196 | sleep 1; |
197 | $waited++; |
198 | |
199 | if ( $waited >= 10 ) { |
200 | BAIL_OUT('Waited 10 seconds for server to start, to no avail'); |
201 | } |
202 | } |
203 | |
204 | return ($pid, $server); |
205 | } |
206 | |
207 | sub check_port { |
208 | my ( $host, $port ) = @_; |
209 | |
210 | my $remote = IO::Socket::INET->new( |
211 | Proto => "tcp", |
212 | PeerAddr => $host, |
213 | PeerPort => $port |
214 | ); |
215 | if ($remote) { |
216 | close $remote; |
217 | return 1; |
218 | } |
219 | else { |
220 | return 0; |
221 | } |
222 | } |
223 | |
224 | sub look_for_restart { |
225 | # give the server time to notice the change and restart |
226 | my $count = 0; |
227 | my $line; |
228 | |
229 | while ( ( $line || '' ) !~ /can connect/ ) { |
230 | $line = $server->getline; |
231 | sleep 0.1; |
232 | if ( $count++ > 300 ) { |
233 | fail "Server restarted"; |
234 | return 0; |
235 | } |
236 | }; |
237 | |
238 | pass "Server restarted"; |
239 | |
240 | return 1; |
241 | } |
242 | |
243 | sub look_for_death { |
244 | # give the server time to notice the change and restart |
245 | my $count = 0; |
246 | my $line; |
247 | |
248 | while ( ( $line || '' ) !~ /failed/ ) { |
249 | $line = $server->getline; |
250 | sleep 0.1; |
251 | if ( $count++ > 300 ) { |
252 | fail "Server died"; |
253 | return 0; |
254 | } |
255 | }; |
256 | |
257 | pass "Server died"; |
258 | |
259 | return 1; |
260 | } |