Commit | Line | Data |
c7ded7aa |
1 | #!perl |
2 | |
3 | # This test tests the standalone server's auto-restart feature. |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
8 | use File::Path; |
9 | use FindBin; |
10 | use LWP::Simple; |
11 | use IO::Socket; |
12 | use Test::More; |
13 | use Time::HiRes qw/sleep/; |
14 | eval "use Catalyst::Devel 1.0;"; |
15 | |
16 | plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP}; |
17 | plan skip_all => 'Catalyst::Devel required' if $@; |
18 | eval "use File::Copy::Recursive"; |
19 | plan skip_all => 'File::Copy::Recursive required' if $@; |
20 | |
21 | plan tests => 40; |
22 | |
23 | # clean up |
24 | rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp"; |
25 | |
26 | # create a TestApp and copy the test libs into it |
27 | mkdir "$FindBin::Bin/../t/tmp"; |
28 | chdir "$FindBin::Bin/../t/tmp"; |
29 | system |
30 | "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp"; |
31 | chdir "$FindBin::Bin/.."; |
32 | File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' ); |
33 | |
34 | # remove TestApp's tests |
35 | rmtree 't/tmp/TestApp/t'; |
36 | |
37 | # spawn the standalone HTTP server |
38 | my $port = 30000 + int rand( 1 + 10000 ); |
39 | my $pid = open my $server, |
40 | "perl -I$FindBin::Bin/../lib $FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl -port $port -restart 2>&1 |" |
41 | or die "Unable to spawn standalone HTTP server: $!"; |
42 | |
43 | # wait for it to start |
44 | print "Waiting for server to start...\n"; |
45 | while ( check_port( 'localhost', $port ) != 1 ) { |
46 | sleep 1; |
47 | } |
48 | |
49 | # change various files |
50 | my @files = ( |
51 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm", |
52 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm", |
53 | "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Engine/Request/URI.pm", |
54 | ); |
55 | |
56 | # change some files and make sure the server restarts itself |
57 | for ( 1 .. 20 ) { |
58 | my $index = rand @files; |
59 | open my $pm, '>>', $files[$index] |
60 | or die "Unable to open $files[$index] for writing: $!"; |
61 | print $pm "\n"; |
62 | close $pm; |
63 | |
64 | # give the server time to notice the change and restart |
65 | my $count = 0; |
66 | sleep 1; |
67 | while ( check_port( 'localhost', $port ) != 1 ) { |
68 | |
69 | # wait for it to restart |
70 | sleep 0.1; |
71 | die "Server appears to have died" if $count++ > 50; |
72 | } |
73 | my $response = get("http://localhost:$port/action/default"); |
74 | like( $response, qr/Catalyst::Request/, 'Non-error restart, request OK' ); |
75 | |
76 | #print $server->getline; |
77 | } |
78 | |
79 | # add errors to the file and make sure server does not die or restart |
80 | for ( 1 .. 20 ) { |
81 | my $index = rand @files; |
82 | open my $pm, '>>', $files[$index] |
83 | or die "Unable to open $files[$index] for writing: $!"; |
84 | print $pm "bleh"; |
85 | close $pm; |
86 | |
87 | # give the server time to notice the change |
88 | sleep 1; |
89 | if ( check_port( 'localhost', $port ) != 1 ) { |
90 | die "Server appears to have died"; |
91 | } |
92 | my $response = get("http://localhost:$port/action/default"); |
93 | like( $response, qr/Catalyst::Request/, |
94 | 'Syntax error, no restart, request OK' ); |
95 | |
96 | #print $server->getline; |
97 | } |
98 | |
99 | # shut it down |
100 | kill 'INT', $pid; |
101 | close $server; |
102 | |
103 | # clean up |
104 | rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp"; |
105 | |
106 | sub check_port { |
107 | my ( $host, $port ) = @_; |
108 | |
109 | my $remote = IO::Socket::INET->new( |
110 | Proto => "tcp", |
111 | PeerAddr => $host, |
112 | PeerPort => $port |
113 | ); |
114 | if ($remote) { |
115 | close $remote; |
116 | return 1; |
117 | } |
118 | else { |
119 | return 0; |
120 | } |
121 | } |