File Coverage

blib/lib/Dancer2/Core/Request.pm
Criterion Covered Total %
statement 306 323 94.7
branch 109 130 83.8
condition 43 59 72.8
subroutine 81 87 93.1
pod 46 53 86.7
total 585 652 89.7


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