File Coverage

blib/lib/Catalyst/Engine/HTTP.pm
Criterion Covered Total %
statement 42 241 17.4
branch 0 100 0.0
condition 1 31 3.2
subroutine 14 27 51.9
pod 6 6 100.0
total 63 405 15.6


line stmt bran cond sub pod time code
1             package Catalyst::Engine::HTTP;
2              
3 1     1   13 use strict;
  1         26  
  1         17  
4 1     1   15 use base 'Catalyst::Engine::CGI';
  1         9  
  1         19  
5 1     1   15 use Data::Dump qw(dump);
  1         9  
  1         18  
6 1     1   16 use Errno 'EWOULDBLOCK';
  1         9  
  1         38  
7 1     1   34 use HTTP::Date ();
  1         11  
  1         10  
8 1     1   16 use HTTP::Headers;
  1         11  
  1         21  
9 1     1   29 use HTTP::Status;
  1         9  
  1         27  
10 1     1   26 use NEXT;
  1         10  
  1         21  
11 1     1   16 use Socket;
  1         10  
  1         21  
12 1     1   28 use IO::Socket::INET ();
  1         10  
  1         9  
13 1     1   37 use IO::Select ();
  1         11  
  1         11  
14              
15             # For PAR
16             require Catalyst::Engine::HTTP::Restarter;
17             require Catalyst::Engine::HTTP::Restarter::Watcher;
18              
19 1     1   18 use constant CHUNKSIZE => 64 * 1024;
  1         9  
  1         19  
20 1   50 1   17 use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0;
  1         9  
  1         21  
