1 package Catalyst::Engine::HTTP::Daemon;
4 use base 'Catalyst::Engine::HTTP::Base';
10 if ( $^O eq 'MSWin32' ) {
12 *EINPROGRESS = sub { 10036 };
13 *EWOULDBLOCK = sub { 10035 };
17 *IO::Socket::blocking = sub {
18 my ( $self, $blocking ) = @_;
19 my $nonblocking = $blocking ? 0 : 1;
20 ioctl( $self, 0x8004667e, \$nonblocking );
26 Errno->import( qw[EWOULDBLOCK EINPROGRESS] );
32 Catalyst::Engine::HTTP::Daemon - Catalyst HTTP Daemon Engine
36 A script using the Catalyst::Engine::HTTP::Daemon module might look like:
40 BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP::Daemon' }
43 use lib '/path/to/MyApp/lib';
50 This is the Catalyst engine specialized for development and testing.
52 =head1 OVERLOADED METHODS
54 This class overloads some methods from C<Catalyst::Engine::HTTP::Base>.
63 my ( $class, $request, $response, $client ) = @_;
65 $request->uri->scheme('http'); # Force URI::http
66 $request->uri->host( $request->header('Host') || $client->sockhost );
67 $request->uri->port( $client->sockport );
69 my $http = Catalyst::Engine::HTTP::Base::struct->new(
70 address => $client->peerhost,
75 $class->SUPER::handler($http);
84 my $port = shift || 3000;
86 $SIG{'PIPE'} = 'IGNORE';
88 my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new(
95 unless ( defined $daemon ) {
96 die(qq/Failed to create daemon. Reason: '$!'/);
99 my $base = URI->new( $daemon->url )->canonical;
101 printf( "You can connect to your server at %s\n", $base );
103 my $select = IO::Select->new($daemon);
107 for my $client ( $select->can_read(0.01) ) {
109 if ( $client == $daemon ) {
110 $client = $daemon->accept;
111 $client->timestamp = time;
112 $client->blocking(0);
113 $select->add($client);
117 next if $client->request;
118 next if $client->response;
120 my $nread = $client->sysread( my $buf, 4096 );
122 unless ( defined($nread) && length($buf) ) {
124 $select->remove($client);
130 $client->request_buffer .= $buf;
132 if ( my $request = $client->get_request ) {
133 $client->request = $request;
134 $client->timestamp = time
139 for my $client ( $select->handles ) {
141 next if $client == $daemon;
143 if ( ( time - $client->timestamp ) > 60 ) {
145 $select->remove($client);
151 next if $client->response;
152 next unless $client->request;
154 $client->response = HTTP::Response->new;
155 $client->response->protocol( $client->request->protocol );
157 $class->handler( $client->request, $client->response, $client );
160 for my $client ( $select->can_write(0.01) ) {
162 next unless $client->response;
164 unless ( $client->response_buffer ) {
165 $client->response_buffer = $client->response->as_string;
166 $client->response_offset = 0;
169 my $nwrite = $client->syswrite( $client->response_buffer,
170 $client->response_length,
171 $client->response_offset );
173 unless ( defined($nwrite) ) {
175 $select->remove($client);
181 $client->response_offset += $nwrite;
183 if ( $client->response_offset == $client->response_length ) {
185 my $connection = $client->request->header('Connection');
187 unless ( $connection && $connection =~ /Keep-Alive/i ) {
188 $select->remove($client);
192 $client->response = undef;
193 $client->request = undef;
194 $client->response_buffer = undef;
204 L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>,
209 Sebastian Riedel, C<sri@cpan.org>
210 Christian Hansen, C<ch@ngmedia.com>
214 This program is free software, you can redistribute it and/or modify it under
215 the same terms as Perl itself.
219 package Catalyst::Engine::HTTP::Daemon::Catalyst;
222 use base 'HTTP::Daemon';
225 return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client');
229 return "Catalyst/$Catalyst::VERSION";
232 package Catalyst::Engine::HTTP::Daemon::Client;
235 use base 'HTTP::Daemon::ClientConn';
237 sub request : lvalue {
239 ${*$self}{'request'};
242 sub request_buffer : lvalue {
244 ${*$self}{'httpd_rbuf'};
247 sub response : lvalue {
249 ${*$self}{'response'};
252 sub response_buffer : lvalue {
254 ${*$self}{'httpd_wbuf'};
257 sub response_length {
259 return length( $self->response_buffer );
262 sub response_offset : lvalue {
264 ${*$self}{'httpd_woffset'};
267 sub timestamp : lvalue {
269 ${*$self}{'timestamp'};