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 ) {
  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->read_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             $class->handler( $client->request, $client->response, $client );
 120         }
 121
 122         for my $client ( $select->can_write(0) ) {
 123
 124             next unless $client->response;
 125
 126             $client->send_response( $client->response );
 127
 128             my $connection = $client->request->header('Connection');
 129
 130             unless ( $connection && $connection =~ /Keep-Alive/i ) {
 131                 $select->remove($client);
 132                 $client->close;
 133             }
 134
 135             $client->request(undef);
 136             $client->response(undef);
 137         }
 138     }
 139 }
 140
 141 =back
 142
 143 =head1 SEE ALSO
 144
 145 L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>,
 146 L<HTTP::Daemon>.
 147
 148 =head1 AUTHOR
 149
 150 Sebastian Riedel, C<sri@cpan.org>
 151 Christian Hansen, C<ch@ngmedia.com>
 152
 153 =head1 COPYRIGHT
 154
 155 This program is free software, you can redistribute it and/or modify it under
 156 the same terms as Perl itself.
 157
 158 =cut
 159
 160 package Catalyst::Engine::HTTP::Daemon::Catalyst;
 161
 162 use strict;
 163 use base 'HTTP::Daemon';
 164
 165 sub accept {
 166     return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client');
 167 }
 168
 169 sub product_tokens {
 170     return "Catalyst/$Catalyst::VERSION";
 171 }
 172
 173 package Catalyst::Engine::HTTP::Daemon::Client;
 174
 175 use strict;
 176 use base 'HTTP::Daemon::ClientConn';
 177
 178 sub read_buffer {
 179     my $self = shift;
 180
 181     if (@_) {
 182         ${*$self}{'httpd_rbuf'} .= shift;
 183     }
 184
 185     return ${*$self}{'httpd_rbuf'};
 186 }
 187
 188 sub request {
 189     my $self = shift;
 190
 191     if (@_) {
 192         ${*$self}{'request'} = shift;
 193     }
 194
 195     return ${*$self}{'request'};
 196 }
 197
 198 sub response {
 199     my $self = shift;
 200
 201     if (@_) {
 202         ${*$self}{'response'} = shift;
 203     }
 204
 205     return ${*$self}{'response'};
 206 }
 207
 208 1;