File Coverage

blib/lib/Dancer2/Core/Request.pm
Criterion Covered Total %
statement 304 322 94.4
branch 107 128 83.5
condition 40 56 71.4
subroutine 81 87 93.1
pod 46 53 86.7
total 578 646 89.4


line stmt bran cond sub pod time code
1             package Dancer2::Core::Request;
2             # ABSTRACT: Interface for accessing incoming requests
3             $Dancer2::Core::Request::VERSION = '0.400001';
4 147     147   252041 use strict;
  147         376  
  147         4435  
5 147     147   788 use warnings;
  147         384  
  147         4133  
6 147     147   3291 use parent 'Plack::Request';
  147         2183  
  147         1219  
7              
8 147     147   9306874 use Carp;
  147         466  
  147         8581  
9 147     147   1025 use Encode;
  147         418  
  147         9426  
10 147     147   979 use URI;
  147         373  
  147         3076  
11 147     147   811 use URI::Escape;
  147         382  
  147         7025  
12 147     147   4454 use Safe::Isa;
  147         4098  
  147         17314  
13 147     147   1122 use Hash::MultiValue;
  147         364  
  147         5198  
14 147     147   4274 use Ref::Util qw< is_ref is_arrayref is_hashref >;
  147         7396  
  147         8720  
15              
16 147     147   2429 use Dancer2::Core::Types;
  147         430  
  147         2644  
17 147     147   1996570 use Dancer2::Core::Request::Upload;
  147         492  
  147         4991  
18 147     147   4389 use Dancer2::Core::Cookie;
  147         483  
  147         20732  
19              
20             # add an attribute for each HTTP_* variables
21             # (HOST is managed manually)
22             my @http_env_keys = (qw/
23             accept_charset
24             accept_encoding
25             accept_language
26             connection
27             keep_alive
28             x_requested_with
29             /);
30              
31             # apparently you can't eval core functions
32 1     1 1 2539 sub accept { $_[0]->env->{'HTTP_ACCEPT'} }
33              
34 1     1 1 595 eval << "_EVAL" or die $@ for @http_env_keys; ## no critic
  1     1 1 555  
  1     1 1 616  
  1     1 1 546  
  1     1 1 548  
  1     1 1 1943  