21              
22             =head1 NAME
23            
24             Catalyst::Engine::HTTP - Catalyst HTTP Engine
25            
26             =head1 SYNOPSIS
27            
28             A script using the Catalyst::Engine::HTTP module might look like:
29            
30             #!/usr/bin/perl -w
31            
32             BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP' }
33            
34             use strict;
35             use lib '/path/to/MyApp/lib';
36             use MyApp;
37            
38             MyApp->run;
39            
40             =head1 DESCRIPTION
41            
42             This is the Catalyst engine specialized for development and testing.
43            
44             =head1 METHODS
45            
46             =head2 $self->finalize_headers($c)
47            
48             =cut
49              
50             sub finalize_headers {
51 0     0 1       my ( $self, $c ) = @_;
52 0               my $protocol = $c->request->protocol;
53 0               my $status = $c->response->status;
54 0               my $message = status_message($status);
55                 
56 0               my @headers;
57 0               push @headers, "$protocol $status $message";
58                 
59 0               $c->response->headers->header( Date => HTTP::Date::time2str(time) );
60 0               $c->response->headers->header( Status => $status );
61                 
62             # Should we keep the connection open?
63 0               my $connection = $c->request->header('Connection');
64 0 0 0           if ( $self->{options}->{keepalive}
      0        
65                     && $connection
66                     && $connection =~ /^keep-alive$/i
67                 ) {
68 0                   $c->response->headers->header( Connection => 'keep-alive' );
69 0                   $self->{_keepalive} = 1;
70                 }
71                 else {
72 0                   $c->response->headers->header( Connection => 'close' );
73                 }
74                 
75 0               push @headers, $c->response->headers->as_string("\x0D\x0A");
76                 
77             # Buffer the headers so they are sent with the first write() call
78             # This reduces the number of TCP packets we are sending
79 0               $self->{_header_buf} = join("\x0D\x0A", @headers, '');
80             }
81              
82             =head2 $self->finalize_read($c)
83            
84             =cut
85              
86             sub finalize_read {
87 0     0 1       my ( $self, $c ) = @_;
88              
89             # Never ever remove this, it would result in random length output
90             # streams if STDIN eq STDOUT (like in the HTTP engine)
91 0               *STDIN->blocking(1);
92              
93 0               return $self->NEXT::finalize_read($c);
94             }
95              
96             =head2 $self->prepare_read($c)
97            
98             =cut
99              
100             sub prepare_read {
101 0     0 1       my ( $self, $c ) = @_;
102              
103             # Set the input handle to non-blocking
104 0               *STDIN->blocking(0);
105              
106 0               return $self->NEXT::prepare_read($c);
107             }
108              
109             =head2 $self->read_chunk($c, $buffer, $length)
110            
111             =cut
112              
113             sub read_chunk {
114 0     0 1       my $self = shift;
115 0               my $c = shift;
116                 
117             # If we have any remaining data in the input buffer, send it back first
118 0 0             if ( $_[0] = delete $self->{inputbuf} ) {
119 0                   my $read = length( $_[0] );
120 0                   DEBUG && warn "read_chunk: Read $read bytes from previous input buffer\n";
121 0                   return $read;
122                 }
123              
124             # support for non-blocking IO
125 0               my $rin = '';
126 0               vec( $rin, *STDIN->fileno, 1 ) = 1;
127              
128 0             READ:
129                 {
130 0                   select( $rin, undef, undef, undef );
131 0                   my $rc = *STDIN->sysread(@_);
132 0 0                 if ( defined $rc ) {
133 0                       DEBUG && warn "read_chunk: Read $rc bytes from socket\n";
134 0                       return $rc;
135                     }
136                     else {
137 0 0                     next READ if $! == EWOULDBLOCK;
138 0                       return;
139                     }
140                 }
141             }
142              
143             =head2 $self->write($c, $buffer)
144            
145             Writes the buffer to the client. Can only be called once for a request.
146            
147             =cut
148              
149             sub write {
150 0     0 1       my ( $self, $c, $buffer ) = @_;
151                 
152             # Avoid 'print() on closed filehandle Remote' warnings when using IE
153 0 0         return unless *STDOUT->opened();
154            
155 0           my $ret;
156            
157             # Prepend the headers if they have not yet been sent
158 0 0         if ( my $headers = delete $self->{_header_buf} ) {
159 0           DEBUG && warn "write: Wrote headers and first chunk (" . length($headers . $buffer) . " bytes)\n";
160 0           $ret = $self->NEXT::write( $c, $headers . $buffer );
161                 }
162                 else {
163 0                   DEBUG && warn "write: Wrote chunk (" . length($buffer) . " bytes)\n";
164 0                   $ret = $self->NEXT::write( $c, $buffer );
165                 }
166                 
167 0 0             if ( !$ret ) {
168 0                   $self->{_write_error} = $!;
169                 }
170                 
171 0               return $ret;
172             }
173              
174             =head2 run
175            
176             =cut
177              
178             # A very very simple HTTP server that initializes a CGI environment
179             sub run {
180 0     0 1       my ( $self, $class, $port, $host, $options ) = @_;
181              
182 0   0           $options ||= {};
183                 
184 0               $self->{options} = $options;
185              
186 0 0             if ($options->{background}) {
187 0                   my $child = fork;
188 0 0                 die "Can't fork: $!" unless defined($child);
189 0 0                 exit if $child;
190                 }
191              
192 0               my $restart = 0;
193 0               local $SIG{CHLD} = 'IGNORE';
194              
195 0   0           my $allowed = $options->{allowed} || { '127.0.0.1' => '255.255.255.255' };
196 0 0             my $addr = $host ? inet_aton($host) : INADDR_ANY;
197 0 0             if ( $addr eq INADDR_ANY ) {
198 0                   require Sys::Hostname;
199 0                   $host = lc Sys::Hostname::hostname();
200                 }
201                 else {
202 0   0               $host = gethostbyaddr( $addr, AF_INET ) || inet_ntoa($addr);
203                 }
204              
205             # Handle requests
206              
207             # Setup socket
208 0 0             my $daemon = IO::Socket::INET->new(
209                     Listen => SOMAXCONN,
210                     LocalAddr => inet_ntoa($addr),
211                     LocalPort => $port,
212                     Proto => 'tcp',
213                     ReuseAddr => 1,
214                     Type => SOCK_STREAM,
215                   )
216                   or die "Couldn't create daemon: $!";
217              
218 0               my $url = "http://$host";
219 0 0             $url .= ":$port" unless $port == 80;
220              
221 0               print "You can connect to your server at $url\n";
222              
223 0 0             if ($options->{background}) {
224 0 0                 open STDIN, "+</dev/null" or die $!;
225 0 0                 open STDOUT, ">&STDIN" or die $!;
226 0 0                 open STDERR, ">&STDIN" or die $!;
227 0 0                 if ( $^O !~ /MSWin32/ ) {
228 0                        require POSIX;
229 0 0                      POSIX::setsid()
230                              or die "Can't start a new session: $!";
231                     }
232                 }
233              
234 0 0             if (my $pidfile = $options->{pidfile}) {
235 0 0                 if (! open PIDFILE, "> $pidfile") {
236 0                       warn("Cannot open: $pidfile: $!");
237                     }
238 0                   print PIDFILE "$$\n";
239 0                   close PIDFILE;
240                 }
241              
242 0               my $pid = undef;
243                 
244             # Ignore broken pipes as an HTTP server should
245 0               local $SIG{PIPE} = 'IGNORE';
246                 
247                 LISTEN:
248 0               while ( !$restart ) {
249 0                   while ( accept( Remote, $daemon ) ) {
250 0                       DEBUG && warn "New connection\n";
251              
252 0                       select Remote;
253              
254 0                       Remote->blocking(1);
255                     
256             # Read until we see all headers
257 0                       $self->{inputbuf} = '';
258                         
259 0 0                     if ( !$self->_read_headers ) {
260             # Error reading, give up
261 0                           next LISTEN;
262                         }
263              
264 0                       my ( $method, $uri, $protocol ) = $self->_parse_request_line;
265                     
266 0                       DEBUG && warn "Parsed request: $method $uri $protocol\n";
267                     
268 0 0                     next unless $method;
269              
270 0 0                     unless ( uc($method) eq 'RESTART' ) {
271              
272             # Fork
273 0 0                         if ( $options->{fork} ) { next if $pid = fork }
  0 0          
274              
275 0                           $self->_handler( $class, $port, $method, $uri, $protocol );
276                         
277 0 0                         if ( my $error = delete $self->{_write_error} ) {
278 0                               DEBUG && warn "Write error: $error\n";
279 0                               close Remote;
280 0                               next LISTEN;
281                             }
282              
283 0 0                         $daemon->close if defined $pid;
284                         }
285                         else {
286 0                           my $sockdata = $self->_socket_data( \*Remote );
287 0                           my $ipaddr = _inet_addr( $sockdata->{peeraddr} );
288 0                           my $ready = 0;
289 0                           foreach my $ip ( keys %$allowed ) {
290 0                               my $mask = $allowed->{$ip};
291 0                               $ready = ( $ipaddr & _inet_addr($mask) ) == _inet_addr($ip);
292 0 0                             last if $ready;
293                             }
294 0 0                         if ($ready) {
295 0                               $restart = 1;
296 0                               last;
297                             }
298                         }
299              
300 0 0                     exit if defined $pid;
301                     }
302                     continue {
303 0                       close Remote;
304                     }
305                 }
306                 
307 0               $daemon->close;
308                 
309 0               DEBUG && warn "Shutting down\n";
310              
311 0 0             if ($restart) {
312 0                   $SIG{CHLD} = 'DEFAULT';
313 0                   wait;
314              
315             ### if the standalone server was invoked with perl -I .. we will loose
316             ### those include dirs upon re-exec. So add them to PERL5LIB, so they
317             ### are available again for the exec'ed process --kane
318 1     1   22         use Config;
  1         9  
  1         19  
319 0                   $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
320                     
321 0                   exec $^X . ' "' . $0