File Coverage

blib/lib/FCGI/Async/PSGI.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	14	18	77.7
condition	1	2	50.0
subroutine	9	9	100.0
pod	2	3	66.6
total	79	85	92.9

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2010 -- [e-mail]

package FCGI::Async::PSGI;

use strict;
use warnings;

use Carp;

use base qw( FCGI::Async );

our $VERSION = '0.22';

my $CRLF = "\x0d\x0a";

=head1 NAME

C - use C applications with C

=head1 SYNOPSIS

 use FCGI::Async::PSGI;
 use IO::Async::Loop;

 my $loop = IO::Async::Loop->new;

 my $fcgi = FCGI::Async::PSGI->new(
    port => 12345,
    app => sub {
       my $env = shift;

       return [
          200,
          [ "Content-Type" => "text/plain" ],
          [ "Hello, world!" ],
       ];
    },
 );

 $loop->add( $fcgi );

 $loop->loop_forever;

=head1 DESCRIPTION

This subclass of L allows a FastCGI responder to use a L
application to respond to requests. It acts as a gateway between the FastCGI
connection from the webserver, and the C application. Aside from the use
of C instead of the C callback, this class behaves similarly
to C.

=cut

sub new
{
   # FCGI::Async's constructor tries to pass on all the args to $loop->listen
   # so we need to pull out app, if present
   my $class = shift;
   my %args = @_;

   my $app = delete $args{app};

   my $self = $class->SUPER::new(
      %args,
      on_request => sub {
         my $self = shift;
         my ( $req ) = @_;

         $self->process_request( $req );
      },
   );

   $self->configure( app => $app ) if defined $app;

   return $self;
}

=head1 PARAMETERS

The following named parameters may be passed to C or C:

=over 8

=item app => CODE

Reference to the actual C application to use for responding to requests

=back

=cut

sub configure
{
   my $self = shift;
   my %args = @_;

   if( exists $args{app} ) {
      $self->{app} = delete $args{app};
   }

   $self->SUPER::configure( %args );
}

=head1 PSGI ENVIRONMENT

The following extra keys are supplied to the environment of the C app:

=over 8

=item C

The C object serving the request

=item C

The L object representing this particular request

=item C

The L object that the C object is a member
of. This is also provided as C for backward-compatibility
with version 0.21, but at some point will be removed.

=back

=cut

sub process_request
{
   my $self = shift;
   my ( $req ) = @_;

   # Much of this code stolen fro^W^Winspired by Plack::Handler::Net::FastCGI

   my %env = (
      %{ $req->params },
      'psgi.version'      => [1,0],
      'psgi.url_scheme'   => ($req->param("HTTPS")||"off") =~ m/^(?:on|1)/i ? "https" : "http",
      'psgi.input'        => $req->stdin,
      'psgi.errors'       => $req->stderr,
      'psgi.multithread'  => 0,
      'psgi.multiprocess' => 0,
      'psgi.run_once'     => 0,
      'psgi.nonblocking'  => 1,
      'psgi.streaming'    => 1,

      # Extensions
      'fcgi.async'      => $self,
      'fcgi.async.req'  => $req,
      'fcgi.async.loop' => $self->get_loop,
      'io.async.loop'   => $self->get_loop,
   );

   my $resp = $self->{app}->( \%env );

   my $responder = sub {
      my ( $status, $headers, $body ) = @{ +shift };

      $req->print_stdout( "Status: $status$CRLF" );
      while( my ( $header, $value ) = splice @$headers, 0, 2 ) {
         $req->print_stdout( "$header: $value$CRLF" );
      }
      $req->print_stdout( $CRLF );

      if( !defined $body ) {
         croak "Responder given no body in void context" unless defined wantarray;

         return $req->stdout_with_close;
      }

      if( ref $body eq "ARRAY" ) {
         $req->print_stdout( $_ ) for @$body;
         $req->finish( 0 );
      }
      else {
         $req->stream_stdout_then_finish(
            sub {
               local $/ = \8192;
               my $buffer = $body->getline;
               defined $buffer and return $buffer;

               $body->close;
               return undef;
            },
            0
         );
      }
   };

   if( ref $resp eq "ARRAY" ) {
      $responder->( $resp );
   }
   elsif( ref $resp eq "CODE" ) {
      $resp->( $responder );
   }
}

# Keep perl happy; keep Britain tidy
1;

__END__