35             sub $_ { \$_[0]->env->{ 'HTTP_' . ( uc "$_" ) } }
36             1;
37             _EVAL
38              
39             eval {
40             require Unicode::UTF8;
41 147     147   1167 no warnings qw<redefine once>;
  147         366  
  147         13089  
42 21551     21551   50097 *__decode = sub { Unicode::UTF8::decode_utf8($_[0]) };
43             1;
44             } or do {
45 147     147   1187 no warnings qw<redefine once>;
  147         474  
  147         599192  
46             *__decode = sub { decode( 'UTF-8', $_[0] ) };
47             };
48              
49             # check presence of XS module to speedup request
50             our $XS_URL_DECODE = eval { require URL::Encode::XS; 1; };
51             our $XS_PARSE_QUERY_STRING = eval { require CGI::Deurl::XS; 1; };
52             our $XS_HTTP_COOKIES = eval { require HTTP::XSCookies; 1; };
53              
54             our $_id = 0;
55              
56             # self->new( env => {}, serializer => $s, is_behind_proxy => 0|1 )
57             sub new {
58 738     738 1 227348 my ( $class, @args ) = @_;
59              
60             # even sized list
61 738 50       3166 @args % 2 == 0
62             or croak 'Must provide even sized list';
63              
64 738         2653 my %opts = @args;
65 738         1675 my $env = $opts{'env'};
66              
67 738         4108 my $self = $class->SUPER::new($env);
68              
69 738 100       8898 if ( my $s = $opts{'serializer'} ) {
70 84 100       327 $s->$_does('Dancer2::Core::Role::Serializer')
71             or croak 'Serializer provided not a Serializer object';
72              
73 83         5135 $self->{'serializer'} = $s;
74             }
75              
76             # additionally supported attributes
77 737         2216 $self->{'id'} = ++$_id;
78 737         1797 $self->{'vars'} = {};
79 737         1984 $self->{'is_behind_proxy'} = !!$opts{'is_behind_proxy'};
80              
81             $opts{'body_params'}
82 737 100       2089 and $self->{'_body_params'} = $opts{'body_params'};
83              
84             # Deserialize/parse body for HMV
85 737         2588 $self->data;
86 734         2986 $self->_build_uploads();
87              
88 733         2817 return $self;
89             }
90              
91             # a buffer for per-request variables
92 91     91 1 282 sub vars { $_[0]->{'vars'} }
93              
94             sub var {
95 12     12 1 803 my $self = shift;
96             @_ == 2
97             ? $self->vars->{ $_[0] } = $_[1]
98 12 100       65 : $self->vars->{ $_[0] };
99             }
100              
101             # I don't like this. I know send_file uses this and I wonder
102             # if we can remove it.
103             # -- Sawyer
104 0     0 0 0 sub set_path_info { $_[0]->env->{'PATH_INFO'} = $_[1] }
105              
106             # XXX: incompatible with Plack::Request
107 32     32 1 154 sub body { $_[0]->raw_body }
108              
109 16     16 1 3366 sub id { $_id }
110              
111             # Private 'read-only' attributes for request params. See the params()
112             # method for the public interface.
113             #
114             # _body_params, _query_params and _route_params have setter methods that
115             # decode byte string to characters before setting; If you know you have
116             # decoded (character) params, such as output from a deserializer, you can
117             # set these directly in the request object hash to avoid the decode op.
118 288   66 288   1531 sub _params { $_[0]->{'_params'} ||= $_[0]->_build_params }
119              
120 577     577   2164 sub _has_params { defined $_[0]->{'_params'} }
121              
122 1322   66 1322   5771 sub _body_params { $_[0]->{'_body_params'} ||= $_[0]->body_parameters->as_hashref_mixed }
123              
124 79     79   219 sub _query_params { $_[0]->{'_query_params'} }
125              
126             sub _set_query_params {
127 31     31   82 my ( $self, $params ) = @_;
128 31         71 $self->{_query_params} = _decode( $params );
129             }
130              
131 578   100 578   2585 sub _route_params { $_[0]->{'_route_params'} ||= {} }
132              
133             sub _set_route_params {
134 550     550   1475 my ( $self, $params ) = @_;
135 550         1451 $self->{_route_params} = _decode( $params );
136 550         1900 $self->_build_params();
137             }
138              
139             # XXX: incompatible with Plack::Request
140 5     5 1 24 sub uploads { $_[0]->{'uploads'} }
141              
142 295 100   295 0 1473 sub is_behind_proxy { $_[0]->{'is_behind_proxy'} || 0 }
143              
144             sub host {
145 141     141 1 2226 my ($self) = @_;
146              
147 141 100 100     358 if ( $self->is_behind_proxy and exists $self->env->{'HTTP_X_FORWARDED_HOST'} ) {
148 3         25 my @hosts = split /\s*,\s*/, $self->env->{'HTTP_X_FORWARDED_HOST'}, 2;
149 3         31 return $hosts[0];
150             } else {
151 138         365 return $self->env->{'HTTP_HOST'};
152             }
153             }
154              
155             # aliases, kept for backward compat
156 12     12 1 2144 sub agent { shift->user_agent }
157 4     4 1 6404 sub remote_address { shift->address }
158 3     3 1 3840 sub forwarded_for_address { shift->env->{'HTTP_X_FORWARDED_FOR'} }
159 0     0 1 0 sub forwarded_host { shift->env->{'HTTP_X_FORWARDED_HOST'} }
160              
161             # there are two options
162             sub forwarded_protocol {
163             $_[0]->env->{'HTTP_X_FORWARDED_PROTO'} ||
164             $_[0]->env->{'HTTP_X_FORWARDED_PROTOCOL'} ||
165 14 100 100 14 1 46 $_[0]->env->{'HTTP_FORWARDED_PROTO'}
166             }
167              
168             sub scheme {
169 153     153 1 13381 my ($self) = @_;
170 153 100       326 my $scheme = $self->is_behind_proxy
171             ? $self->forwarded_protocol
172             : '';
173              
174 153   66     1015 return $scheme || $self->env->{'psgi.url_scheme'};
175             }
176              
177 801     801 1 5493 sub serializer { $_[0]->{'serializer'} }
178              
179 787   100 787 1 3997 sub data { $_[0]->{'data'} ||= $_[0]->deserialize() }
180              
181             sub deserialize {
182 737     737 0 1459 my $self = shift;
183              
184 737 100       2265 my $serializer = $self->serializer
185             or return;
186              
187             # The latest draft of the RFC does not forbid DELETE to have content,
188             # rather the behaviour is undefined. Take the most lenient route and
189             # deserialize any content on delete as well.
190             return
191 83 100       210 unless grep { $self->method eq $_ } qw/ PUT POST PATCH DELETE /;
  332         2133  
192              
193             # try to deserialize
194 31         288 my $body = $self->body;
195              
196 31 100 66     10114 $body && length $body > 0
197             or return;
198              
199             # Catch serializer fails - which is tricky as Role::Serializer
200             # wraps the deserializaion in an eval and returns undef.
201             # We want to generate a 500 error on serialization fail (Ref #794)
202             # to achieve that, override the log callback so we can catch a signal
203             # that it failed. This is messy (messes with serializer internals), but
204             # "works".
205 30         65 my $serializer_fail;
206 30         132 my $serializer_log_cb = $serializer->log_cb;
207             local $serializer->{log_cb} = sub {
208 3     3   9 $serializer_fail = $_[1];
209 3         13 $serializer_log_cb->(@_);
210 30         217 };
211             # work-around to resolve a chicken-and-egg issue when instantiating a
212             # request object; the serializer needs that request object to deserialize
213             # the body params.
214 30         145 Scalar::Util::weaken( my $request = $self );
215 30 100       85 $self->serializer->has_request || $self->serializer->set_request($request);
216 30         1530 my $data = $serializer->deserialize($body);
217 30 100       128 die $serializer_fail if $serializer_fail;
218              
219             # Set _body_params directly rather than using the setter. Deserializiation
220             # returns characters and skipping the decode op in the setter ensures
221             # that numerical data "stays" numerical; decoding an SV that is an IV
222             # converts that to a PVIV. Some serializers are picky (JSON)..
223 27         109 $self->{_body_params} = $data;
224              
225             # Set body parameters (decoded HMV)
226 27 100       206 $self->{'body_parameters'} =
227             Hash::MultiValue->from_mixed( is_hashref($data) ? %$data : () );
228              
229 27         1557 return $data;
230             }
231              
232 3     3 1 9674 sub uri { $_[0]->request_uri }
233              
234 4     4 1 1183 sub is_head { $_[0]->method eq 'HEAD' }
235 7     7 1 5891 sub is_post { $_[0]->method eq 'POST' }
236 7     7 1 6775 sub is_get { $_[0]->method eq 'GET' }
237 4     4 1 1233 sub is_put { $_[0]->method eq 'PUT' }
238 4     4 1 1209 sub is_delete { $_[0]->method eq 'DELETE' }
239 4     4 0 1186 sub is_patch { $_[0]->method eq 'PATCH' }
240 0     0 1 0 sub is_options { $_[0]->method eq 'OPTIONS' }
241              
242             # public interface compat with CGI.pm objects
243 3     3 1 3221 sub request_method { $_[0]->method }
244 0     0 1 0 sub input_handle { $_[0]->env->{'psgi.input'} }
245              
246             sub to_string {
247 7     7 1 6299 my ($self) = @_;
248 7         32 return "[#" . $self->id . "] " . $self->method . " " . $self->path;
249             }
250              
251             sub base {
252 24     24 1 11133 my $self = shift;
253 24         64 my $uri = $self->_common_uri;
254              
255 24         84 return $uri->canonical;
256             }
257              
258             sub _common_uri {
259 135     135   225 my $self = shift;
260              
261 135         2378 my $path = $self->env->{SCRIPT_NAME};
262 135         650 my $port = $self->env->{SERVER_PORT};
263 135         590 my $server = $self->env->{SERVER_NAME};
264 135         599 my $host = $self->host;
265 135         706 my $scheme = $self->scheme;
266              
267 135         1051 my $uri = URI->new;
268 135         18065 $uri->scheme($scheme);
269 135   66     19607 $uri->authority( $host || "$server:$port" );
270 135   100     4953 $uri->path( $path || '/' );
271              
272 135         4475 return $uri;
273             }
274              
275             sub uri_base {
276 111     111 1 8390 my $self = shift;
277 111         318 my $uri = $self->_common_uri;
278 111         389 my $canon = $uri->canonical;
279              
280 111 100       11144 if ( $uri->path eq '/' ) {
281 104         1309 $canon =~ s{/$}{};
282             }
283              
284 111         1698 return $canon;
285             }
286              
287             sub dispatch_path {
288 0     0 1 0 warn q{DEPRECATED: request->dispatch_path. Please use request->path instead};
289 0         0 return shift->path;
290             }
291              
292             sub uri_for {
293 15     15 1 13178 my ( $self, $part, $params, $dont_escape ) = @_;
294              
295 15   50     47 $part ||= '';
296 15         43 my $uri = $self->base;
297              
298             # Make sure there's exactly one slash between the base and the new part
299 15         1470 my $base = $uri->path;
300 15         173 $base =~ s|/$||;
301 15         40 $part =~ s|^/||;
302 15         60 $uri->path("$base/$part");
303              
304 15 100       419 $uri->query_form($params) if $params;
305              
306             return $dont_escape
307 3         16 ? uri_unescape( ${ $uri->canonical } )
308 15 100       338 : ${ $uri->canonical };
  12         28  
309             }
310              
311             sub params {
312 256     256 1 27102 my ( $self, $source ) = @_;
313              
314 256 100 66     894 return %{ $self->_params } if wantarray && @_ == 1;
  31         84  
315 225 100       961 return $self->_params if @_ == 1;
316              
317 16 100       73 if ( $source eq 'query' ) {
    100          
318 5 0       16 return %{ $self->_query_params || {} } if wantarray;
  0 50       0  
319 5         18 return $self->_query_params;
320             }
321             elsif ( $source eq 'body' ) {
322 10 0       31 return %{ $self->_body_params || {} } if wantarray;
  0 50       0  
323 10         29 return $self->_body_params;
324             }
325 1 50       6 if ( $source eq 'route' ) {
326 1 50       4 return %{ $self->_route_params } if wantarray;
  0         0  
327 1         6 return $self->_route_params;
328             }
329             else {
330 0         0 croak "Unknown source params \"$source\".";
331             }
332             }
333              
334             sub query_parameters {
335 59     59 1 128 my $self = shift;
336 59   66     275 $self->{'query_parameters'} ||= do {
337 47 100       145 if ($XS_PARSE_QUERY_STRING) {
338             my $query = _decode(CGI::Deurl::XS::parse_query_string(
339 43         159 $self->env->{'QUERY_STRING'}
340             ));
341              
342             Hash::MultiValue->new(
343             map {;
344 10         21 my $key = $_;
345             is_arrayref( $query->{$key} )
346 2         26 ? ( map +( $key => $_ ), @{ $query->{$key} } )
347 10 100       47 : ( $key => $query->{$key} )
348 43         100 } keys %{$query}
  43         184  
349             );
350             } else {
351             # defer to Plack::Request
352 4         26 _decode($self->SUPER::query_parameters);
353             }
354             };
355             }
356              
357             # this will be filled once the route is matched
358 17   33 17 0 75 sub route_parameters { $_[0]->{'route_parameters'} ||= Hash::MultiValue->new }
359              
360             sub _set_route_parameters {
361 550     550   1381 my ( $self, $params ) = @_;
362             # remove reserved splat parameter name
363             # you should access splat parameters using splat() keyword
364 550         1042 delete @{$params}{qw<splat captures>};
  550         1498  
365 550         1001 $self->{'route_parameters'} = Hash::MultiValue->from_mixed( %{_decode($params)} );
  550         1352  
366             }
367              
368             sub body_parameters {
369 715     715 1 1329 my $self = shift;
370             # defer to (the overridden) Plack::Request->body_parameters
371 715   66     4089 $self->{'body_parameters'} ||= _decode($self->SUPER::body_parameters());
372             }
373              
374             sub parameters {
375 3     3 1 7 my ( $self, $type ) = @_;
376              
377             # handle a specific case
378 3 50       22 if ($type) {
379 0         0 my $attr = "${type}_parameters";
380 0         0 return $self->$attr;
381             }
382              
383             # merge together the *decoded* parameters
384 3   33     41 $self->{'merged_parameters'} ||= do {
385 3         11 my $query = $self->query_parameters;
386 3         6 my $body = $self->body_parameters;
387 3         7 my $route = $self->route_parameters; # not in Plack::Request
388 3         11 Hash::MultiValue->new( map $_->flatten, $query, $body, $route );
389             };
390             }
391              
392 2 100   2 0 8 sub captures { shift->params->{captures} || {} }
393              
394 31 100   31 0 63 sub splat { @{ shift->params->{splat} || [] } }
  31         131  
