File Coverage

blib/lib/Catalyst/Engine/SCGI.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package Catalyst::Engine::SCGI;

use strict;
use warnings;

use base 'Catalyst::Engine::CGI';
eval "use SCGI";
die "Please install SCGI\n" if $@;
use IO::Socket;

our $VERSION = '0.03';

=head1 NAME

Catalyst::Engine::SCGI - SCGI Engine

=head1 DESCRIPTION

This is the SCGI engine.

=head1 OVERLOADED METHODS

This class overloads some methods from C<Catalyst::Engine::CGI>.

=head2 $self->run($c, $port, $detach)

Start the SCGI server.  If $port is not set default to port 9000. If $detach is set, server will go into the background.

=cut

sub run {
    my ( $self, $class, $port, $detach ) = @_;

    my $sock = 0;
    $port = 9000 unless defined $port;
    my $socket = IO::Socket::INET->new(
        Listen    => 5,
        ReuseAddr => 1,
        LocalPort => $port,
    ) or die "cannot bind to port $port: $!";
    $sock = SCGI->new( $socket, blocking => 1 )
      or die "Failed to open SCGI socket; $!";

    $self->daemon_fork()   if defined $detach;
    $self->daemon_detach() if defined $detach;
    while ( my $request = $sock->accept ) {
        eval { $request->read_env };
        if ($@) {

            # some error
        }
        else {
            $self->{_request} = $request;
            $class->handle_request( env => $request->env );
            # make sure to close once we are done.
            $request->close();
        }
    }
}

=head2 $self->finalize_headers ( $c )

 Write finalized headers to socket

=cut
sub finalize_headers {
    my ( $self, $c ) = @_;
    $c->response->header( Status => $c->response->status );
    $self->{_request}->connection->print(
        $c->response->headers->as_string("\015\012") . "\015\012" );
}

=head2 $self->write ( $c, $buffer )

 Write directly to socket

=cut
sub write {
    my ( $self, $c, $buffer ) = @_;

    unless ( $self->{_prepared_write} ) {
        $self->prepare_write($c);
        $self->{_prepared_write} = 1;
    }

    $self->{_request}->connection->print($buffer);
}

=head2 $self->read_chunk ( $c, $buffer, $readlen )

 Read Body content to $_[3]'s set length and direct output to $_[2].

=cut
sub read_chunk {
    my ( $self, $c ) = @_;
    my $rc = read( $self->{_request}->connection, $_[2], $_[3] );
    return $rc;
}

=head2 $self->daemon_fork()

Performs the first part of daemon initialisation.  Specifically,
forking.  STDERR, etc are still connected to a terminal.

=cut

sub daemon_fork {
    require POSIX;
    fork && exit;
}

=head2 $self->daemon_detach( )

Performs the second part of daemon initialisation.  Specifically,
disassociates from the terminal.

However, this does B<not> change the current working directory to "/",
as normal daemons do.  It also does not close all open file
descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
F</dev/null>).

=cut

sub daemon_detach {
    my $self = shift;
    print "SCGI daemon started (pid $$)\n";
    open STDIN,  "+</dev/null" or die $!;
    open STDOUT, ">&STDIN"     or die $!;
    open STDERR, ">&STDIN"     or die $!;
    POSIX::setsid();
}

1;