line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package HTTP::Message::PSGI; |
2
|
70
|
|
|
70
|
|
511160
|
use strict; |
|
70
|
|
|
|
|
254
|
|
|
70
|
|
|
|
|
1960
|
|
3
|
70
|
|
|
70
|
|
409
|
use warnings; |
|
70
|
|
|
|
|
124
|
|
|
70
|
|
|
|
|
1938
|
|
4
|
70
|
|
|
70
|
|
2889
|
use parent qw(Exporter); |
|
70
|
|
|
|
|
2090
|
|
|
70
|
|
|
|
|
386
|
|
5
|
|
|
|
|
|
|
our @EXPORT = qw( req_to_psgi res_from_psgi ); |
6
|
|
|
|
|
|
|
|
7
|
70
|
|
|
70
|
|
4707
|
use Carp (); |
|
70
|
|
|
|
|
139
|
|
|
70
|
|
|
|
|
1448
|
|
8
|
70
|
|
|
70
|
|
4288
|
use HTTP::Status qw(status_message); |
|
70
|
|
|
|
|
40110
|
|
|
70
|
|
|
|
|
8652
|
|
9
|
70
|
|
|
70
|
|
3826
|
use URI::Escape (); |
|
70
|
|
|
|
|
9343
|
|
|
70
|
|
|
|
|
1393
|
|
10
|
70
|
|
|
70
|
|
9087
|
use Plack::Util; |
|
70
|
|
|
|
|
157
|
|
|
70
|
|
|
|
|
1874
|
|
11
|
70
|
|
|
70
|
|
25212
|
use Try::Tiny; |
|
70
|
|
|
|
|
101014
|
|
|
70
|
|
|
|
|
80116
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
my $TRUE = (1 == 1); |
14
|
|
|
|
|
|
|
my $FALSE = !$TRUE; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
sub req_to_psgi { |
17
|
346
|
|
|
346
|
1
|
61431
|
my $req = shift; |
18
|
|
|
|
|
|
|
|
19
|
346
|
50
|
|
346
|
|
1712
|
unless (try { $req->isa('HTTP::Request') }) { |
|
346
|
|
|
|
|
9675
|
|
20
|
0
|
|
|
|
|
0
|
Carp::croak("Request is not HTTP::Request: $req"); |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# from HTTP::Request::AsCGI |
24
|
346
|
|
|
|
|
4953
|
my $host = $req->header('Host'); |
25
|
346
|
|
|
|
|
17711
|
my $uri = $req->uri->clone; |
26
|
346
|
100
|
|
|
|
4731
|
$uri->scheme('http') unless $uri->scheme; |
27
|
346
|
100
|
|
|
|
8540
|
$uri->host('localhost') unless $uri->host; |
28
|
346
|
50
|
|
|
|
9240
|
$uri->port(80) unless $uri->port; |
29
|
346
|
100
|
66
|
|
|
7651
|
$uri->host_port($host) unless !$host || ( $host eq $uri->host_port ); |
30
|
|
|
|
|
|
|
|
31
|
346
|
|
|
|
|
885
|
my $input; |
32
|
346
|
|
|
|
|
945
|
my $content = $req->content; |
33
|
346
|
50
|
|
|
|
3833
|
if (ref $content eq 'CODE') { |
34
|
0
|
0
|
|
|
|
0
|
if (defined $req->content_length) { |
35
|
0
|
|
|
|
|
0
|
$input = HTTP::Message::PSGI::ChunkedInput->new($content); |
36
|
|
|
|
|
|
|
} else { |
37
|
0
|
|
|
|
|
0
|
$req->header("Transfer-Encoding" => "chunked"); |
38
|
0
|
|
|
|
|
0
|
$input = HTTP::Message::PSGI::ChunkedInput->new($content, 1); |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
} else { |
41
|
66
|
|
|
66
|
|
414
|
open $input, "<", \$content; |
|
66
|
|
|
|
|
122
|
|
|
66
|
|
|
|
|
416
|
|
|
346
|
|
|
|
|
4893
|
|
42
|
346
|
100
|
|
|
|
47729
|
$req->content_length(length $content) |
43
|
|
|
|
|
|
|
unless defined $req->content_length; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
346
|
50
|
100
|
|
|
23310
|
my $env = { |
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
47
|
|
|
|
|
|
|
PATH_INFO => URI::Escape::uri_unescape($uri->path || '/'), |
48
|
|
|
|
|
|
|
QUERY_STRING => $uri->query || '', |
49
|
|
|
|
|
|
|
SCRIPT_NAME => '', |
50
|
|
|
|
|
|
|
SERVER_NAME => $uri->host, |
51
|
|
|
|
|
|
|
SERVER_PORT => $uri->port, |
52
|
|
|
|
|
|
|
SERVER_PROTOCOL => $req->protocol || 'HTTP/1.1', |
53
|
|
|
|
|
|
|
REMOTE_ADDR => '127.0.0.1', |
54
|
|
|
|
|
|
|
REMOTE_HOST => 'localhost', |
55
|
|
|
|
|
|
|
REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875 |
56
|
|
|
|
|
|
|
REQUEST_URI => $uri->path_query || '/', # not in RFC 3875 |
57
|
|
|
|
|
|
|
REQUEST_METHOD => $req->method, |
58
|
|
|
|
|
|
|
'psgi.version' => [ 1, 1 ], |
59
|
|
|
|
|
|
|
'psgi.url_scheme' => $uri->scheme eq 'https' ? 'https' : 'http', |
60
|
|
|
|
|
|
|
'psgi.input' => $input, |
61
|
|
|
|
|
|
|
'psgi.errors' => *STDERR, |
62
|
|
|
|
|
|
|
'psgi.multithread' => $FALSE, |
63
|
|
|
|
|
|
|
'psgi.multiprocess' => $FALSE, |
64
|
|
|
|
|
|
|
'psgi.run_once' => $TRUE, |
65
|
|
|
|
|
|
|
'psgi.streaming' => $TRUE, |
66
|
|
|
|
|
|
|
'psgi.nonblocking' => $FALSE, |
67
|
|
|
|
|
|
|
@_, |
68
|
|
|
|
|
|
|
}; |
69
|
|
|
|
|
|
|
|
70
|
346
|
|
|
|
|
44033
|
for my $field ( $req->headers->header_field_names ) { |
71
|
394
|
|
|
|
|
8854
|
my $key = uc("HTTP_$field"); |
72
|
394
|
|
|
|
|
667
|
$key =~ tr/-/_/; |
73
|
394
|
100
|
|
|
|
2197
|
$key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/; |
74
|
|
|
|
|
|
|
|
75
|
394
|
50
|
|
|
|
1066
|
unless ( exists $env->{$key} ) { |
76
|
394
|
|
|
|
|
838
|
$env->{$key} = $req->headers->header($field); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
346
|
50
|
|
|
|
12547
|
if ($env->{SCRIPT_NAME}) { |
81
|
0
|
|
|
|
|
0
|
$env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E/\//; |
82
|
0
|
|
|
|
|
0
|
$env->{PATH_INFO} =~ s/^\/+/\//; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
346
|
100
|
100
|
|
|
1364
|
if (!defined($env->{HTTP_HOST}) && $req->uri->can('host')) { |
86
|
336
|
|
|
|
|
3391
|
$env->{HTTP_HOST} = $req->uri->host; |
87
|
336
|
100
|
|
|
|
9363
|
$env->{HTTP_HOST} .= ':' . $req->uri->port |
88
|
|
|
|
|
|
|
if $req->uri->port ne $req->uri->default_port; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
346
|
|
|
|
|
10710
|
return $env; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub res_from_psgi { |
95
|
328
|
|
|
328
|
1
|
578
|
my ($psgi_res) = @_; |
96
|
|
|
|
|
|
|
|
97
|
328
|
|
|
|
|
1565
|
require HTTP::Response; |
98
|
|
|
|
|
|
|
|
99
|
328
|
|
|
|
|
450
|
my $res; |
100
|
328
|
100
|
|
|
|
863
|
if (ref $psgi_res eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
101
|
291
|
|
|
|
|
668
|
_res_from_psgi($psgi_res, \$res); |
102
|
|
|
|
|
|
|
} elsif (ref $psgi_res eq 'CODE') { |
103
|
|
|
|
|
|
|
$psgi_res->(sub { |
104
|
33
|
|
|
33
|
|
111
|
_res_from_psgi($_[0], \$res); |
105
|
35
|
|
|
|
|
200
|
}); |
106
|
|
|
|
|
|
|
} else { |
107
|
2
|
100
|
|
|
|
252
|
Carp::croak("Bad response: ", defined $psgi_res ? $psgi_res : 'undef'); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
324
|
|
|
|
|
1693
|
return $res; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub _res_from_psgi { |
114
|
324
|
|
|
324
|
|
474
|
my ($status, $headers, $body) = @{+shift}; |
|
324
|
|
|
|
|
871
|
|
115
|
324
|
|
|
|
|
486
|
my $res_ref = shift; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
my $convert_resp = sub { |
118
|
324
|
|
|
324
|
|
1147
|
my $res = HTTP::Response->new($status); |
119
|
324
|
|
|
|
|
13824
|
$res->message(status_message($status)); |
120
|
324
|
100
|
|
|
|
4080
|
$res->headers->header(@$headers) if @$headers; |
121
|
|
|
|
|
|
|
|
122
|
324
|
100
|
|
|
|
18129
|
if (ref $body eq 'ARRAY') { |
123
|
293
|
|
|
|
|
1680
|
$res->content(join '', grep defined, @$body); |
124
|
|
|
|
|
|
|
} else { |
125
|
31
|
|
|
|
|
175
|
local $/ = \4096; |
126
|
31
|
|
|
|
|
47
|
my $content = ''; |
127
|
31
|
|
|
|
|
582
|
while (defined(my $buf = $body->getline)) { |
128
|
93
|
|
|
|
|
4371
|
$content .= $buf; |
129
|
|
|
|
|
|
|
} |
130
|
31
|
|
|
|
|
578
|
$body->close; |
131
|
31
|
|
|
|
|
2704
|
$res->content($content); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
324
|
|
|
|
|
6146
|
${ $res_ref } = $res; |
|
324
|
|
|
|
|
530
|
|
135
|
|
|
|
|
|
|
|
136
|
324
|
|
|
|
|
2738
|
return; |
137
|
324
|
|
|
|
|
1429
|
}; |
138
|
|
|
|
|
|
|
|
139
|
324
|
100
|
|
|
|
805
|
if (!defined $body) { |
140
|
15
|
|
|
|
|
41
|
$body = []; |
141
|
|
|
|
|
|
|
my $o = Plack::Util::inline_object |
142
|
21
|
|
|
21
|
|
60
|
write => sub { push @$body, @_ }, |
143
|
15
|
|
|
|
|
83
|
close => $convert_resp; |
144
|
|
|
|
|
|
|
|
145
|
15
|
|
|
|
|
57
|
return $o; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
309
|
|
|
|
|
579
|
$convert_resp->(); |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
sub HTTP::Request::to_psgi { |
152
|
290
|
|
|
290
|
0
|
18900
|
req_to_psgi(@_); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub HTTP::Response::from_psgi { |
156
|
291
|
|
|
291
|
0
|
2505
|
my $class = shift; |
157
|
291
|
|
|
|
|
702
|
res_from_psgi(@_); |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
package |
161
|
|
|
|
|
|
|
HTTP::Message::PSGI::ChunkedInput; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
sub new { |
164
|
0
|
|
|
0
|
|
|
my($class, $content, $chunked) = @_; |
165
|
|
|
|
|
|
|
|
166
|
0
|
|
|
|
|
|
my $content_cb; |
167
|
0
|
0
|
|
|
|
|
if ($chunked) { |
168
|
0
|
|
|
|
|
|
my $done; |
169
|
|
|
|
|
|
|
$content_cb = sub { |
170
|
0
|
|
|
0
|
|
|
my $chunk = $content->(); |
171
|
0
|
0
|
|
|
|
|
return if $done; |
172
|
0
|
0
|
|
|
|
|
unless (defined $chunk) { |
173
|
0
|
|
|
|
|
|
$done = 1; |
174
|
0
|
|
|
|
|
|
return "0\015\012\015\012"; |
175
|
|
|
|
|
|
|
} |
176
|
0
|
0
|
|
|
|
|
return '' unless length $chunk; |
177
|
0
|
|
|
|
|
|
return sprintf('%x', length $chunk) . "\015\012$chunk\015\012"; |
178
|
0
|
|
|
|
|
|
}; |
179
|
|
|
|
|
|
|
} else { |
180
|
0
|
|
|
|
|
|
$content_cb = $content; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
0
|
|
|
|
|
|
bless { content => $content_cb }, $class; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub read { |
187
|
0
|
|
|
0
|
|
|
my $self = shift; |
188
|
|
|
|
|
|
|
|
189
|
0
|
|
|
|
|
|
my $chunk = $self->{content}->(); |
190
|
0
|
0
|
|
|
|
|
return 0 unless defined $chunk; |
191
|
|
|
|
|
|
|
|
192
|
0
|
|
|
|
|
|
$_[0] = ''; |
193
|
0
|
|
0
|
|
|
|
substr($_[0], $_[2] || 0, length $chunk) = $chunk; |
194
|
|
|
|
|
|
|
|
195
|
0
|
|
|
|
|
|
return length $chunk; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
0
|
|
|
sub close { } |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
package HTTP::Message::PSGI; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
1; |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
__END__ |