File Coverage

blib/lib/Plack/Request.pm
Criterion Covered Total %
statement 149 164 90.8
branch 30 36 83.3
condition 22 33 66.6
subroutine 45 59 76.2
pod 38 40 95.0
total 284 332 85.5


line stmt bran cond sub pod time code
1             package Plack::Request;
2 65     65   646612 use strict;
  65         231  
  65         1967  
3 65     65   323 use warnings;
  65         137  
  65         1575  
4 65     65   1396 use 5.008_001;
  65         250  
5             our $VERSION = '1.0048';
6              
7 65     65   35477 use HTTP::Headers::Fast;
  65         354419  
  65         2306  
8 65     65   476 use Carp ();
  65         134  
  65         1055  
9 65     65   36326 use Hash::MultiValue;
  65         163082  
  65         2101  
10              
11 65     65   27733 use Plack::Request::Upload;
  65         205  
  65         1989  
12 65     65   28918 use Stream::Buffered;
  65         577685  
  65         1733  
13 65     65   13635 use URI;
  65         159079  
  65         1928  
14 65     65   376 use URI::Escape ();
  65         156  
  65         875  
15 65     65   30688 use Cookie::Baker ();
  65         100302  
  65         1637  
16              
17 65     65   31841 use HTTP::Entity::Parser;
  65         2630139  
  65         3659  
18 65     65   688 use WWW::Form::UrlEncoded qw/parse_urlencoded_arrayref/;
  65         131  
  65         139296  
