1 package Catalyst::Engine::HTTP;
4 use base 'Catalyst::Engine::CGI';
5 use Errno 'EWOULDBLOCK';
15 Catalyst::Engine::HTTP - Catalyst HTTP Engine
19 A script using the Catalyst::Engine::HTTP module might look like:
23 BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP' }
26 use lib '/path/to/MyApp/lib';
33 This is the Catalyst engine specialized for development and testing.
39 =item $self->finalize_headers($c)
43 sub finalize_headers {
44 my ( $self, $c ) = @_;
45 my $protocol = $c->request->protocol;
46 my $status = $c->response->status;
47 my $message = status_message($status);
48 print "$protocol $status $message\015\012";
49 $c->response->headers->date(time);
50 $self->NEXT::finalize_headers($c);
53 =item $self->finalize_read($c)
58 my ( $self, $c ) = @_;
60 # Never ever remove this, it would result in random length output
61 # streams if STDIN eq STDOUT (like in the HTTP engine)
64 return $self->NEXT::finalize_read($c);
67 =item $self->prepare_read($c)
72 my ( $self, $c ) = @_;
74 # Set the input handle to non-blocking
77 return $self->NEXT::prepare_read($c);
80 =item $self->read_chunk($c, $buffer, $length)
88 # support for non-blocking IO
90 vec( $rin, *STDIN->fileno, 1 ) = 1;
94 select( $rin, undef, undef, undef );
95 my $rc = *STDIN->sysread(@_);
100 next READ if $! == EWOULDBLOCK;
110 # A very very simple HTTP server that initializes a CGI environment
112 my ( $self, $class, $port, $host, $options ) = @_;
118 if ( $options->{restart} ) {
120 unless ( $restarter = fork ) {
126 # Index parent directory
127 my $dir = File::Spec->catdir( $FindBin::Bin, '..' );
129 my $regex = $options->{restart_regex};
130 my $one = _index( $dir, $regex );
132 sleep $options->{restart_delay} || 1;
134 # check if our parent has died
135 exit if ( getppid == 1 );
137 my $two = _index( $dir, $regex );
138 my $changes = _compare_index( $one, $two );
143 for my $file (@$changes) {
144 next unless $file =~ /\.pm$/;
145 if ( my $error = _test($file) ) {
147 qq/File "$file" modified, not restarting\n\n/;
148 print STDERR '*' x 80, "\n";
150 print STDERR '*' x 80, "\n";
156 my $files = join ', ', @$changes;
157 print STDERR qq/File(s) "$files" modified, restarting\n\n/;
168 local $SIG{HUP} = sub { $GOT_HUP = 1; };
169 local $SIG{CHLD} = 'IGNORE';
174 $host = $host ? inet_aton($host) : INADDR_ANY;
175 socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
176 || die "Couldn't assign TCP socket: $!";
177 setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
178 || die "Couldn't set TCP socket options: $!";
179 bind( HTTPDaemon, sockaddr_in( $port, $host ) )
180 || die "Couldn't bind socket to $port on $host: $!";
181 listen( HTTPDaemon, SOMAXCONN )
182 || die "Couldn't listen to socket on $port on $host: $!";
184 if ( $host eq INADDR_ANY ) {
185 require Sys::Hostname;
186 $url .= lc Sys::Hostname::hostname();
189 $url .= gethostbyaddr( $host, AF_INET ) || inet_ntoa($host);
192 print "You can connect to your server at $url\n";
194 while ( accept( Remote, HTTPDaemon ) ) {
197 if ( $options->{fork} ) { next if $pid = fork }
199 close HTTPDaemon if defined $pid;
201 # Ignore broken pipes as an HTTP server should
202 local $SIG{PIPE} = sub { close Remote };
203 local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} );
205 local *STDIN = \*Remote;
206 local *STDOUT = \*Remote;
210 my $remote_sockaddr = getpeername( \*Remote );
211 my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
212 my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
213 my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
214 my $local_sockaddr = getsockname( \*Remote );
215 my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
216 my $localname = gethostbyaddr( $localiaddr, AF_INET )
218 my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1";
223 my $line = $self->_get_line( \*STDIN );
225 unless my ( $method, $uri, $protocol ) =
226 $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/;
228 # We better be careful and just use 1.0
231 my ( $path, $query_string ) = split /\?/, $uri, 2;
233 # Initialize CGI environment
235 PATH_INFO => $path || '',
236 QUERY_STRING => $query_string || '',
237 REMOTE_ADDR => $peeraddr,
238 REMOTE_HOST => $peername,
239 REQUEST_METHOD => $method || '',
240 SERVER_NAME => $localname,
241 SERVER_PORT => $port,
242 SERVER_PROTOCOL => "HTTP/$protocol",
247 if ( $protocol >= 1 ) {
249 my $line = $self->_get_line( \*STDIN );
252 unless my ( $name, $value ) =
253 $line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/;
256 $name = 'COOKIE' if $name eq 'COOKIES';
258 $name = 'HTTP_' . $name
259 unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
260 if ( exists $ENV{$name} ) {
261 $ENV{$name} .= "; $value";
264 $ENV{$name} = $value;
269 # Pass flow control to Catalyst
270 $class->handle_request;
271 exit if defined $pid;
279 $SIG{CHLD} = 'DEFAULT';
281 exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @{ $options->{argv} } );
286 my ( $one, $two ) = @_;
289 while ( my ( $key, $val ) = each %$one ) {
290 if ( !$clone{$key} || ( $clone{$key} ne $val ) ) {
295 for my $key ( keys %clone ) { push @changes, $key }
300 my ( $self, $handle ) = @_;
304 while ( sysread( $handle, my $byte, 1 ) ) {
305 last if $byte eq "\012"; # eol
309 1 while $line =~ s/\s\z//;
315 my ( $dir, $regex ) = @_;
320 my $file = File::Spec->rel2abs($File::Find::name);
321 return unless $file =~ /$regex/;
322 return unless -f $file;
323 my $time = ( stat $file )[9];
324 $index{$file} = $time;
336 local $SIG{__WARN__} = sub { };
337 open my $olderr, '>&STDERR';
338 open STDERR, '>', File::Spec->devnull;
339 eval "require '$file'";
340 open STDERR, '>&', $olderr;
349 L<Catalyst>, L<Catalyst::Engine>.
353 Sebastian Riedel, <sri@cpan.org>
355 Dan Kubb, <dan.kubb-cpan@onautopilot.com>
359 Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
363 This program is free software, you can redistribute it and/or modify it under
364 the same terms as Perl itself.