lib/Catalyst/Engine/HTTP/Daemon.pm

   1 package Catalyst::Engine::HTTP::Daemon;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::HTTP::Base';
   5
   6 use IO::Select;
   7
   8 =head1 NAME
   9
  10 Catalyst::Engine::HTTP::Daemon - Catalyst HTTP Daemon Engine
  11
  12 =head1 SYNOPSIS
  13
  14 A script using the Catalyst::Engine::HTTP::Daemon module might look like:
  15
  16     #!/usr/bin/perl -w
  17
  18     BEGIN {  $ENV{CATALYST_ENGINE} = 'HTTP::Daemon' }
  19
  20     use strict;
  21     use lib '/path/to/MyApp/lib';
  22     use MyApp;
  23
  24     MyApp->run;
  25
  26 =head1 DESCRIPTION
  27
  28 This is the Catalyst engine specialized for development and testing.
  29
  30 =head1 OVERLOADED METHODS
  31
  32 This class overloads some methods from C<Catalyst::Engine::HTTP::Base>.
  33
  34 =over 4
  35
  36 =item $c->handler
  37
  38 =cut
  39
  40 sub handler {
  41     my ( $class, $request, $response, $client ) = @_;
  42
  43     $request->uri->scheme('http');    # Force URI::http
  44     $request->uri->host( $request->header('Host') || $client->sockhost );
  45     $request->uri->port( $client->sockport );
  46
  47     my $http = Catalyst::Engine::HTTP::Base::struct->new(
  48         address  => $client->peerhost,
  49         request  => $request,
  50         response => $response
  51     );
  52
  53     $class->SUPER::handler($http);
  54 }
  55
  56 =item $c->run
  57
  58 =cut
  59
  60 sub run {
  61     my $class = shift;
  62     my $port  = shift || 3000;
  63
  64     $SIG{'PIPE'} = 'IGNORE';
  65
  66     my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new(
  67         Listen    => 1,
  68         LocalPort => $port,
  69         ReuseAddr => 1,
  70         Timeout   => 5
  71     );
  72
  73     unless ( defined $daemon ) {
  74         die(qq/Failed to create daemon. Reason: '$!'/);
  75     }
  76
  77     my $base = URI->new( $daemon->url )->canonical;
  78
  79     printf( "You can connect to your server at %s\n", $base );
  80
  81     my $select = IO::Select->new($daemon);
  82
  83     while (1) {
  84
  85         for my $client ( $select->can_read(0.1) ) {
  86
  87             if ( $client == $daemon ) {
  88                 $client = $daemon->accept;
  89                 $client->blocking(0);
  90                 $select->add($client);
  91             }
  92
  93             else {
  94                 next if $client->request;
  95                 next if $client->response;
  96
  97                 my $read = $client->sysread( my $buf, 4096 );
  98
  99                 unless ( defined($read) && length($buf) ) {
 100
 101                     $select->remove($client);
 102                     $client->close;
 103
 104                     next;
 105                 }
 106
 107                 $client->request_buffer .= $buf;
 108                 $client->request = $client->get_request;
 109             }
 110         }
 111
 112         for my $client ( $select->handles ) {
 113
 114             next if $client == $daemon;
 115             next if $client->response;
 116             next unless $client->request;
 117
 118             $client->response = HTTP::Response->new;
 119             $client->response->protocol( $client->request->protocol );
 120             $class->handler( $client->request, $client->response, $client );
 121         }
 122
 123         for my $client ( $select->can_write(0) ) {
 124
 125             next unless $client->response;
 126
 127             unless ( $client->response_buffer ) {
 128                 $client->response_buffer = $client->response->as_string;
 129                 $client->response_offset = 0;
 130             }
 131
 132             my $write = $client->syswrite( $client->response_buffer,
 133                                            $client->response_length,
 134                                            $client->response_offset );
 135
 136             $client->response_offset += $write;
 137
 138             unless ( defined($write) ) {
 139
 140                 $select->remove($client);
 141                 $client->close;
 142
 143                 next;
 144             }
 145
 146             if ( $client->response_offset == $client->response_length ) {
 147
 148                 my $connection = $client->request->header('Connection');
 149
 150                 unless ( $connection && $connection =~ /Keep-Alive/i ) {
 151                     $select->remove($client);
 152                     $client->close;
 153                 }
 154
 155                 $client->response        = undef;
 156                 $client->request         = undef;
 157                 $client->response_buffer = undef;
 158             }
 159         }
 160     }
 161 }
 162
 163 =back
 164
 165 =head1 SEE ALSO
 166
 167 L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>,
 168 L<HTTP::Daemon>.
 169
 170 =head1 AUTHOR
 171
 172 Sebastian Riedel, C<sri@cpan.org>
 173 Christian Hansen, C<ch@ngmedia.com>
 174
 175 =head1 COPYRIGHT
 176
 177 This program is free software, you can redistribute it and/or modify it under
 178 the same terms as Perl itself.
 179
 180 =cut
 181
 182 package Catalyst::Engine::HTTP::Daemon::Catalyst;
 183
 184 use strict;
 185 use base 'HTTP::Daemon';
 186
 187 sub accept {
 188     return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client');
 189 }
 190
 191 sub product_tokens {
 192     return "Catalyst/$Catalyst::VERSION";
 193 }
 194
 195 package Catalyst::Engine::HTTP::Daemon::Client;
 196
 197 use strict;
 198 use base 'HTTP::Daemon::ClientConn';
 199
 200 sub request : lvalue {
 201     my $self = shift;
 202     ${*$self}{'request'};
 203 }
 204
 205 sub request_buffer : lvalue {
 206     my $self = shift;
 207     ${*$self}{'httpd_rbuf'};
 208 }
 209
 210 sub response : lvalue {
 211     my $self = shift;
 212     ${*$self}{'response'};
 213 }
 214
 215 sub response_buffer : lvalue {
 216     my $self = shift;
 217     ${*$self}{'httpd_wbuf'};
 218 }
 219
 220 sub response_length {
 221     my $self = shift;
 222     return length( $self->response_buffer );
 223 }
 224
 225 sub response_offset : lvalue {
 226     my $self = shift;
 227     ${*$self}{'httpd_woffset'};
 228 }
 229
 230
 231 1;