19              
20             sub new {
21 68     68 1 29978 my($class, $env) = @_;
22 68 50 33     580 Carp::croak(q{$env is required})
23             unless defined $env && ref($env) eq 'HASH';
24              
25 68         418 bless { env => $env }, $class;
26             }
27              
28 435     435 1 2350 sub env { $_[0]->{env} }
29              
30 2     2 1 594 sub address { $_[0]->env->{REMOTE_ADDR} }
31 1     1 1 6 sub remote_host { $_[0]->env->{REMOTE_HOST} }
32 1     1 1 4 sub protocol { $_[0]->env->{SERVER_PROTOCOL} }
33 1     1 1 4 sub method { $_[0]->env->{REQUEST_METHOD} }
34 1     1 0 8597 sub port { $_[0]->env->{SERVER_PORT} }
35 0     0 1 0 sub user { $_[0]->env->{REMOTE_USER} }
36 2     2 1 19 sub request_uri { $_[0]->env->{REQUEST_URI} }
37 3     3 1 70 sub path_info { $_[0]->env->{PATH_INFO} }
38 4 50   4 1 30 sub path { $_[0]->env->{PATH_INFO} || '/' }
39 2     2 1 14 sub query_string{ $_[0]->env->{QUERY_STRING} }
40 0     0 1 0 sub script_name { $_[0]->env->{SCRIPT_NAME} }
41 1     1 1 5 sub scheme { $_[0]->env->{'psgi.url_scheme'} }
42 0     0 1 0 sub secure { $_[0]->scheme eq 'https' }
43 0     0 1 0 sub body { $_[0]->env->{'psgi.input'} }
44 13     13 1 69 sub input { $_[0]->env->{'psgi.input'} }
45              
46 0     0 1 0 sub content_length { $_[0]->env->{CONTENT_LENGTH} }
47 0     0 1 0 sub content_type { $_[0]->env->{CONTENT_TYPE} }
48              
49 0     0 1 0 sub session { $_[0]->env->{'psgix.session'} }
50 0     0 1 0 sub session_options { $_[0]->env->{'psgix.session.options'} }
51 0     0 1 0 sub logger { $_[0]->env->{'psgix.logger'} }
52              
53             sub cookies {
54 13     13 1 33 my $self = shift;
55              
56 13 100       37 return {} unless $self->env->{HTTP_COOKIE};
57              
58             # HTTP_COOKIE hasn't changed: reuse the parsed cookie
59 12 100 66     24 if ( $self->env->{'plack.cookie.parsed'}
60             && $self->env->{'plack.cookie.string'} eq $self->env->{HTTP_COOKIE}) {
61 11         18 return $self->env->{'plack.cookie.parsed'};
62             }
63              
64 1         3 $self->env->{'plack.cookie.string'} = $self->env->{HTTP_COOKIE};
65 1         4 $self->env->{'plack.cookie.parsed'} = Cookie::Baker::crush_cookie($self->env->{'plack.cookie.string'});
66             }
67              
68             sub content {
69 13     13 1 1652 my $self = shift;
70              
71 13 100       90 unless ($self->env->{'psgix.input.buffered'}) {
72 7         29 $self->_parse_request_body;
73             }
74              
75 13 50       98 my $fh = $self->input or return '';
76 13 100       47 my $cl = $self->env->{CONTENT_LENGTH} or return '';
77              
78 9         143 $fh->seek(0, 0); # just in case middleware/apps read it without seeking back
79 9         185 $fh->read(my($content), $cl, 0);
80 9         126 $fh->seek(0, 0);
81              
82 9         168 return $content;
83             }
84              
85 0     0 1 0 sub raw_body { $_[0]->content }
86              
87             # XXX you can mutate headers with ->headers but it's not written through to the env
88              
89             sub headers {
90 1     1 1 8 my $self = shift;
91 1 50       6 if (!defined $self->{headers}) {
92 1         5 my $env = $self->env;
93             $self->{headers} = HTTP::Headers::Fast->new(
94             map {
95 5         17 (my $field = $_) =~ s/^HTTPS?_//;
96 5         23 ( lc($field) => $env->{$_} );
97             }
98 1         39 grep { /^(?:HTTP|CONTENT)/i } keys %$env
  25         55  
99             );
100             }
101 1         219 $self->{headers};
102             }
103              
104 0     0 1 0 sub content_encoding { shift->headers->content_encoding(@_) }
105 0     0 1 0 sub header { shift->headers->header(@_) }
106 0     0 1 0 sub referer { shift->headers->referer(@_) }
107 0     0 1 0 sub user_agent { shift->headers->user_agent(@_) }
108              
109             sub _body_parameters {
110 12     12   22 my $self = shift;
111 12 100       29 unless ($self->env->{'plack.request.body_parameters'}) {
112 10         34 $self->_parse_request_body;
113             }
114 11         26 return $self->env->{'plack.request.body_parameters'};
115             }
116              
117             sub _query_parameters {
118 27     27   36 my $self = shift;
119 27   66     58 $self->env->{'plack.request.query_parameters'} ||= parse_urlencoded_arrayref($self->env->{'QUERY_STRING'});
120             }
121              
122             sub query_parameters {
123 18     18 1 21101 my $self = shift;
124 18   33     49 $self->env->{'plack.request.query'} ||= Hash::MultiValue->new(@{$self->_query_parameters});
  18         38  
125             }
126              
127             sub body_parameters {
128 3     3 1 30 my $self = shift;
129 3   66     11 $self->env->{'plack.request.body'} ||= Hash::MultiValue->new(@{$self->_body_parameters});
  3         17  
130             }
131              
132             # contains body + query
133             sub parameters {
134 17     17 1 1577 my $self = shift;
135              
136 17   66     41 $self->env->{'plack.request.merged'} ||= do {
137             Hash::MultiValue->new(
138 9         24 @{$self->_query_parameters},
139 9         16 @{$self->_body_parameters}
  9         404  
140             );
141             };
142             }
143              
144             sub uploads {
145 16     16 1 800 my $self = shift;
146              
147 16 100       40 if ($self->env->{'plack.request.upload'}) {
148 13         26 return $self->env->{'plack.request.upload'};
149             }
150              
151 3         28 $self->_parse_request_body;
152 3         9 return $self->env->{'plack.request.upload'};
153             }
154              
155             sub param {
156 8     8 1 3270 my $self = shift;
157              
158 8 100       25 return keys %{ $self->parameters } if @_ == 0;
  3         7  
159              
160 5         7 my $key = shift;
161 5 100       14 return $self->parameters->{$key} unless wantarray;
162 2         6 return $self->parameters->get_all($key);
163             }
164              
165             sub upload {
166 11     11 1 3873 my $self = shift;
167              
168 11 100       34 return keys %{ $self->uploads } if @_ == 0;
  1         3  
169              
170 10         20 my $key = shift;
171 10 100       28 return $self->uploads->{$key} unless wantarray;
172 6         17 return $self->uploads->get_all($key);
173             }
174              
175             sub uri {
176 21     21 1 141 my $self = shift;
177              
178 21         49 my $base = $self->_uri_base;
179              
180             # We have to escape back PATH_INFO in case they include stuff like
181             # ? or # so that the URI parser won't be tricked. However we should
182             # preserve '/' since encoding them into %2f doesn't make sense.
183             # This means when a request like /foo%2fbar comes in, we recognize
184             # it as /foo/bar which is not ideal, but that's how the PSGI PATH_INFO
185             # spec goes and we can't do anything about it. See PSGI::FAQ for details.
186              
187             # See RFC 3986 before modifying.
188 21         35 my $path_escape_class = q{^/;:@&=A-Za-z0-9\$_.+!*'(),-};
189              
190 21   100     43 my $path = URI::Escape::uri_escape($self->env->{PATH_INFO} || '', $path_escape_class);
191             $path .= '?' . $self->env->{QUERY_STRING}
192 21 100 100     1646 if defined $self->env->{QUERY_STRING} && $self->env->{QUERY_STRING} ne '';
193              
194 21 100       80 $base =~ s!/$!! if $path =~ m!^/!;
195              
196 21         91 return URI->new($base . $path)->canonical;
197             }
198              
199             sub base {
200 9     9 1 36 my $self = shift;
201 9         21 URI->new($self->_uri_base)->canonical;
202             }
203              
204             sub _uri_base {
205 30     30   97 my $self = shift;
206              
207 30         67 my $env = $self->env;
208              
209             my $uri = ($env->{'psgi.url_scheme'} || "http") .
210             "://" .
211             ($env->{HTTP_HOST} || (($env->{SERVER_NAME} || "") . ":" . ($env->{SERVER_PORT} || 80))) .
212 30   100     224 ($env->{SCRIPT_NAME} || '/');
      66        
      100        
213              
214 30         85 return $uri;
215             }
216              
217             sub new_response {
218 17     17 1 1528 my $self = shift;
219 17         5334 require Plack::Response;
220 17         129 Plack::Response->new(@_);
221             }
222              
223             sub request_body_parser {
224 20     20 0 38 my $self = shift;
225 20   33     128 $self->{request_body_parser} ||= $self->_build_body_parser;
226             }
227              
228             sub _build_body_parser {
229 20     20   38 my $self = shift;
230              
231 20         77 my $len = $self->_buffer_length_for($self->env);
232              
233 20         180 my $parser = HTTP::Entity::Parser->new(buffer_length => $len);
234 20         312 $parser->register('application/x-www-form-urlencoded', 'HTTP::Entity::Parser::UrlEncoded');
235 20         336 $parser->register('multipart/form-data', 'HTTP::Entity::Parser::MultiPart');
236              
237 20         293 $parser;
238             }
239              
240             sub _buffer_length_for {
241 20     20   65 my($self, $env) = @_;
242              
243 20 50       105 return $ENV{PLACK_BUFFER_LENGTH} if defined $ENV{PLACK_BUFFER_LENGTH};
244              
245 20 50       62 if ($env->{'psgix.input.buffered'}) {
246 0         0 return 1024 * 1024; # 1MB for buffered
247             } else {
248 20         65 return 1024 * 64; # 64K for unbuffered
249             }
250             }
251              
252             sub _parse_request_body {
253 20     20   41 my $self = shift;
254              
255 20         79 my ($params,$uploads) = $self->request_body_parser->parse($self->env);
256 19         12399 $self->env->{'plack.request.body_parameters'} = $params;
257              
258 19         148 my $upload_hash = Hash::MultiValue->new();
259 19         959 while ( my ($k,$v) = splice @$uploads, 0, 2 ) {
260 10         338 my %copy = %$v;
261 10         24 $copy{headers} = HTTP::Headers::Fast->new(@{$v->{headers}});
  10         55  
262 10         894 $upload_hash->add($k, Plack::Request::Upload->new(%copy));
263             }
264 19         167 $self->env->{'plack.request.upload'} = $upload_hash;
265 19         52 1;
266             }
267              
268             1;
269             __END__