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