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->read_chunk ( $c, $buffer, $readlen )
  90
  91  Read Body content to $_[3]'s set length and direct output to $_[2].
  92
  93 =cut
  94 sub read_chunk {
  95     my ( $self, $c ) = @_;
  96     my $rc = read( $self->{_request}->connection, $_[2], $_[3] );
  97     return $rc;
  98 }
  99
 100 =head2 $self->daemon_fork()
 101
 102 Performs the first part of daemon initialisation.  Specifically,
 103 forking.  STDERR, etc are still connected to a terminal.
 104
 105 =cut
 106
 107 sub daemon_fork {
 108     require POSIX;
 109     fork && exit;
 110 }
 111
 112 =head2 $self->daemon_detach( )
 113
 114 Performs the second part of daemon initialisation.  Specifically,
 115 disassociates from the terminal.
 116
 117 However, this does B<not> change the current working directory to "/",
 118 as normal daemons do.  It also does not close all open file
 119 descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
 120 F</dev/null>).
 121
 122 =cut
 123
 124 sub daemon_detach {
 125     my $self = shift;
 126     print "SCGI daemon started (pid $$)\n";
 127     open STDIN,  "+</dev/null" or die $!;
 128     open STDOUT, ">&STDIN"     or die $!;
 129     open STDERR, ">&STDIN"     or die $!;
 130     POSIX::setsid();
 131 }
 132
 133 1;