lib/Catalyst/Engine/SCGI.pm

   1 package Catalyst::Engine::SCGI;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI';
   5 eval "use SCGI";
   6 die "Please install SCGI\n" if $@;
   7 use IO::Socket;
   8 use Data::Dumper;
   9
  10
  11 my $uri_proto=URI->new();
  12
  13 =head1 NAME
  14
  15 Catalyst::Engine::SCGI - SCGI Engine
  16
  17 =head1 DESCRIPTION
  18
  19 This is the SCGI engine.
  20
  21 =head1 OVERLOADED METHODS
  22
  23 This class overloads some methods from C<Catalyst::Engine::CGI>.
  24
  25 =head2 $self->run($c, $port, $detach)
  26
  27 Start the SCGI server.  If $port is not set default to port 9000. If $detach is set, server will go into the background.
  28
  29 =cut
  30
  31 sub run {
  32     my ( $self, $class, $port, $detach ) = @_;
  33
  34     my $sock = 0;
  35     $port = 9000 unless defined $port;
  36     my $socket = IO::Socket::INET->new(
  37         Listen    => 5,
  38         ReuseAddr => 1,
  39         LocalPort => $port,
  40     ) or die "cannot bind to port $port: $!";
  41     $sock = SCGI->new( $socket, blocking => 1 )
  42       or die "Failed to open SCGI socket; $!";
  43
  44     $self->daemon_fork()   if defined $detach;
  45     $self->daemon_detach() if defined $detach;
  46     while ( my $request = $sock->accept ) {
  47         eval { $request->read_env };
  48         if ($@) {
  49
  50             # some error
  51         }
  52         else {
  53             $self->{_request} = $request;
  54             $class->handle_request( env => $request->env );
  55             # make sure to close once we are done.
  56             $request->close();
  57         }
  58     }
  59 }
  60
  61 =head2 $self->finalize_headers ( $c )
  62
  63  Write finalized headers to socket
  64
  65 =cut
  66 sub finalize_headers {
  67     my ( $self, $c ) = @_;
  68     $c->response->header( Status => $c->response->status );
  69     $self->{_request}->connection->print(
  70         $c->response->headers->as_string("\015\012") . "\015\012" );
  71 }
  72
  73 =head2 $self->write ( $c, $buffer )
  74
  75  Write directly to socket
  76
  77 =cut
  78 sub write {
  79     my ( $self, $c, $buffer ) = @_;
  80
  81     unless ( $self->{_prepared_write} ) {
  82         $self->prepare_write($c);
  83         $self->{_prepared_write} = 1;
  84     }
  85
  86     $self->{_request}->connection->print($buffer);
  87 }
  88
  89 =head2 $self->prepare_path($c)
  90
  91 =cut
  92 sub prepare_path {
  93     my ( $self, $c ) = @_;
  94     local (*ENV) = $self->env || \%ENV;
  95
  96     my $scheme = $c->request->secure ? 'https' : 'http';
  97     my $host      = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
  98     my $port      = $ENV{SERVER_PORT} || 80;
  99     my $base_path;
 100     if ( exists $ENV{REDIRECT_URL} ) {
 101         $base_path = $ENV{REDIRECT_URL};
 102         $base_path =~ s/$ENV{PATH_INFO}$//;
 103     }
 104     else {
 105         $base_path = $ENV{SCRIPT_NAME} || '/';
 106     }
 107
 108     my $path = $base_path . ( $ENV{PATH_INFO} || '' );
 109     $path =~ s{^/+}{};
 110
 111     my $uri = $uri_proto->clone;
 112     $uri->scheme($scheme);
 113     $uri->host($host);
 114     $uri->port($port);
 115     $uri->path($path);
 116     $uri->query( $ENV{QUERY_STRING} ) if $ENV{QUERY_STRING};
 117
 118     # sanitize the URI
 119     $uri = $uri->canonical;
 120     $c->request->uri($uri);
 121
 122     # set the base URI
 123     # base must end in a slash
 124     $base_path .= '/' unless ( $base_path =~ /\/$/ );
 125     my $base = $uri->clone;
 126
 127     my ($base_uri) = $base_path=~ /(.*?)\//;
 128     $base_uri .= '/' unless ($base_uri =~/\/$/ );
 129
 130     $base->path_query($base_uri);
 131     $c->request->base($base);
 132 }
 133
 134 =head2 $self->read_chunk ( $c, $buffer, $readlen )
 135
 136  Read Body content to $_[3]'s set length and direct output to $_[2].
 137
 138 =cut
 139 sub read_chunk {
 140     my ( $self, $c ) = @_;
 141     my $rc = read( $self->{_request}->connection, $_[2], $_[3] );
 142     return $rc;
 143 }
 144
 145 =head2 $self->daemon_fork()
 146
 147 Performs the first part of daemon initialisation.  Specifically,
 148 forking.  STDERR, etc are still connected to a terminal.
 149
 150 =cut
 151
 152 sub daemon_fork {
 153     require POSIX;
 154     fork && exit;
 155 }
 156
 157 =head2 $self->daemon_detach( )
 158
 159 Performs the second part of daemon initialisation.  Specifically,
 160 disassociates from the terminal.
 161
 162 However, this does B<not> change the current working directory to "/",
 163 as normal daemons do.  It also does not close all open file
 164 descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
 165 F</dev/null>).
 166
 167 =cut
 168
 169 sub daemon_detach {
 170     my $self = shift;
 171     print "SCGI daemon started (pid $$)\n";
 172     open STDIN,  "+</dev/null" or die $!;
 173     open STDOUT, ">&STDIN"     or die $!;
 174     open STDERR, ">&STDIN"     or die $!;
 175     POSIX::setsid();
 176 }
 177
 178 1;