395              
396             # XXX: incompatible with Plack::Request
397 10     10 1 2152 sub param { shift->params->{ $_[0] } }
398              
399             sub _decode {
400 24126     24126   231039 my ($h) = @_;
401 24126 100       41434 return if not defined $h;
402              
403 24083 100 66     69656 if ( !is_ref($h) && !utf8::is_utf8($h) ) {
    100          
    100          
    50          
404 21551         30346 return __decode($h);
405             }
406             elsif ( ref($h) eq 'Hash::MultiValue' ) {
407 657         2703 return Hash::MultiValue->from_mixed(_decode($h->as_hashref_mixed));
408             }
409             elsif ( is_hashref($h) ) {
410 1797         9739 return { map {my $t = _decode($_); $t} (%$h) };
  21490         30020  
  21490         46810  
411             }
412             elsif ( is_arrayref($h) ) {
413 78         288 return [ map _decode($_), @$h ];
414             }
415              
416 0         0 return $h;
417             }
418              
419             sub is_ajax {
420 0     0 1 0 my $self = shift;
421              
422 0 0       0 return 0 unless defined $self->headers;
423 0 0       0 return 0 unless defined $self->header('X-Requested-With');
424 0 0       0 return 0 if $self->header('X-Requested-With') ne 'XMLHttpRequest';
425 0         0 return 1;
426             }
427              
428             # XXX incompatible with Plack::Request
429             # context-aware accessor for uploads
430             sub upload {
431 21     21 1 3896 my ( $self, $name ) = @_;
432 21         51 my $res = $self->{uploads}{$name};
433              
434 21 100       68 return $res unless wantarray;
435 9 100       25 return () unless defined $res;
436 6 100       29 return ( is_arrayref($res) ) ? @$res : $res;
437             }
438              
439             sub _build_params {
440 577     577   1372 my ($self) = @_;
441              
442             # params may have been populated by before filters
443             # _before_ we get there, so we have to save it first
444 577 100       1725 my $previous = $self->_has_params ? $self->_params : {};
445              
446             # now parse environment params...
447 577         1905 my $get_params = $self->_parse_get_params();
448              
449             # and merge everything
450             $self->{_params} = {
451 577 100       1673 map +( is_hashref($_) ? %{$_} : () ),
  1803         5973  
452             $previous,
453             $get_params,
454             $self->_body_params,
455             $self->_route_params,
456             };
457              
458             }
459              
460             sub _url_decode {
461 64     64   102 my ( $self, $encoded ) = @_;
462 64 100       166 return URL::Encode::XS::url_decode($encoded) if $XS_URL_DECODE;
463 32         45 my $clean = $encoded;
464 32         53 $clean =~ tr/\+/ /;
465 32         71 $clean =~ s/%([a-fA-F0-9]{2})/pack "H2", $1/eg;
  7         38  
466 32         62 return $clean;
467             }
468              
469             sub _parse_get_params {
470 577     577   1248 my ($self) = @_;
471 577 100       3892 return $self->_query_params if defined $self->{_query_params};
472              
473 534         1069 my $query_params = {};
474              
475 534         1720 my $source = $self->env->{QUERY_STRING};
476 534 100 100     4357 return if !defined $source || $source eq '';
477              
478 31 100       139 if ($XS_PARSE_QUERY_STRING) {
479 21   50     261 $self->_set_query_params(
480             CGI::Deurl::XS::parse_query_string($source) || {}
481             );
482 21         95 return $self->_query_params;
483             }
484              
485 10         70 foreach my $token ( split /[&;]/, $source ) {
486 32         92 my ( $key, $val ) = split( /=/, $token );
487 32 50       83 next unless defined $key;
488 32 50       60 $val = ( defined $val ) ? $val : '';
489 32         124 $key = $self->_url_decode($key);
490 32         64 $val = $self->_url_decode($val);
491              
492             # looking for multi-value params
493 32 100       71 if ( exists $query_params->{$key} ) {
494 6         14 my $prev_val = $query_params->{$key};
495 6 100       18 if ( is_arrayref($prev_val) ) {
496 2         5 push @{ $query_params->{$key} }, $val;
  2         9  
497             }
498             else {
499 4         17 $query_params->{$key} = [ $prev_val, $val ];
500             }
501             }
502              
503             # simple value param (first time we see it)
504             else {
505 26         75 $query_params->{$key} = $val;
506             }
507             }
508 10         40 $self->_set_query_params( $query_params );
509 10         36 return $self->_query_params;
510             }
511              
512             sub _build_uploads {
513 734     734   1609 my ($self) = @_;
514              
515             # parse body and build body params
516 734         2074 my $body_params = $self->_body_params;
517              
518 733         33398 my $uploads = $self->SUPER::uploads;
519 733         7481 my %uploads;
520              
521 733         2104 for my $name ( keys %$uploads ) {
522             my @uploads = map Dancer2::Core::Request::Upload->new(
523             # For back-compatibility, we use a HashRef of headers
524 20         859 headers => {@{$_->{headers}->psgi_flatten_without_sort}},
525             tempname => $_->{tempname},
526             size => $_->{size},
527 14         46 filename => _decode( $_->{filename} ),
528             ), $uploads->get_all($name);
529              
530 14 100       7003 $uploads{$name} = @uploads > 1 ? \@uploads : $uploads[0];
531              
532             # support access to the filename as a normal param
533 14         50 my @filenames = map $_->{'filename'}, @uploads;
534 14 100       51 $self->{_body_params}{$name} =
535             @filenames > 1 ? \@filenames : $filenames[0];
536             }
537              
538 733         2085 $self->{uploads} = \%uploads;
539             }
540              
541             # XXX: incompatible with Plack::Request
542 571   66 571 1 3622 sub cookies { $_[0]->{'cookies'} ||= $_[0]->_build_cookies }
543              
544             sub _build_cookies {
545 482     482   2721 my $self = shift;
546 482         969 my $cookies = {};
547              
548 482         2415 my $http_cookie = $self->header('Cookie');
549 482 100       81211 return $cookies unless defined $http_cookie; # nothing to do
550              
551 64 100       208 if ( $XS_HTTP_COOKIES ) {
552 63         550 $cookies = HTTP::XSCookies::crush_cookie($http_cookie);
553             }
554             else {
555             # handle via Plack::Request
556 1         11 $cookies = $self->SUPER::cookies();
557             }
558              
559             # convert to objects
560 64         233 while (my ($name, $value) = each %{$cookies}) {
  131         2375  
561 67 100       1979 $cookies->{$name} = Dancer2::Core::Cookie->new(
562             name => $name,
563             # HTTP::XSCookies v0.17+ will do the split and return an arrayref
564             value => (is_arrayref($value) ? $value : [split(/[&;]/, $value)])
565             );
566             }
567 64         551 return $cookies;
568             }
569              
570             # poor man's clone
571             sub _shallow_clone {
572 53     53   137 my ($self, $params, $options) = @_;
573              
574             # shallow clone $env; we don't want to alter the existing one
575             # in $self, then merge any overridden values
576 53 50       91 my $env = { %{ $self->env }, %{ $options || {} } };
  53         186  
  53         1105  
577              
578 53         395 my $new_request = __PACKAGE__->new(
579             env => $env,
580             body_params => {},
581             );
582              
583             # Clone and merge query params
584 53         194 my $new_params = $self->params;
585 53 100       100 $new_request->{_query_params} = { %{ $self->{_query_params} || {} } };
  53         346  
586 53         200 $new_request->{query_parameters} = $self->query_parameters->clone;
587 53 100       4005 for my $key ( keys %{ $params || {} } ) {
  53         282  
588 9         19 my $value = $params->{$key};
589 9         20 $new_params->{$key} = $value;
590 9         19 $new_request->{_query_params}->{$key} = $value;
591 9         32 $new_request->{query_parameters}->add( $key => $value );
592             }
593              
594             # Copy params (these are already decoded)
595 53         375 $new_request->{_params} = $new_params;
596 53         117 $new_request->{_body_params} = $self->{_body_params};
597 53         117 $new_request->{_route_params} = $self->{_route_params};
598 53         202 $new_request->{headers} = $self->headers;
599              
600             # Copy remaining settings
601 53         5098 $new_request->{is_behind_proxy} = $self->{is_behind_proxy};
602 53         148 $new_request->{vars} = $self->{vars};
603              
604             # Clone any existing decoded & cached body params. (GH#1116 GH#1269)
605 53         151 $new_request->{'body_parameters'} = $self->body_parameters->clone;
606              
607             # Delete merged HMV parameters, allowing them to be reconstructed on first use.
608 53         2068 delete $new_request->{'merged_parameters'};
609              
610 53         161 return $new_request;
611             }
612              
613              
614             sub _set_route {
615 550     550   1407 my ( $self, $route ) = @_;
616 550         1425 $self->{'route'} = $route;
617             }
618              
619 6     6 1 35 sub route { $_[0]->{'route'} }
620              
621             sub body_data {
622 2     2 1 6 my $self = shift;
623 2 100       8 return $self->data if $self->serializer;
624 1         4 $self->_body_params;
625 1 50       2 return $self->{_body_params} if keys %{ $self->{_body_params} };
  1         5  
626 1         5 return $self->body;
627             }
628              
629             1;
630              
631             __END__
632              
633             =pod
634              
635             =encoding UTF-8
636              
637             =head1 NAME
638              
639             Dancer2::Core::Request - Interface for accessing incoming requests
640              
641             =head1 VERSION
642              
643             version 0.400001
644              
645             =head1 SYNOPSIS
646              
647             In a route handler, the current request object can be accessed by the
648             C<request> keyword:
649              
650             get '/foo' => sub {
651             request->params; # request, params parsed as a hash ref
652             request->body; # returns the request body, unparsed
653             request->path; # the path requested by the client
654             # ...
655             };
656              
657             =head1 DESCRIPTION
658              
659             An object representing a Dancer2 request. It aims to provide a proper
660             interface to anything you might need from a web request.
661              
662             =head1 METHODS
663              
664             =head2 address
665              
666             Return the IP address of the client.
667              
668             =head2 base
669              
670             Returns an absolute URI for the base of the application. Returns a L<URI>
671             object (which stringifies to the URL, as you'd expect).
672              
673             =head2 body_parameters
674              
675             Returns a L<Hash::MultiValue> object representing the POST parameters.
676              
677             =head2 body
678              
679             Return the raw body of the request, unparsed.
680              
681             If you need to access the body of the request, you have to use this accessor and
682             should not try to read C<psgi.input> by hand. C<Dancer2::Core::Request>
683             already did it for you and kept the raw body untouched in there.
684              
685             =head2 body_data
686              
687             Returns the body of the request in data form, making it possible to distinguish
688             between C<body_parameters>, a representation of the request parameters
689             (L<Hash::MultiValue>) and other forms of content.
690              
691             If a serializer is set, this is the deserialized request body. Otherwise this is
692             the decoded body parameters (if any), or the body content itself.
693              
694             =head2 content
695              
696             Returns the undecoded byte string POST body.
697              
698             =head2 cookies
699              
700             Returns a reference to a hash containing cookies, where the keys are the names of the
701             cookies and values are L<Dancer2::Core::Cookie> objects.
702              
703             =head2 data
704              
705             If the application has a serializer and if the request has serialized
706             content, returns the deserialized structure as a hashref.
707              
708             =head2 dispatch_path
709              
710             Alias for L<path>. Deprecated.
711              
712             =head2 env
713              
714             Return the current PSGI environment hash reference.
715              
716             =head2 header($name)
717              
718             Return the value of the given header, if present. If the header has multiple
719             values, returns an the list of values if called in list context, the first one
720             in scalar.
721              
722             =head2 headers
723              
724             Returns either an L<HTTP::Headers> or an L<HTTP::Headers::Fast> object
725             representing the headers.
726              
727             =head2 id
728              
729             The ID of the request. This allows you to trace a specific request in loggers,
730             per the string created using C<to_string>.
731              
732             The ID of the request is essentially the number of requests run in the current
733             class.
734              
735             =head2 input
736              
737             Alias to C<input_handle> method below.
738              
739             =head2 input_handle
740              
741             Alias to the PSGI input handle (C<< <request->env->{psgi.input}> >>)
742              
743             =head2 is_ajax
744              
745             Return true if the value of the header C<X-Requested-With> is
746             C<XMLHttpRequest>.
747              
748             =head2 is_delete
749              
750             Return true if the method requested by the client is 'DELETE'
751              
752             =head2 is_get
753              
754             Return true if the method requested by the client is 'GET'
755              
756             =head2 is_head
757              
758             Return true if the method requested by the client is 'HEAD'
759              
760             =head2 is_post
761              
762             Return true if the method requested by the client is 'POST'
763              
764             =head2 is_put
765              
766             Return true if the method requested by the client is 'PUT'
767              
768             =head2 is_options
769              
770             Return true if the method requested by the client is 'OPTIONS'
771              
772             =head2 logger
773              
774             Returns the C<psgix.logger> code reference, if exists.
775              
776             =head2 method
777              
778             Return the HTTP method used by the client to access the application.
779              
780             While this method returns the method string as provided by the environment, it's
781             better to use one of the following boolean accessors if you want to inspect the
782             requested method.
783              
784             =head2 new
785              
786             The constructor of the class, used internally by Dancer2's core to create request
787             objects.
788              
789             It uses the environment hash table given to build the request object:
790              
791             Dancer2::Core::Request->new( env => $env );
792              
793             There are two additional parameters for instantiation:
794              
795             =over 4
796              
797             =item * serializer
798              
799             A serializer object to work with when reading the request body.
800              
801             =item * body_params
802              
803             Provide body parameters.
804              
805             Used internally when we need to avoid parsing the body again.
806              
807             =back
808              
809             =head2 param($key)
810              
811             Calls the C<params> method below and fetches the key provided.
812              
813             =head2 params($source)
814              
815             Called in scalar context, returns a hashref of params, either from the specified
816             source (see below for more info on that) or merging all sources.
817              
818             So, you can use, for instance:
819              
820             my $foo = params->{foo}
821              
822             If called in list context, returns a list of key and value pairs, so you could use:
823              
824             my %allparams = params;
825              
826             Parameters are merged in the following order: query, body, route - i.e. route
827             parameters have the highest priority:
828              
829             POST /hello/Ruth?name=Quentin
830              
831             name=Bobbie
832              
833             post '/hello/:name' => sub {
834             return "Hello, " . route_parameters->get('name') . "!"; # returns Ruth
835             return "Hello, " . query_parameters->get('name') . "!"; # returns Quentin
836             return "Hello, " . body_parameters->get('name') . "!"; # returns Bobbie
837             return "Hello, " . param('name') . "!"; # returns Ruth
838             };
839              
840             The L</query_parameters>, L</route_parameters>, and L</body_parameters> keywords
841             provide a L<Hash::MultiValue> result from the three different parameters.
842             We recommend using these rather than C<params>, because of the potential for
843             unintentional behaviour - consider the following request and route handler:
844              
845             POST /artist/104/new-song
846              
847             name=Careless Dancing
848              
849             post '/artist/:id/new-song' => sub {
850             find_artist(param('id'))->create_song(params);
851             # oops! we just passed id into create_song,
852             # but we probably only intended to pass name
853             find_artist(param('id'))->create_song(body_parameters);
854             };
855              
856             POST /artist/104/join-band
857              
858             id=4
859             name=Dancing Misfits
860              
861             post '/artist/:id/new-song' => sub {
862             find_artist(param('id'))->join_band(params);
863             # oops! we just passed an id of 104 into join_band,
864             # but we probably should have passed an id of 4
865             };
866              
867             =head2 parameters
868              
869             Returns a L<Hash::MultiValue> object with merged GET and POST parameters.
870              
871             Parameters are merged in the following order: query, body, route - i.e. route
872             parameters have the highest priority - see L</params> for how this works, and
873             associated risks and alternatives.
874              
875             =head2 path
876              
877             The path requested by the client, normalized. This is effectively
878             C<path_info> or a single forward C</>.
879              
880             =head2 path_info
881              
882             The raw requested path. This could be empty. Use C<path> instead.
883              
884             =head2 port
885              
886             Return the port of the server.
887              
888             =head2 protocol
889              
890             Return the protocol (I<HTTP/1.0> or I<HTTP/1.1>) used for the request.
891              
892             =head2 query_parameters
893              
894             Returns a L<Hash::MultiValue> parameters object.
895              
896             =head2 query_string
897              
898             Returns the portion of the request defining the query itself - this is
899             what comes after the C<?> in a URI.
900              
901             =head2 raw_body
902              
903             Alias to C<content> method.
904              
905             =head2 remote_address
906              
907             Alias for C<address> method.
908              
909             =head2 remote_host
910              
911             Return the remote host of the client. This only works with web servers configured
912             to do a reverse DNS lookup on the client's IP address.
913              
914             =head2 request_method
915              
916             Alias to the C<method> accessor, for backward-compatibility with C<CGI> interface.
917              
918             =head2 request_uri
919              
920             Return the raw, undecoded request URI path.
921              
922             =head2 route
923              
924             Return the L<route|Dancer2::Core::Route> which this request matched.
925              
926             =head2 scheme
927              
928             Return the scheme of the request
929              
930             =head2 script_name
931              
932             Return script_name from the environment.
933              
934             =head2 secure
935              
936             Return true or false, indicating whether the connection is secure - this is
937             effectively checking if the scheme is I<HTTPS> or not.
938              
939             =head2 serializer
940              
941             Returns the optional serializer object used to deserialize request parameters.
942              
943             =head2 session
944              
945             Returns the C<psgix.session> hash, if exists.
946              
947             =head2 session_options
948              
949             Returns the C<psgix.session.options> hash, if exists.
950              
951             =head2 to_string
952              
953             Return a string representing the request object (e.g., C<GET /some/path>).
954              
955             =head2 upload($name)
956              
957             Context-aware accessor for uploads. It's a wrapper around an access to the hash
958             table provided by C<uploads()>. It looks at the calling context and returns a
959             corresponding value.
960              
961             If you have many file uploads under the same name, and call C<upload('name')> in
962             an array context, the accessor will unroll the ARRAY ref for you:
963              
964             my @uploads = request->upload('many_uploads'); # OK
965              
966             Whereas with a manual access to the hash table, you'll end up with one element
967             in C<@uploads>, being the arrayref:
968              
969             my @uploads = request->uploads->{'many_uploads'};
970             # $uploads[0]: ARRAY(0xXXXXX)
971              
972             That is why this accessor should be used instead of a manual access to
973             C<uploads>.
974              
975             =head2 uploads
976              
977             Returns a reference to a hash containing uploads. Values can be either a
978             L<Dancer2::Core::Request::Upload> object, or an arrayref of
979             L<Dancer2::Core::Request::Upload>
980             objects.
981              
982             You should probably use the C<upload($name)> accessor instead of manually accessing the
983             C<uploads> hash table.
984              
985             =head2 uri
986              
987             An alias to C<request_uri>.
988              
989             =head2 uri_base
990              
991             Same thing as C<base> above, except it removes the last trailing slash in the
992             path if it is the only path.
993              
994             This means that if your base is I<http://myserver/>, C<uri_base> will return
995             I<http://myserver> (notice no trailing slash). This is considered very useful
996             when using templates to do the following thing:
997              
998             <link rel="stylesheet" href="[% request.uri_base %]/css/style.css" />
999              
1000             =head2 uri_for(path, params)
1001              
1002             Constructs a URI from the base and the passed path. If params (hashref) is
1003             supplied, these are added to the query string of the URI.
1004              
1005             Thus, with the following base:
1006              
1007             http://localhost:5000/foo
1008              
1009             You get the following behavior:
1010              
1011             my $uri = request->uri_for('/bar', { baz => 'baz' });
1012             print $uri; # http://localhost:5000/foo/bar?baz=baz
1013              
1014             C<uri_for> returns a L<URI> object (which can stringify to the value).
1015              
1016             =head2 user
1017              
1018             Return remote user if defined.
1019              
1020             =head2 var
1021              
1022             By-name interface to variables stored in this request object.
1023              
1024             my $stored = $request->var('some_variable');
1025              
1026             returns the value of 'some_variable', while
1027              
1028             $request->var('some_variable' => 'value');
1029              
1030             will set it.
1031              
1032             =head2 vars
1033              
1034             Access to the internal hash of variables:
1035              
1036             my $value = $request->vars->{'my_key'};
1037              
1038             You want to use C<var> above.
1039              
1040             =head1 Common HTTP request headers
1041              
1042             Commonly used client-supplied HTTP request headers are available through
1043             specific accessors:
1044              
1045             =over 4
1046              
1047             =item C<accept>
1048              
1049             HTTP header: C<HTTP_ACCEPT>.
1050              
1051             =item C<accept_charset>
1052              
1053             HTTP header: C<HTTP_ACCEPT_CHARSET>.
1054              
1055             =item C<accept_encoding>
1056              
1057             HTTP header: C<HTTP_ACCEPT_ENCODING>.
1058              
1059             =item C<accept_language>
1060              
1061             HTTP header: C<HTTP_ACCEPT_LANGUAGE>.
1062              
1063             =item C<agent>
1064              
1065             Alias for C<user_agent>) below.
1066              
1067             =item C<connection>
1068              
1069             HTTP header: C<HTTP_CONNECTION>.
1070              
1071             =item C<content_encoding>
1072              
1073             HTTP header: C<HTTP_CONTENT_ENCODING>.
1074              
1075             =item C<content_length>
1076              
1077             HTTP header: C<HTTP_CONTENT_LENGTH>.
1078              
1079             =item C<content_type>
1080              
1081             HTTP header: C<HTTP_CONTENT_TYPE>.
1082              
1083             =item C<forwarded_for_address>
1084              
1085             HTTP header: C<HTTP_X_FORWARDED_FOR>.
1086              
1087             =item C<forwarded_host>
1088              
1089             HTTP header: C<HTTP_X_FORWARDED_HOST>.
1090              
1091             =item C<forwarded_protocol>
1092              
1093             One of either C<HTTP_X_FORWARDED_PROTOCOL>, C<HTTP_X_FORWARDED_PROTO>, or
1094             C<HTTP_FORWARDED_PROTO>.
1095              
1096             =item C<host>
1097              
1098             Checks whether we are behind a proxy using the C<behind_proxy>
1099             configuration option, and if so returns the first
1100             C<HTTP_X_FORWARDED_HOST>, since this is a comma separated list.
1101              
1102             If you have not configured that you are behind a proxy, it returns HTTP
1103             header C<HTTP_HOST>.
1104              
1105             =item C<keep_alive>
1106              
1107             HTTP header: C<HTTP_KEEP_ALIVE>.
1108              
1109             =item C<referer>
1110              
1111             HTTP header: C<HTTP_REFERER>.
1112              
1113             =item C<user_agent>
1114              
1115             HTTP header: C<HTTP_USER_AGENT>.
1116              
1117             =item C<x_requested_with>
1118              
1119             HTTP header: C<HTTP_X_REQUESTED_WITH>.
1120              
1121             =back
1122              
1123             =head1 Fetching only params from a given source
1124              
1125             If a required source isn't specified, a mixed hashref (or list of key value
1126             pairs, in list context) will be returned; this will contain params from all
1127             sources (route, query, body).
1128              
1129             In practical terms, this means that if the param C<foo> is passed both on the
1130             querystring and in a POST body, you can only access one of them.
1131              
1132             If you want to see only params from a given source, you can say so by passing
1133             the C<$source> param to C<params()>:
1134              
1135             my %querystring_params = params('query');
1136             my %route_params = params('route');
1137             my %post_params = params('body');
1138              
1139             If source equals C<route>, then only params parsed from the route pattern
1140             are returned.
1141              
1142             If source equals C<query>, then only params parsed from the query string are
1143             returned.
1144              
1145             If source equals C<body>, then only params sent in the request body will be
1146             returned.
1147              
1148             If another value is given for C<$source>, then an exception is triggered.
1149              
1150             =head1 EXTRA SPEED
1151              
1152             If L<Dancer2::Core::Request> detects the following modules as installed,
1153             it will use them to speed things up:
1154              
1155             =over 4
1156              
1157             =item * L<URL::Encode::XS>
1158              
1159             =item * L<CGI::Deurl::XS>
1160              
1161             =back
1162              
1163             =head1 AUTHOR
1164              
1165             Dancer Core Developers
1166              
1167             =head1 COPYRIGHT AND LICENSE
1168              
1169             This software is copyright (c) 2023 by Alexis Sukrieh.
1170              
1171             This is free software; you can redistribute it and/or modify it under
1172             the same terms as the Perl 5 programming language system itself.
1173              
1174             =cut