line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package HTTP::Parser::XS::PP; |
2
|
6
|
|
|
6
|
|
29
|
use strict; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
174
|
|
3
|
6
|
|
|
6
|
|
27
|
use warnings; |
|
6
|
|
|
|
|
52
|
|
|
6
|
|
|
|
|
139
|
|
4
|
6
|
|
|
6
|
|
5892
|
use utf8; |
|
6
|
|
|
|
|
60
|
|
|
6
|
|
|
|
|
30
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
sub HTTP::Parser::XS::parse_http_request { |
7
|
10
|
|
|
10
|
1
|
849
|
my($chunk, $env) = @_; |
8
|
10
|
100
|
100
|
|
|
260
|
Carp::croak("second param to parse_http_request should be a hashref") unless (ref $env|| '') eq 'HASH'; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# pre-header blank lines are allowed (RFC 2616 4.1) |
11
|
9
|
|
|
|
|
33
|
$chunk =~ s/^(\x0d?\x0a)+//; |
12
|
9
|
50
|
|
|
|
22
|
return -2 unless length $chunk; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# double line break indicates end of header; parse it |
15
|
9
|
50
|
|
|
|
67
|
if ($chunk =~ /^(.*?\x0d?\x0a\x0d?\x0a)/s) { |
16
|
9
|
|
|
|
|
29
|
return _parse_header($chunk, length $1, $env); |
17
|
|
|
|
|
|
|
} |
18
|
0
|
|
|
|
|
0
|
return -2; # still waiting for unknown amount of header lines |
19
|
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub _parse_header { |
22
|
9
|
|
|
9
|
|
15
|
my($chunk, $eoh, $env) = @_; |
23
|
|
|
|
|
|
|
|
24
|
9
|
|
|
|
|
23
|
my $header = substr($chunk, 0, $eoh,''); |
25
|
9
|
|
|
|
|
13
|
$chunk =~ s/^\x0d?\x0a\x0d?\x0a//; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# parse into lines |
28
|
9
|
|
|
|
|
56
|
my @header = split /\x0d?\x0a/,$header; |
29
|
9
|
|
|
|
|
18
|
my $request = shift @header; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# join folded lines |
32
|
9
|
|
|
|
|
11
|
my @out; |
33
|
9
|
|
|
|
|
19
|
for(@header) { |
34
|
9
|
100
|
|
|
|
24
|
if(/^[ \t]+/) { |
35
|
2
|
50
|
|
|
|
6
|
return -1 unless @out; |
36
|
2
|
|
|
|
|
4
|
$out[-1] .= $_; |
37
|
|
|
|
|
|
|
} else { |
38
|
7
|
|
|
|
|
16
|
push @out, $_; |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# parse request or response line |
43
|
9
|
|
|
|
|
11
|
my $obj; |
44
|
|
|
|
|
|
|
my $minor; |
45
|
|
|
|
|
|
|
|
46
|
9
|
|
|
|
|
26
|
my ($method,$uri,$http) = split / /,$request; |
47
|
9
|
50
|
33
|
|
|
66
|
return -1 unless $http and $http =~ /^HTTP\/1\.(\d+)$/; |
48
|
9
|
|
|
|
|
16
|
$minor = $1; |
49
|
|
|
|
|
|
|
|
50
|
9
|
|
|
|
|
37
|
my($path, $query) = ( $uri =~ /^([^?#]*)(?:\?([^#]*))?/s ); |
51
|
|
|
|
|
|
|
# following validations are just needed to pass t/01simple.t |
52
|
9
|
100
|
|
|
|
29
|
if ($path =~ /%(?:[0-9a-f][^0-9a-f]|[^0-9a-f][0-9a-f])/i) { |
53
|
|
|
|
|
|
|
# invalid char in url-encoded path |
54
|
1
|
|
|
|
|
6
|
return -1; |
55
|
|
|
|
|
|
|
} |
56
|
8
|
100
|
|
|
|
21
|
if ($path =~ /%(?:[0-9a-f])$/i) { |
57
|
|
|
|
|
|
|
# partially url-encoded |
58
|
1
|
|
|
|
|
6
|
return -1; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
7
|
|
|
|
|
19
|
$env->{REQUEST_METHOD} = $method; |
62
|
7
|
|
|
|
|
12
|
$env->{REQUEST_URI} = $uri; |
63
|
7
|
|
|
|
|
38
|
$env->{SERVER_PROTOCOL} = "HTTP/1.$minor"; |
64
|
7
|
|
|
|
|
26
|
($env->{PATH_INFO} = $path) =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
|
2
|
|
|
|
|
11
|
|
65
|
7
|
|
100
|
|
|
37
|
$env->{QUERY_STRING} = $query || ''; |
66
|
7
|
|
|
|
|
13
|
$env->{SCRIPT_NAME} = ''; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# import headers |
69
|
7
|
|
|
|
|
27
|
my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/; |
70
|
7
|
|
|
|
|
11
|
my $k; |
71
|
7
|
|
|
|
|
13
|
for my $header (@out) { |
72
|
7
|
50
|
|
|
|
683
|
if ( $header =~ s/^($token): ?// ) { |
|
|
0
|
|
|
|
|
|
73
|
7
|
|
|
|
|
14
|
$k = $1; |
74
|
7
|
|
|
|
|
13
|
$k =~ s/-/_/g; |
75
|
7
|
|
|
|
|
11
|
$k = uc $k; |
76
|
|
|
|
|
|
|
|
77
|
7
|
100
|
|
|
|
20
|
if ($k !~ /^(?:CONTENT_LENGTH|CONTENT_TYPE)$/) { |
78
|
5
|
|
|
|
|
9
|
$k = "HTTP_$k"; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
} elsif ( $header =~ /^\s+/) { |
81
|
|
|
|
|
|
|
# multiline header |
82
|
|
|
|
|
|
|
} else { |
83
|
0
|
|
|
|
|
0
|
return -1; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
7
|
100
|
|
|
|
18
|
if (exists $env->{$k}) { |
87
|
2
|
|
|
|
|
8
|
$env->{$k} .= ", $header"; |
88
|
|
|
|
|
|
|
} else { |
89
|
5
|
|
|
|
|
14
|
$env->{$k} = $header; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
7
|
|
|
|
|
60
|
return $eoh; |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# ---------------------------------------------------------- |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
my %PARSER_FUNC = ( |
99
|
|
|
|
|
|
|
HTTP::Parser::XS::HEADERS_NONE() => \&_parse_as_none, |
100
|
|
|
|
|
|
|
HTTP::Parser::XS::HEADERS_AS_HASHREF() => \&_parse_as_hashref, |
101
|
|
|
|
|
|
|
HTTP::Parser::XS::HEADERS_AS_ARRAYREF() => \&_parse_as_arrayref, |
102
|
|
|
|
|
|
|
); |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub HTTP::Parser::XS::parse_http_response { |
105
|
37
|
|
|
37
|
1
|
43288
|
my ($str, $header_format, $special_headers) = @_; |
106
|
37
|
50
|
|
|
|
99
|
return -2 unless $str; |
107
|
|
|
|
|
|
|
|
108
|
37
|
|
|
|
|
52
|
my $len = length $str; |
109
|
|
|
|
|
|
|
|
110
|
37
|
|
|
|
|
226
|
my ($sl, $remain) = split /\r?\n/, $_[0], 2; |
111
|
37
|
|
|
|
|
113
|
my ($proto, $rc, $msg) = split(' ', $sl, 3); |
112
|
37
|
100
|
|
|
|
170
|
return -1 unless $proto =~m{^HTTP/1.(\d)}; |
113
|
36
|
|
|
|
|
72
|
my $minor_version = $1; |
114
|
36
|
50
|
|
|
|
143
|
return -1 unless $rc =~m/^\d+$/; |
115
|
|
|
|
|
|
|
|
116
|
36
|
|
|
|
|
153
|
my ($header_str, $content) = split /\r?\n\r?\n/, $remain, 2; |
117
|
|
|
|
|
|
|
|
118
|
36
|
|
|
|
|
113
|
my $parser_func = $PARSER_FUNC{$header_format}; |
119
|
36
|
50
|
|
|
|
76
|
die 'unknown header format: '. $header_format unless $parser_func; |
120
|
|
|
|
|
|
|
|
121
|
36
|
|
50
|
|
|
196
|
my $header = $parser_func->($header_str, $special_headers || +{}); |
122
|
|
|
|
|
|
|
|
123
|
36
|
50
|
66
|
|
|
287
|
return -2 if ($str !~/\r?\n\r?\n/ && $remain !~/\r?\n\r?\n/ && !defined $content); |
|
|
|
33
|
|
|
|
|
124
|
34
|
100
|
|
|
|
103
|
my $parsed = $len - (defined $content ? length $content : 0); |
125
|
|
|
|
|
|
|
|
126
|
34
|
|
|
|
|
172
|
return ($parsed, $minor_version, $rc, $msg, $header); |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# return special headers only |
130
|
|
|
|
|
|
|
sub _parse_as_none { |
131
|
8
|
|
|
8
|
|
15
|
my ($str, $special) = @_; |
132
|
8
|
50
|
|
|
|
27
|
return unless defined $str; |
133
|
8
|
50
|
|
|
|
32
|
return unless keys %$special; |
134
|
|
|
|
|
|
|
|
135
|
0
|
|
|
|
|
0
|
my ($field, $value, $f); |
136
|
0
|
|
|
|
|
0
|
for ( split /\r?\n/, $str ) { |
137
|
0
|
0
|
|
|
|
0
|
if ( defined $field ) { |
138
|
0
|
0
|
0
|
|
|
0
|
if ( ord == 9 || ord == 32 ) { |
139
|
0
|
|
|
|
|
0
|
$value .= "\n$_"; |
140
|
0
|
|
|
|
|
0
|
next; |
141
|
|
|
|
|
|
|
} |
142
|
0
|
|
|
|
|
0
|
$f = lc($field); |
143
|
0
|
0
|
|
|
|
0
|
exists $special->{$f} and $special->{$f} = $value; |
144
|
|
|
|
|
|
|
} |
145
|
0
|
|
|
|
|
0
|
( $field, $value ) = split /[ \t]*: ?/, $_, 2; |
146
|
|
|
|
|
|
|
} |
147
|
0
|
0
|
|
|
|
0
|
if ( defined $field ) { |
148
|
0
|
|
|
|
|
0
|
$f = lc($field); |
149
|
0
|
0
|
|
|
|
0
|
exists $special->{$f} and $special->{$f} = $value; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# return headers as arrayref |
154
|
|
|
|
|
|
|
sub _parse_as_arrayref { |
155
|
8
|
|
|
8
|
|
15
|
my ($str, $special) = @_; |
156
|
8
|
50
|
|
|
|
21
|
return [] unless defined $str; |
157
|
|
|
|
|
|
|
|
158
|
8
|
|
|
|
|
10
|
my (@headers, $field, $value, $f ); |
159
|
8
|
|
|
|
|
38
|
for ( split /\r?\n/, $str ) { |
160
|
12
|
100
|
|
|
|
31
|
if ( defined $field ) { |
161
|
5
|
100
|
66
|
|
|
72
|
if ( ord == 9 || ord == 32 ) { |
162
|
1
|
|
|
|
|
4
|
$value .= "\n$_"; |
163
|
1
|
|
|
|
|
4
|
next; |
164
|
|
|
|
|
|
|
} |
165
|
4
|
|
|
|
|
10
|
$f = lc($field); |
166
|
4
|
|
|
|
|
9
|
push @headers, $f, $value; |
167
|
4
|
50
|
|
|
|
12
|
exists $special->{$f} and $special->{$f} = $value; |
168
|
|
|
|
|
|
|
} |
169
|
11
|
|
|
|
|
59
|
( $field, $value ) = split /[ \t]*: ?/, $_, 2; |
170
|
|
|
|
|
|
|
} |
171
|
8
|
100
|
|
|
|
25
|
if ( defined $field ) { |
172
|
7
|
|
|
|
|
13
|
$f = lc($field); |
173
|
7
|
|
|
|
|
17
|
push @headers, $f, $value; |
174
|
7
|
50
|
|
|
|
25
|
exists $special->{$f} and $special->{$f} = $value; |
175
|
|
|
|
|
|
|
} |
176
|
8
|
|
|
|
|
22
|
return \@headers; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# return headers as HTTP::Header compatible HashRef |
180
|
|
|
|
|
|
|
sub _parse_as_hashref { |
181
|
20
|
|
|
20
|
|
41
|
my ($str, $special) = @_; |
182
|
20
|
100
|
|
|
|
54
|
return +{} unless defined $str; |
183
|
|
|
|
|
|
|
|
184
|
19
|
|
|
|
|
25
|
my ( %self, $field, $value, $f ); |
185
|
19
|
|
|
|
|
82
|
for ( split /\r?\n/, $str ) { |
186
|
31
|
100
|
|
|
|
70
|
if ( defined $field ) { |
187
|
14
|
100
|
66
|
|
|
102
|
if ( ord == 9 || ord == 32 ) { |
188
|
3
|
|
|
|
|
9
|
$value .= "\n$_"; |
189
|
3
|
|
|
|
|
7
|
next; |
190
|
|
|
|
|
|
|
} |
191
|
11
|
|
|
|
|
22
|
$f = lc($field); |
192
|
11
|
50
|
|
|
|
30
|
if ( defined $self{$f} ) { |
193
|
0
|
|
|
|
|
0
|
my $h = $self{$f}; |
194
|
0
|
0
|
|
|
|
0
|
ref($h) eq 'ARRAY' |
195
|
|
|
|
|
|
|
? push( @$h, $value ) |
196
|
|
|
|
|
|
|
: ( $self{$f} = [ $h, $value ] ); |
197
|
|
|
|
|
|
|
} |
198
|
11
|
|
|
|
|
40
|
else { $self{$f} = $value } |
199
|
|
|
|
|
|
|
} |
200
|
28
|
|
|
|
|
172
|
( $field, $value ) = split /[ \t]*: ?/, $_, 2; |
201
|
|
|
|
|
|
|
} |
202
|
19
|
100
|
|
|
|
79
|
if ( defined $field ) { |
203
|
17
|
|
|
|
|
95
|
$f = lc($field); |
204
|
17
|
100
|
|
|
|
39
|
if ( defined $self{$f} ) { |
205
|
3
|
|
|
|
|
6
|
my $h = $self{$f}; |
206
|
3
|
50
|
|
|
|
551
|
ref($h) eq 'ARRAY' |
207
|
|
|
|
|
|
|
? push( @$h, $value ) |
208
|
|
|
|
|
|
|
: ( $self{$f} = [ $h, $value ] ); |
209
|
|
|
|
|
|
|
} |
210
|
14
|
|
|
|
|
34
|
else { $self{$f} = $value } |
211
|
|
|
|
|
|
|
} |
212
|
19
|
|
|
|
|
51
|
return \%self; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
1; |
216
|
|
|
|
|
|
|
|