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; |