File Coverage

blib/lib/HTTP/Parser/XS/PP.pm
Criterion Covered Total %
statement 109 125 87.2
branch 48 78 61.5
condition 13 24 54.1
subroutine 9 9 100.0
pod 2 2 100.0
total 181 238 76.0


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