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 ) { |
00c8a8df |
64 | SKIP : { |
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() ) { |
0a4876c2 |
72 | skip "Server did not restart, no sense in checking further", 1; |
73 | } |
0a4876c2 |
74 | |
00c8a8df |
75 | my $response = get("http://localhost:$port/"); |
76 | like( $response, qr/Welcome to the world of Catalyst/, |
77 | 'Non-error restart, request OK' ); |
78 | } |
0a4876c2 |
79 | } |
80 | |
81 | # add errors to the file and make sure server does die |
82 | DIES_ON_ERROR: |
83 | for ( 1 .. 5 ) { |
00c8a8df |
84 | SKIP : { |
85 | my $index = rand @files; |
86 | open my $pm, '>>', $files[$index] |
87 | or die "Unable to open $files[$index] for writing: $!"; |
88 | print $pm "bleh"; |
89 | close $pm; |
90 | |
91 | if ( ! look_for_death() ) { |
0a4876c2 |
92 | skip "Server restarted, no sense in checking further", 2; |
93 | } |
0a4876c2 |
94 | |
00c8a8df |
95 | copy_test_app(); |
96 | |
97 | if ( ! look_for_restart() ) { |
0a4876c2 |
98 | skip "Server did not restart, no sense in checking further", 1; |
99 | } |
0a4876c2 |
100 | |
00c8a8df |
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' ); |
104 | } |
0a4876c2 |
105 | } |
106 | |
107 | # multiple restart directories |
108 | |
109 | # we need different options so we have to rebuild most |
110 | # of the testing environment |
111 | |
56828b49 |
112 | kill 9, $pid or die "Cannot send kill signal to $pid: $!"; |
0a4876c2 |
113 | close $server or die "Cannot close handle to server process: $!"; |
114 | wait; |
115 | |
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 |
119 | |
120 | $port += 1; |
121 | |
122 | copy_test_app(); |
123 | |
124 | @files = ( |
99e40d91 |
125 | "$appdir/lib/TestApp/Controller/Subdir1/Foo.pm", |
126 | "$appdir/lib/TestApp/Controller/Subdir2/Foo.pm", |
0a4876c2 |
127 | ); |
128 | |
0a4876c2 |
129 | ( $pid, $server ) = start_server($port); |
130 | |
131 | MULTI_DIR_RESTART: |
132 | for ( 1 .. 5 ) { |
99e40d91 |
133 | SKIP : { |
134 | my $index = rand @files; |
135 | open my $pm, '>>', $files[$index] |
136 | or die "Unable to open $files[$index] for writing: $!"; |
137 | print $pm "\n"; |
138 | close $pm; |
139 | |
140 | if ( ! look_for_restart() ) { |
0a4876c2 |
141 | skip "Server did not restart, no sense in checking further", 1; |
142 | } |
0a4876c2 |
143 | |
99e40d91 |
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' ); |
147 | } |
0a4876c2 |
148 | } |
149 | |
56828b49 |
150 | kill 9, $pid; |
0a4876c2 |
151 | close $server; |
152 | wait; |
153 | |
0a4876c2 |
154 | sub copy_test_app { |
99e40d91 |
155 | local $File::Copy::Recursive::RMTrgFil = 1; |
156 | dircopy( 't/lib/TestApp', "$appdir/lib/TestApp" ); |
0a4876c2 |
157 | } |
158 | |
159 | sub start_server { |
160 | my $port = shift; |
161 | |
162 | my $server; |
163 | my $pid = open3( |
164 | undef, $server, undef, |
99e40d91 |
165 | $^X, "-I$helper_lib", |
166 | "$appdir/script/testapp_server.pl", '--port', |
56828b49 |
167 | $port, '--restart' |
0a4876c2 |
168 | ) or die "Unable to spawn standalone HTTP server: $!"; |
169 | |
170 | # switch to non-blocking reads so we can fail gracefully instead |
171 | # of just hanging forever |
172 | $server->blocking(0); |
173 | |
174 | my $waited = 0; |
175 | |
176 | diag('Waiting for server to start...'); |
177 | while ( check_port( 'localhost', $port ) != 1 ) { |
178 | sleep 1; |
179 | $waited++; |
180 | |
181 | if ( $waited >= 10 ) { |
00c8a8df |
182 | die 'Waited 10 seconds for server to start, to no avail'; |
0a4876c2 |
183 | } |
184 | } |
185 | |
186 | return ($pid, $server); |
187 | } |
188 | |
189 | sub check_port { |
190 | my ( $host, $port ) = @_; |
191 | |
192 | my $remote = IO::Socket::INET->new( |
193 | Proto => "tcp", |
194 | PeerAddr => $host, |
195 | PeerPort => $port |
196 | ); |
197 | if ($remote) { |
198 | close $remote; |
199 | return 1; |
200 | } |
201 | else { |
202 | return 0; |
203 | } |
204 | } |
205 | |
206 | sub look_for_restart { |
207 | # give the server time to notice the change and restart |
208 | my $count = 0; |
209 | my $line; |
210 | |
211 | while ( ( $line || '' ) !~ /can connect/ ) { |
212 | $line = $server->getline; |
213 | sleep 0.1; |
214 | if ( $count++ > 300 ) { |
215 | fail "Server restarted"; |
216 | return 0; |
217 | } |
218 | }; |
219 | |
220 | pass "Server restarted"; |
221 | |
222 | return 1; |
223 | } |
224 | |
225 | sub look_for_death { |
226 | # give the server time to notice the change and restart |
227 | my $count = 0; |
228 | my $line; |
229 | |
230 | while ( ( $line || '' ) !~ /failed/ ) { |
231 | $line = $server->getline; |
232 | sleep 0.1; |
233 | if ( $count++ > 300 ) { |
234 | fail "Server died"; |
235 | return 0; |
236 | } |
237 | }; |
238 | |
239 | pass "Server died"; |
240 | |
241 | return 1; |
242 | } |