line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package HTTP::Message::PSGI; |
2
|
70
|
|
|
70
|
|
530538
|
use strict; |
|
70
|
|
|
|
|
257
|
|
|
70
|
|
|
|
|
2072
|
|
3
|
70
|
|
|
70
|
|
441
|
use warnings; |
|
70
|
|
|
|
|
132
|
|
|
70
|
|
|
|
|
1986
|
|
4
|
70
|
|
|
70
|
|
2864
|
use parent qw(Exporter); |
|
70
|
|
|
|
|
2161
|
|
|
70
|
|
|
|
|
396
|
|
5
|
|
|
|
|
|
|
our @EXPORT = qw( req_to_psgi res_from_psgi ); |
6
|
|
|
|
|
|
|
|
7
|
70
|
|
|
70
|
|
4647
|
use Carp (); |
|
70
|
|
|
|
|
132
|
|
|
70
|
|
|
|
|
1437
|
|
8
|
70
|
|
|
70
|
|
4405
|
use HTTP::Status qw(status_message); |
|
70
|
|
|
|
|
41253
|
|
|
70
|
|
|
|
|
8838
|
|
9
|
70
|
|
|
70
|
|
3967
|
use URI::Escape (); |
|
70
|
|
|
|
|
9437
|
|
|
70
|
|
|
|
|
1396
|
|
10
|
70
|
|
|
70
|
|
9816
|
use Plack::Util; |
|
70
|
|
|
|
|
166
|
|
|
70
|
|
|
|
|
1797
|
|
11
|
70
|
|
|
70
|
|
26347
|
use Try::Tiny; |
|
70
|
|
|
|
|
102110
|
|
|
70
|
|
|
|
|
82573
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
my $TRUE = (1 == 1); |
14
|
|
|
|
|
|
|
my $FALSE = !$TRUE; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
sub req_to_psgi { |
17
|
347
|
|
|
347
|
1
|
62382
|
my $req = shift; |
18
|
|
|
|
|
|
|
|
19
|
347
|
50
|
|
347
|
|
1698
|
unless (try { $req->isa('HTTP::Request') }) { |
|
347
|
|
|
|
|
9800
|
|
20
|
0
|
|
|
|
|
0
|
Carp::croak("Request is not HTTP::Request: $req"); |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# from HTTP::Request::AsCGI |
24
|
347
|
|
|
|
|
4909
|
my $host = $req->header('Host'); |
25
|
347
|
|
|
|
|
17707
|
my $uri = $req->uri->clone; |
26
|
347
|
100
|
|
|
|
4652
|
$uri->scheme('http') unless $uri->scheme; |
27
|
347
|
100
|
|
|
|
8675
|
$uri->host('localhost') unless $uri->host; |
28
|
347
|
50
|
|
|
|
9264
|
$uri->port(80) unless $uri->port; |
29
|
347
|
100
|
66
|
|
|
7639
|
$uri->host_port($host) unless !$host || ( $host eq $uri->host_port ); |
30
|
|
|
|
|
|
|
|
31
|
347
|
|
|
|
|
756
|
my $input; |
32
|
347
|
|
|
|
|
1022
|
my $content = $req->content; |
33
|
347
|
50
|
|
|
|
3895
|
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
|
|
417
|
open $input, "<", \$content; |
|
66
|
|
|
|
|
146
|
|
|
66
|
|
|
|
|
408
|
|
|
347
|
|
|
|
|
4826
|
|
42
|
347
|
100
|
|
|
|
48413
|
$req->content_length(length $content) |
43
|
|
|
|
|
|
|
unless defined $req->content_length; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
347
|
50
|
100
|
|
|
23664
|
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
|
347
|
|
|
|
|
45120
|
for my $field ( $req->headers->header_field_names ) { |
71
|
396
|
|
|
|
|
8781
|
my $key = uc("HTTP_$field"); |
72
|
396
|
|
|
|
|
704
|
$key =~ tr/-/_/; |
73
|
396
|
100
|
|
|
|
2257
|
$key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/; |
74
|
|
|
|
|
|
|
|
75
|
396
|
50
|
|
|
|
1071
|
unless ( exists $env->{$key} ) { |
76
|
396
|
|
|
|
|
870
|
$env->{$key} = $req->headers->header($field); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
347
|
50
|
|
|
|
12331
|
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
|
347
|
100
|
100
|
|
|
1340
|
if (!defined($env->{HTTP_HOST}) && $req->uri->can('host')) { |
86
|
337
|
|
|
|
|
3385
|
$env->{HTTP_HOST} = $req->uri->host; |
87
|
337
|
100
|
|
|
|
9411
|
$env->{HTTP_HOST} .= ':' . $req->uri->port |
88
|
|
|
|
|
|
|
if $req->uri->port ne $req->uri->default_port; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
347
|
|
|
|
|
10812
|
return $env; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub res_from_psgi { |
95
|
329
|
|
|
329
|
1
|
576
|
my ($psgi_res) = @_; |
96
|
|
|
|
|
|
|
|
97
|
329
|
|
|
|
|
1635
|
require HTTP::Response; |
98
|
|
|
|
|
|
|
|
99
|
329
|
|
|
|
|
489
|
my $res; |
100
|
329
|
100
|
|
|
|
800
|
if (ref $psgi_res eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
101
|
292
|
|
|
|
|
715
|
_res_from_psgi($psgi_res, \$res); |
102
|
|
|
|
|
|
|
} elsif (ref $psgi_res eq 'CODE') { |
103
|
|
|
|
|
|
|
$psgi_res->(sub { |
104
|
33
|
|
|
33
|
|
110
|
_res_from_psgi($_[0], \$res); |
105
|
35
|
|
|
|
|
183
|
}); |
106
|
|
|
|
|
|
|
} else { |
107
|
2
|
100
|
|
|
|
259
|
Carp::croak("Bad response: ", defined $psgi_res ? $psgi_res : 'undef'); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
325
|
|
|
|
|
1334
|
return $res; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub _res_from_psgi { |
114
|
325
|
|
|
325
|
|
399
|
my ($status, $headers, $body) = @{+shift}; |
|
325
|
|
|
|
|
841
|
|
115
|
325
|
|
|
|
|
490
|
my $res_ref = shift; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
my $convert_resp = sub { |
118
|
325
|
|
|
325
|
|
1114
|
my $res = HTTP::Response->new($status); |
119
|
325
|
|
|
|
|
14042
|
$res->message(status_message($status)); |
120
|
325
|
100
|
|
|
|
4004
|
$res->headers->header(@$headers) if @$headers; |
121
|
|
|
|
|
|
|
|
122
|
325
|
100
|
|
|
|
18106
|
if (ref $body eq 'ARRAY') { |
123
|
294
|
|
|
|
|
1683
|
$res->content(join '', grep defined, @$body); |
124
|
|
|
|
|
|
|
} else { |
125
|
31
|
|
|
|
|
162
|
local $/ = \4096; |
126
|
31
|
|
|
|
|
50
|
my $content = ''; |
127
|
31
|
|
|
|
|
587
|
while (defined(my $buf = $body->getline)) { |
128
|
93
|
|
|
|
|
4347
|
$content .= $buf; |
129
|
|
|
|
|
|
|
} |
130
|
31
|
|
|
|
|
572
|
$body->close; |
131
|
31
|
|
|
|
|
2674
|
$res->content($content); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
325
|
|
|
|
|
6153
|
${ $res_ref } = $res; |
|
325
|
|
|
|
|
541
|
|
135
|
|
|
|
|
|
|
|
136
|
325
|
|
|
|
|
2177
|
return; |
137
|
325
|
|
|
|
|
1450
|
}; |
138
|
|
|
|
|
|
|
|
139
|
325
|
100
|
|
|
|
777
|
if (!defined $body) { |
140
|
15
|
|
|
|
|
33
|
$body = []; |
141
|
|
|
|
|
|
|
my $o = Plack::Util::inline_object |
142
|
21
|
|
|
21
|
|
57
|
write => sub { push @$body, @_ }, |
143
|
15
|
|
|
|
|
78
|
close => $convert_resp; |
144
|
|
|
|
|
|
|
|
145
|
15
|
|
|
|
|
55
|
return $o; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
310
|
|
|
|
|
582
|
$convert_resp->(); |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
sub HTTP::Request::to_psgi { |
152
|
291
|
|
|
291
|
0
|
19977
|
req_to_psgi(@_); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub HTTP::Response::from_psgi { |
156
|
292
|
|
|
292
|
0
|
2502
|
my $class = shift; |
157
|
292
|
|
|
|
|
744
|
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__ |