File Coverage

blib/lib/Net/Async/FastCGI/PSGI.pm
Criterion Covered Total %
statement 44 44 100.0
branch 12 16 75.0
condition 1 2 50.0
subroutine 7 7 100.0
pod 2 2 100.0
total 66 71 92.9


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2010-2013 -- leonerd@leonerd.org.uk
5              
6             package Net::Async::FastCGI::PSGI;
7              
8 2     2   224528 use strict;
  2         5  
  2         201  
9 2     2   9 use warnings;
  2         3  
  2         44  
10              
11 2     2   10 use Carp;
  2         3  
  2         148  
12              
13 2     2   12 use base qw( Net::Async::FastCGI );
  2         3  
  2         1267  
14              
15             our $VERSION = '0.25';
16              
17             my $CRLF = "\x0d\x0a";
18              
19             =head1 NAME
20              
21             C - use C applications with C
22              
23             =head1 SYNOPSIS
24              
25             use Net::Async::FastCGI::PSGI;
26             use IO::Async::Loop;
27              
28             my $loop = IO::Async::Loop->new;
29              
30             my $fcgi = Net::Async::FastCGI::PSGI->new(
31             port => 12345,
32             app => sub {
33             my $env = shift;
34              
35             return [
36             200,
37             [ "Content-Type" => "text/plain" ],
38             [ "Hello, world!" ],
39             ];
40             },
41             );
42              
43             $loop->add( $fcgi );
44              
45             $loop->run;
46              
47             =head1 DESCRIPTION
48              
49             This subclass of L allows a FastCGI responder to use a
50             L application to respond to requests. It acts as a gateway between the
51             FastCGI connection from the webserver, and the C application. Aside from
52             the use of C instead of the C event, this class behaves
53             similarly to C.
54              
55             =cut
56              
57             =head1 PARAMETERS
58              
59             The following named parameters may be passed to C or C:
60              
61             =over 8
62              
63             =item app => CODE
64              
65             Reference to the actual C application to use for responding to requests
66              
67             =back
68              
69             =cut
70              
71             sub configure
72             {
73 5     5 1 3600 my $self = shift;
74 5         16 my %args = @_;
75              
76 5 50       22 if( exists $args{app} ) {
77 5         12 $self->{app} = delete $args{app};
78             }
79              
80 5         49 $self->SUPER::configure( %args );
81             }
82              
83             =head1 PSGI ENVIRONMENT
84              
85             The following extra keys are supplied to the environment of the C app:
86              
87             =over 8
88              
89             =item C
90              
91             The C object serving the request
92              
93             =item C
94              
95             The L object representing this particular
96             request
97              
98             =item C
99              
100             The L object that the C object is
101             a member of.
102              
103             =back
104              
105             =cut
106              
107             sub on_request
108             {
109 6     6 1 78 my $self = shift;
110 6         10 my ( $req ) = @_;
111              
112             # Much of this code stolen fro^W^Winspired by Plack::Handler::Net::FastCGI
113              
114 6         25 my %env = (
115 6 50 50     9 %{ $req->params },
116             'psgi.version' => [1,0],
117             'psgi.url_scheme' => ($req->param("HTTPS")||"off") =~ m/^(?:on|1)/i ? "https" : "http",
118             'psgi.input' => $req->stdin,
119             'psgi.errors' => $req->stderr,
120             'psgi.multithread' => 0,
121             'psgi.multiprocess' => 0,
122             'psgi.run_once' => 0,
123             'psgi.nonblocking' => 1,
124             'psgi.streaming' => 1,
125              
126             # Extensions
127             'net.async.fastcgi' => $self,
128             'net.async.fastcgi.req' => $req,
129             'io.async.loop' => $self->get_loop,
130             );
131              
132 6         248 my $resp = $self->{app}->( \%env );
133              
134             my $responder = sub {
135 6     6   1102 my ( $status, $headers, $body ) = @{ +shift };
  6         13  
136              
137 6         37 $req->print_stdout( "Status: $status$CRLF" );
138 6         833 while( my ( $header, $value ) = splice @$headers, 0, 2 ) {
139 6         28 $req->print_stdout( "$header: $value$CRLF" );
140             }
141 6         19 $req->print_stdout( $CRLF );
142              
143 6 100       16 if( !defined $body ) {
144 1 50       5 croak "Responder given no body in void context" unless defined wantarray;
145              
146 1         5 return $req->stdout_with_close;
147             }
148              
149 5 100       15 if( ref $body eq "ARRAY" ) {
150 4         16 $req->print_stdout( $_ ) for @$body;
151 4         17 $req->finish( 0 );
152             }
153             else {
154             $req->stream_stdout_then_finish(
155             sub {
156 2         10 local $/ = \8192;
157 2         79 my $buffer = $body->getline;
158 2 100       74 defined $buffer and return $buffer;
159              
160 1         11 $body->close;
161 1         10 return undef;
162             },
163 1         9 0
164             );
165             }
166 6         3117 };
167              
168 6 100       26 if( ref $resp eq "ARRAY" ) {
    50          
169 4         9 $responder->( $resp );
170             }
171             elsif( ref $resp eq "CODE" ) {
172 2         7 $resp->( $responder );
173             }
174             }
175              
176             =head1 SEE ALSO
177              
178             =over 4
179              
180             =item *
181              
182             L - Perl Web Server Gateway Interface Specification
183              
184             =item *
185              
186             L - FastCGI handler for Plack using L
187              
188             =back
189              
190             =head1 AUTHOR
191              
192             Paul Evans
193              
194             =cut
195              
196             0x55AA;