lib/Catalyst/Request.pm

   1 package Catalyst::Request;
   2
   3 use Socket qw( getaddrinfo getnameinfo AI_NUMERICHOST NI_NAMEREQD NIx_NOSERV );
   4 use Carp;
   5 use utf8;
   6 use URI::http;
   7 use URI::https;
   8 use URI::QueryParam;
   9 use HTTP::Headers;
  10 use Stream::Buffered;
  11 use Hash::MultiValue;
  12 use Scalar::Util;
  13 use HTTP::Body;
  14 use Catalyst::Exception;
  15 use Catalyst::Request::PartData;
  16 use Moose;
  17
  18 use namespace::clean -except => 'meta';
  19
  20 with 'MooseX::Emulate::Class::Accessor::Fast';
  21
  22 has env => (is => 'ro', writer => '_set_env', predicate => '_has_env');
  23 # XXX Deprecated crap here - warn?
  24 has action => (is => 'rw');
  25 # XXX: Deprecated in docs ages ago (2006), deprecated with warning in 5.8000 due
  26 # to confusion between Engines and Plugin::Authentication. Remove in 5.8100?
  27 has user => (is => 'rw');
  28 sub snippets        { shift->captures(@_) }
  29
  30 has _read_position => (
  31     # FIXME: work around Moose bug RT#75367
  32     # init_arg => undef,
  33     is => 'ro',
  34     writer => '_set_read_position',
  35     default => 0,
  36 );
  37 has _read_length => (
  38     # FIXME: work around Moose bug RT#75367
  39     # init_arg => undef,
  40     is => 'ro',
  41     default => sub {
  42         my $self = shift;
  43         $self->header('Content-Length') || 0;
  44     },
  45     lazy => 1,
  46 );
  47
  48 has address => (is => 'rw');
  49 has arguments => (is => 'rw', default => sub { [] });
  50 has cookies => (is => 'ro', builder => 'prepare_cookies', lazy => 1);
  51
  52 sub prepare_cookies {
  53     my ( $self ) = @_;
  54
  55     if ( my $header = $self->header('Cookie') ) {
  56         return { CGI::Simple::Cookie->parse($header) };
  57     }
  58     {};
  59 }
  60
  61 has query_keywords => (is => 'rw');
  62 has match => (is => 'rw');
  63 has method => (is => 'rw');
  64 has protocol => (is => 'rw');
  65 has query_parameters  => (is => 'rw', lazy=>1, default => sub { shift->_use_hash_multivalue ? Hash::MultiValue->new : +{} });
  66 has secure => (is => 'rw', default => 0);
  67 has captures => (is => 'rw', default => sub { [] });
  68 has uri => (is => 'rw', predicate => 'has_uri');
  69 has remote_user => (is => 'rw');
  70 has headers => (
  71   is      => 'rw',
  72   isa     => 'HTTP::Headers',
  73   handles => [qw(content_encoding content_length content_type header referer user_agent)],
  74   builder => 'prepare_headers',
  75   lazy => 1,
  76 );
  77
  78 sub prepare_headers {
  79     my ($self) = @_;
  80
  81     my $env = $self->env;
  82     my $headers = HTTP::Headers->new();
  83
  84     for my $header (keys %{ $env }) {
  85         next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
  86         (my $field = $header) =~ s/^HTTPS?_//;
  87         $field =~ tr/_/-/;
  88         $headers->header($field => $env->{$header});
  89     }
  90     return $headers;
  91 }
  92
  93 has _log => (
  94     is => 'ro',
  95     weak_ref => 1,
  96     required => 1,
  97 );
  98
  99 has io_fh => (
 100     is=>'ro',
 101     predicate=>'_has_io_fh',
 102     lazy=>1,
 103     builder=>'_build_io_fh');
 104
 105 sub _build_io_fh {
 106     my $self = shift;
 107     return $self->env->{'psgix.io'}
 108       || (
 109         $self->env->{'net.async.http.server.req'} &&
 110         $self->env->{'net.async.http.server.req'}->stream)   ## Until I can make ioasync cabal see the value of supportin psgix.io (jnap)
 111       || die "Your Server does not support psgix.io";
 112 };
 113
 114 has data_handlers => ( is=>'ro', isa=>'HashRef', default=>sub { +{} } );
 115
 116 has body_data => (
 117     is=>'ro',
 118     lazy=>1,
 119     builder=>'_build_body_data');
 120
 121 sub _build_body_data {
 122     my ($self) = @_;
 123
 124     # Not sure if these returns should not be exceptions...
 125     my $content_type = $self->content_type || return;
 126     return unless ($self->method eq 'POST' || $self->method eq 'PUT' || $self->method eq 'PATCH');
 127
 128     my ($match) = grep { $content_type =~/$_/i }
 129       keys(%{$self->data_handlers});
 130
 131     if($match) {
 132       my $fh = $self->body;
 133       local $_ = $fh;
 134       return $self->data_handlers->{$match}->($fh, $self);
 135     } else {
 136       Catalyst::Exception->throw(
 137         sprintf '%s does not have an available data handler. Valid data_handlers are %s.',
 138           $content_type, join ', ', sort keys %{$self->data_handlers}
 139       );
 140     }
 141 }
 142
 143 has _use_hash_multivalue => (
 144     is=>'ro',
 145     required=>1,
 146     default=> sub {0});
 147
 148 # Amount of data to read from input on each pass
 149 our $CHUNKSIZE = 64 * 1024;
 150
 151 sub read {
 152     my ($self, $maxlength) = @_;
 153     my $remaining = $self->_read_length - $self->_read_position;
 154     $maxlength ||= $CHUNKSIZE;
 155
 156     # Are we done reading?
 157     if ( $remaining <= 0 ) {
 158         return;
 159     }
 160
 161     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 162     my $rc = $self->read_chunk( my $buffer, $readlen );
 163     if ( defined $rc ) {
 164         if (0 == $rc) { # Nothing more to read even though Content-Length
 165                         # said there should be.
 166             return;
 167         }
 168         $self->_set_read_position( $self->_read_position + $rc );
 169         return $buffer;
 170     }
 171     else {
 172         Catalyst::Exception->throw(
 173             message => "Unknown error reading input: $!" );
 174     }
 175 }
 176
 177 sub read_chunk {
 178     my $self = shift;
 179     return $self->env->{'psgi.input'}->read(@_);
 180 }
 181
 182 has body_parameters => (
 183   is => 'rw',
 184   required => 1,
 185   lazy => 1,
 186   predicate => 'has_body_parameters',
 187   builder => 'prepare_body_parameters',
 188 );
 189
 190 has uploads => (
 191   is => 'rw',
 192   required => 1,
 193   default => sub { {} },
 194 );
 195
 196 has parameters => (
 197     is => 'rw',
 198     lazy => 1,
 199     builder => '_build_parameters',
 200     clearer => '_clear_parameters',
 201 );
 202
 203 # TODO:
 204 # - Can we lose the before modifiers which just call prepare_body ?
 205 #   they are wasteful, slow us down and feel cluttery.
 206
 207 #  Can we make _body an attribute, have the rest of
 208 #  these lazy build from there and kill all the direct hash access
 209 #  in Catalyst.pm and Engine.pm?
 210
 211 sub prepare_parameters {
 212     my ( $self ) = @_;
 213     $self->_clear_parameters;
 214     return $self->parameters;
 215 }
 216
 217 sub _build_parameters {
 218     my ( $self ) = @_;
 219     my $parameters = {};
 220     my $body_parameters = $self->body_parameters;
 221     my $query_parameters = $self->query_parameters;
 222
 223     if($self->_use_hash_multivalue) {
 224         return Hash::MultiValue->new($query_parameters->flatten, $body_parameters->flatten);
 225     }
 226
 227     # We copy, no references
 228     foreach my $name (keys %$query_parameters) {
 229         my $param = $query_parameters->{$name};
 230         $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
 231     }
 232
 233     # Merge query and body parameters
 234     foreach my $name (keys %$body_parameters) {
 235         my $param = $body_parameters->{$name};
 236         my @values = ref $param eq 'ARRAY' ? @$param : ($param);
 237         if ( my $existing = $parameters->{$name} ) {
 238           unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
 239         }
 240         $parameters->{$name} = @values > 1 ? \@values : $values[0];
 241     }
 242     $parameters;
 243 }
 244
 245 has _uploadtmp => (
 246     is => 'ro',
 247     predicate => '_has_uploadtmp',
 248 );
 249
 250 sub prepare_body {
 251     my ( $self ) = @_;
 252
 253     # If previously applied middleware created the HTTP::Body object, then we
 254     # just use that one.
 255
 256     if(my $plack_body = $self->_has_env ? $self->env->{'plack.request.http.body'} : undef) {
 257         $self->_body($plack_body);
 258         $self->_body->cleanup(1);
 259         return;
 260     }
 261
 262     # If there is nothing to read, set body to naught and return.  This
 263     # will cause all body code to be skipped
 264
 265     return $self->_body(0) unless my $length = $self->_read_length;
 266
 267     # Unless the body has already been set, create it.  Not sure about this
 268     # code, how else might it be set, but this was existing logic.
 269
 270     unless ($self->_body) {
 271         my $type = $self->header('Content-Type');
 272         $self->_body(HTTP::Body->new( $type, $length ));
 273         $self->_body->cleanup(1);
 274
 275         # JNAP: I'm not sure this is doing what we expect, but it also doesn't
 276         # seem to be hurting (seems ->_has_uploadtmp is true more than I would
 277         # expect.
 278
 279         $self->_body->tmpdir( $self->_uploadtmp )
 280           if $self->_has_uploadtmp;
 281     }
 282
 283     # Ok if we get this far, we have to read psgi.input into the new body
 284     # object.  Lets play nice with any plack app or other downstream, so
 285     # we create a buffer unless one exists.
 286
 287     my $stream_buffer;
 288     if ($self->env->{'psgix.input.buffered'}) {
 289         # Be paranoid about previous psgi middleware or apps that read the
 290         # input but didn't return the buffer to the start.
 291         $self->env->{'psgi.input'}->seek(0, 0);
 292     } else {
 293         $stream_buffer = Stream::Buffered->new($length);
 294     }
 295
 296     # Check for definedness as you could read '0'
 297     while ( defined ( my $chunk = $self->read() ) ) {
 298         $self->prepare_body_chunk($chunk);
 299         next unless $stream_buffer;
 300
 301         $stream_buffer->print($chunk)
 302             || die sprintf "Failed to write %d bytes to psgi.input file: $!", length( $chunk );
 303     }
 304
 305     # Ok, we read the body.  Lets play nice for any PSGI app down the pipe
 306
 307     if ($stream_buffer) {
 308         $self->env->{'psgix.input.buffered'} = 1;
 309         $self->env->{'psgi.input'} = $stream_buffer->rewind;
 310     } else {
 311         $self->env->{'psgi.input'}->seek(0, 0); # Reset the buffer for downstream middleware or apps
 312     }
 313
 314     # paranoia against wrong Content-Length header
 315     my $remaining = $length - $self->_read_position;
 316     if ( $remaining > 0 ) {
 317         Catalyst::Exception->throw("Wrong Content-Length value: $length" );
 318     }
 319 }
 320
 321 sub prepare_body_chunk {
 322     my ( $self, $chunk ) = @_;
 323
 324     $self->_body->add($chunk);
 325 }
 326
 327 sub prepare_body_parameters {
 328     my ( $self, $c ) = @_;
 329     return $self->body_parameters if $self->has_body_parameters;
 330     $self->prepare_body if ! $self->_has_body;
 331
 332     unless($self->_body) {
 333       my $return = $self->_use_hash_multivalue ? Hash::MultiValue->new : {};
 334       $self->body_parameters($return);
 335       return $return;
 336     }
 337
 338     my $params;
 339     my %part_data = %{$self->_body->part_data};
 340     if(scalar %part_data && !$c->config->{skip_complex_post_part_handling}) {
 341       foreach my $key (keys %part_data) {
 342         my $proto_value = $part_data{$key};
 343         my ($val, @extra) = (ref($proto_value)||'') eq 'ARRAY' ? @$proto_value : ($proto_value);
 344
 345         $key = $c->_handle_param_unicode_decoding($key)
 346           if ($c and $c->encoding and !$c->config->{skip_body_param_unicode_decoding});
 347
 348         if(@extra) {
 349           $params->{$key} = [map { Catalyst::Request::PartData->build_from_part_data($c, $_) } ($val,@extra)];
 350         } else {
 351           $params->{$key} = Catalyst::Request::PartData->build_from_part_data($c, $val);
 352         }
 353       }
 354     } else {
 355       $params = $self->_body->param;
 356
 357       # If we have an encoding configured (like UTF-8) in general we expect a client
 358       # to POST with the encoding we fufilled the request in. Otherwise don't do any
 359       # encoding (good change wide chars could be in HTML entity style llike the old
 360       # days -JNAP
 361
 362       # so, now that HTTP::Body prepared the body params, we gotta 'walk' the structure
 363       # and do any needed decoding.
 364
 365       # This only does something if the encoding is set via the encoding param.  Remember
 366       # this is assuming the client is not bad and responds with what you provided.  In
 367       # general you can just use utf8 and get away with it.
 368       #
 369       # I need to see if $c is here since this also doubles as a builder for the object :(
 370
 371       if($c and $c->encoding and !$c->config->{skip_body_param_unicode_decoding}) {
 372         $params = $c->_handle_unicode_decoding($params);
 373       }
 374     }
 375
 376     my $return = $self->_use_hash_multivalue ?
 377         Hash::MultiValue->from_mixed($params) :
 378         $params;
 379
 380     $self->body_parameters($return) unless $self->has_body_parameters;
 381     return $return;
 382 }
 383
 384 sub prepare_connection {
 385     my ($self) = @_;
 386
 387     my $env = $self->env;
 388
 389     $self->address( $env->{REMOTE_ADDR} );
 390     $self->hostname( $env->{REMOTE_HOST} )
 391         if exists $env->{REMOTE_HOST};
 392     $self->protocol( $env->{SERVER_PROTOCOL} );
 393     $self->remote_user( $env->{REMOTE_USER} );
 394     $self->method( $env->{REQUEST_METHOD} );
 395     $self->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
 396 }
 397
 398 # XXX - FIXME - method is here now, move this crap...
 399 around parameters => sub {
 400     my ($orig, $self, $params) = @_;
 401     if ($params) {
 402         if ( !ref $params ) {
 403             $self->_log->warn(
 404                 "Attempt to retrieve '$params' with req->params(), " .
 405                 "you probably meant to call req->param('$params')"
 406             );
 407             $params = undef;
 408         }
 409         return $self->$orig($params);
 410     }
 411     $self->$orig();
 412 };
 413
 414 has base => (
 415   is => 'rw',
 416   required => 1,
 417   lazy => 1,
 418   default => sub {
 419     my $self = shift;
 420     return $self->path if $self->has_uri;
 421   },
 422 );
 423
 424 has _body => (
 425   is => 'rw', clearer => '_clear_body', predicate => '_has_body',
 426 );
 427 # Eugh, ugly. Should just be able to rename accessor methods to 'body'
 428 #             and provide a custom reader..
 429 sub body {
 430   my $self = shift;
 431   $self->prepare_body unless $self->_has_body;
 432   croak 'body is a reader' if scalar @_;
 433   return blessed $self->_body ? $self->_body->body : $self->_body;
 434 }
 435
 436 has hostname => (
 437   is        => 'rw',
 438   required  => 1,
 439   lazy      => 1,
 440   default   => sub {
 441     my ($self) = @_;
 442     my ( $err, $sockaddr ) = getaddrinfo(
 443         $self->address,
 444         # no service
 445         '',
 446         { flags => AI_NUMERICHOST }
 447     );
 448     if ( $err ) {
 449         $self->_log->warn("resolve of hostname failed: $err");
 450         return $self->address;
 451     }
 452     ( $err, my $hostname ) = getnameinfo(
 453         $sockaddr->{addr},
 454         NI_NAMEREQD,
 455         # we are only interested in the hostname, not the servicename
 456         NIx_NOSERV
 457     );
 458     if ( $err ) {
 459         $self->_log->warn("resolve of hostname failed: $err");
 460         return $self->address;
 461     }
 462     return $hostname;
 463   },
 464 );
 465
 466 has _path => ( is => 'rw', predicate => '_has_path', clearer => '_clear_path' );
 467
 468 sub args            { shift->arguments(@_) }
 469 sub body_params     { shift->body_parameters(@_) }
 470 sub input           { shift->body(@_) }
 471 sub params          { shift->parameters(@_) }
 472 sub query_params    { shift->query_parameters(@_) }
 473 sub path_info       { shift->path(@_) }
 474
 475 =for stopwords param params
 476
 477 =head1 NAME
 478
 479 Catalyst::Request - provides information about the current client request
 480
 481 =head1 SYNOPSIS
 482
 483     $req = $c->request;
 484     $req->address eq "127.0.0.1";
 485     $req->arguments;
 486     $req->args;
 487     $req->base;
 488     $req->body;
 489     $req->body_data;
 490     $req->body_parameters;
 491     $req->content_encoding;
 492     $req->content_length;
 493     $req->content_type;
 494     $req->cookie;
 495     $req->cookies;
 496     $req->header;
 497     $req->headers;
 498     $req->hostname;
 499     $req->input;
 500     $req->query_keywords;
 501     $req->match;
 502     $req->method;
 503     $req->param;
 504     $req->parameters;
 505     $req->params;
 506     $req->path;
 507     $req->protocol;
 508     $req->query_parameters;
 509     $req->read;
 510     $req->referer;
 511     $req->secure;
 512     $req->captures;
 513     $req->upload;
 514     $req->uploads;
 515     $req->uri;
 516     $req->user;
 517     $req->user_agent;
 518     $req->env;
 519
 520 See also L<Catalyst>, L<Catalyst::Request::Upload>.
 521
 522 =head1 DESCRIPTION
 523
 524 This is the Catalyst Request class, which provides an interface to data for the
 525 current client request. The request object is prepared by L<Catalyst::Engine>,
 526 thus hiding the details of the particular engine implementation.
 527
 528 =head1 METHODS
 529
 530 =head2 $req->address
 531
 532 Returns the IP address of the client.
 533
 534 =head2 $req->arguments
 535
 536 Returns a reference to an array containing the arguments.
 537
 538     print $c->request->arguments->[0];
 539
 540 For example, if your action was
 541
 542     package MyApp::Controller::Foo;
 543
 544     sub moose : Local {
 545         ...
 546     }
 547
 548 and the URI for the request was C<http://.../foo/moose/bah>, the string C<bah>
 549 would be the first and only argument.
 550
 551 Arguments get automatically URI-unescaped for you.
 552
 553 =head2 $req->args
 554
 555 Shortcut for L</arguments>.
 556
 557 =head2 $req->base
 558
 559 Contains the URI base. This will always have a trailing slash. Note that the
 560 URI scheme (e.g., http vs. https) must be determined through heuristics;
 561 depending on your server configuration, it may be incorrect. See $req->secure
 562 for more info.
 563
 564 If your application was queried with the URI
 565 C<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>.
 566
 567 =head2 $req->body
 568
 569 Returns the message body of the request, as returned by L<HTTP::Body>: a string,
 570 unless Content-Type is C<application/x-www-form-urlencoded>, C<text/xml>, or
 571 C<multipart/form-data>, in which case a L<File::Temp> object is returned.
 572
 573 =head2 $req->body_data
 574
 575 Returns a Perl representation of POST/PUT body data that is not classic HTML
 576 form data, such as JSON, XML, etc.  By default, Catalyst will parse incoming
 577 data of the type 'application/json' and return access to that data via this
 578 method.  You may define addition data_handlers via a global configuration
 579 setting.  See L<Catalyst\DATA HANDLERS> for more information.
 580
 581 If the POST is malformed in some way (such as undefined or not content that
 582 matches the content-type) we raise a L<Catalyst::Exception> with the error
 583 text as the message.
 584
 585 If the POSTed content type does not match an available data handler, this
 586 will also raise an exception.
 587
 588 =head2 $req->body_parameters
 589
 590 Returns a reference to a hash containing body (POST) parameters. Values can
 591 be either a scalar or an arrayref containing scalars.
 592
 593     print $c->request->body_parameters->{field};
 594     print $c->request->body_parameters->{field}->[0];
 595
 596 These are the parameters from the POST part of the request, if any.
 597
 598 B<NOTE> If your POST is multipart, but contains non file upload parts (such
 599 as an line part with an alternative encoding or content type) we do our best to
 600 try and figure out how the value should be presented.  If there's a specified character
 601 set we will use that to decode rather than the default encoding set by the application.
 602 However if there are complex headers and we cannot determine
 603 the correct way to extra a meaningful value from the upload, in this case any
 604 part like this will be represented as an instance of L<Catalyst::Request::PartData>.
 605
 606 Patches and review of this part of the code welcomed.
 607
 608 =head2 $req->body_params
 609
 610 Shortcut for body_parameters.
 611
 612 =head2 $req->content_encoding
 613
 614 Shortcut for $req->headers->content_encoding.
 615
 616 =head2 $req->content_length
 617
 618 Shortcut for $req->headers->content_length.
 619
 620 =head2 $req->content_type
 621
 622 Shortcut for $req->headers->content_type.
 623
 624 =head2 $req->cookie
 625
 626 A convenient method to access $req->cookies.
 627
 628     $cookie  = $c->request->cookie('name');
 629     @cookies = $c->request->cookie;
 630
 631 =cut
 632
 633 sub cookie {
 634     my $self = shift;
 635
 636     if ( @_ == 0 ) {
 637         return keys %{ $self->cookies };
 638     }
 639
 640     if ( @_ == 1 ) {
 641
 642         my $name = shift;
 643
 644         unless ( exists $self->cookies->{$name} ) {
 645             return undef;
 646         }
 647
 648         return $self->cookies->{$name};
 649     }
 650 }
 651
 652 =head2 $req->cookies
 653
 654 Returns a reference to a hash containing the cookies.
 655
 656     print $c->request->cookies->{mycookie}->value;
 657
 658 The cookies in the hash are indexed by name, and the values are L<CGI::Simple::Cookie>
 659 objects.
 660
 661 =head2 $req->header
 662
 663 Shortcut for $req->headers->header.
 664
 665 =head2 $req->headers
 666
 667 Returns an L<HTTP::Headers> object containing the headers for the current request.
 668
 669     print $c->request->headers->header('X-Catalyst');
 670
 671 =head2 $req->hostname
 672
 673 Returns the hostname of the client. Use C<< $req->uri->host >> to get the hostname of the server.
 674
 675 =head2 $req->input
 676
 677 Alias for $req->body.
 678
 679 =head2 $req->query_keywords
 680
 681 Contains the keywords portion of a query string, when no '=' signs are
 682 present.
 683
 684     http://localhost/path?some+keywords
 685
 686     $c->request->query_keywords will contain 'some keywords'
 687
 688 =head2 $req->match
 689
 690 This contains the matching part of a Regex action. Otherwise
 691 it returns the same as 'action', except for default actions,
 692 which return an empty string.
 693
 694 =head2 $req->method
 695
 696 Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
 697
 698 =head2 $req->param
 699
 700 Returns GET and POST parameters with a CGI.pm-compatible param method. This
 701 is an alternative method for accessing parameters in $c->req->parameters.
 702
 703     $value  = $c->request->param( 'foo' );
 704     @values = $c->request->param( 'foo' );
 705     @params = $c->request->param;
 706
 707 Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
 708 arguments to this method, like this:
 709
 710     $c->request->param( 'foo', 'bar', 'gorch', 'quxx' );
 711
 712 will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
 713 C<quxx>. Previously this would have added C<bar> as another value to C<foo>
 714 (creating it if it didn't exist before), and C<quxx> as another value for
 715 C<gorch>.
 716
 717 B<NOTE> this is considered a legacy interface and care should be taken when
 718 using it. C<< scalar $c->req->param( 'foo' ) >> will return only the first
 719 C<foo> param even if multiple are present; C<< $c->req->param( 'foo' ) >> will
 720 return a list of as many are present, which can have unexpected consequences
 721 when writing code of the form:
 722
 723     $foo->bar(
 724         a => 'b',
 725         baz => $c->req->param( 'baz' ),
 726     );
 727
 728 If multiple C<baz> parameters are provided this code might corrupt data or
 729 cause a hash initialization error. For a more straightforward interface see
 730 C<< $c->req->parameters >>.
 731
 732 B<NOTE> Interfaces like this, which are based on L<CGI> and the C<param> method
 733 are known to cause demonstrated exploits. It is highly recommended that you
 734 avoid using this method, and migrate existing code away from it.  Here's a
 735 whitepaper of the exploit:
 736
 737 L<http://blog.gerv.net/2014/10/new-class-of-vulnerability-in-perl-web-applications/>
 738
 739 B<NOTE> Further discussion on IRC indicate that the L<Catalyst> core team from 'back then'
 740 were well aware of this hack and this is the main reason we added the new approach to
 741 getting parameters in the first place.
 742
 743 Basically this is an exploit that takes advantage of how L<\param> will do one thing
 744 in scalar context and another thing in list context.  This is combined with how Perl
 745 chooses to deal with duplicate keys in a hash definition by overwriting the value of
 746 existing keys with a new value if the same key shows up again.  Generally you will be
 747 vulnerable to this exploit if you are using this method in a direct assignment in a
 748 hash, such as with a L<DBIx::Class> create statement.  For example, if you have
 749 parameters like:
 750
 751     user?user=123&foo=a&foo=user&foo=456
 752
 753 You could end up with extra parameters injected into your method calls:
 754
 755     $c->model('User')->create({
 756       user => $c->req->param('user'),
 757       foo => $c->req->param('foo'),
 758     });
 759
 760 Which would look like:
 761
 762     $c->model('User')->create({
 763       user => 123,
 764       foo => qw(a user 456),
 765     });
 766
 767 (or to be absolutely clear if you are not seeing it):
 768
 769     $c->model('User')->create({
 770       user => 456,
 771       foo => 'a',
 772     });
 773
 774 Possible remediations include scrubbing your parameters with a form validator like
 775 L<HTML::FormHandler> or being careful to force scalar context using the scalar
 776 keyword:
 777
 778     $c->model('User')->create({
 779       user => scalar($c->req->param('user')),
 780       foo => scalar($c->req->param('foo')),
 781     });
 782
 783 Upcoming versions of L<Catalyst> will disable this interface by default and require
 784 you to positively enable it should you require it for backwards compatibility reasons.
 785
 786 =cut
 787
 788 sub param {
 789     my $self = shift;
 790
 791     if ( @_ == 0 ) {
 792         return keys %{ $self->parameters };
 793     }
 794
 795     # If anything in @_ is undef, carp about that, and remove it from
 796     # the list;
 797
 798     my @params = grep { defined($_) ? 1 : do {carp "You called ->params with an undefined value"; 0} } @_;
 799
 800     if ( @params == 1 ) {
 801
 802         defined(my $param = shift @params) ||
 803           carp "You called ->params with an undefined value 2";
 804
 805         unless ( exists $self->parameters->{$param} ) {
 806             return wantarray ? () : undef;
 807         }
 808
 809         if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
 810             return (wantarray)
 811               ? @{ $self->parameters->{$param} }
 812               : $self->parameters->{$param}->[0];
 813         }
 814         else {
 815             return (wantarray)
 816               ? ( $self->parameters->{$param} )
 817               : $self->parameters->{$param};
 818         }
 819     }
 820     elsif ( @params > 1 ) {
 821         my $field = shift @params;
 822         $self->parameters->{$field} = [@params];
 823     }
 824 }
 825
 826 =head2 $req->parameters
 827
 828 Returns a reference to a hash containing GET and POST parameters. Values can
 829 be either a scalar or an arrayref containing scalars.
 830
 831     print $c->request->parameters->{field};
 832     print $c->request->parameters->{field}->[0];
 833
 834 This is the combination of C<query_parameters> and C<body_parameters>.
 835
 836 =head2 $req->params
 837
 838 Shortcut for $req->parameters.
 839
 840 =head2 $req->path
 841
 842 Returns the path, i.e. the part of the URI after $req->base, for the current request.
 843
 844     http://localhost/path/foo
 845
 846     $c->request->path will contain 'path/foo'
 847
 848 =head2 $req->path_info
 849
 850 Alias for path, added for compatibility with L<CGI>.
 851
 852 =cut
 853
 854 sub path {
 855     my ( $self, @params ) = @_;
 856
 857     if (@params) {
 858         $self->uri->path(@params);
 859         $self->_clear_path;
 860     }
 861     elsif ( $self->_has_path ) {
 862         return $self->_path;
 863     }
 864     else {
 865         my $path     = $self->uri->path;
 866         my $location = $self->base->path;
 867         $path =~ s/^(\Q$location\E)?//;
 868         $path =~ s/^\///;
 869         $self->_path($path);
 870
 871         return $path;
 872     }
 873 }
 874
 875 =head2 $req->protocol
 876
 877 Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
 878
 879 =head2 $req->query_parameters
 880
 881 =head2 $req->query_params
 882
 883 Returns a reference to a hash containing query string (GET) parameters. Values can
 884 be either a scalar or an arrayref containing scalars.
 885
 886     print $c->request->query_parameters->{field};
 887     print $c->request->query_parameters->{field}->[0];
 888
 889 =head2 $req->read( [$maxlength] )
 890
 891 Reads a chunk of data from the request body. This method is intended to be
 892 used in a while loop, reading $maxlength bytes on every call. $maxlength
 893 defaults to the size of the request if not specified.
 894
 895 =head2 $req->read_chunk(\$buff, $max)
 896
 897 Reads a chunk.
 898
 899 You have to set MyApp->config(parse_on_demand => 1) to use this directly.
 900
 901 =head2 $req->referer
 902
 903 Shortcut for $req->headers->referer. Returns the referring page.
 904
 905 =head2 $req->secure
 906
 907 Returns true or false, indicating whether the connection is secure
 908 (https). The reliability of $req->secure may depend on your server
 909 configuration; Catalyst relies on PSGI to determine whether or not a
 910 request is secure (Catalyst looks at psgi.url_scheme), and different
 911 PSGI servers may make this determination in different ways (as by
 912 directly passing along information from the server, interpreting any of
 913 several HTTP headers, or using heuristics of their own).
 914
 915 =head2 $req->captures
 916
 917 Returns a reference to an array containing captured args from chained
 918 actions or regex captures.
 919
 920     my @captures = @{ $c->request->captures };
 921
 922 =head2 $req->upload
 923
 924 A convenient method to access $req->uploads.
 925
 926     $upload  = $c->request->upload('field');
 927     @uploads = $c->request->upload('field');
 928     @fields  = $c->request->upload;
 929
 930     for my $upload ( $c->request->upload('field') ) {
 931         print $upload->filename;
 932     }
 933
 934 =cut
 935
 936 sub upload {
 937     my $self = shift;
 938
 939     if ( @_ == 0 ) {
 940         return keys %{ $self->uploads };
 941     }
 942
 943     if ( @_ == 1 ) {
 944
 945         my $upload = shift;
 946
 947         unless ( exists $self->uploads->{$upload} ) {
 948             return wantarray ? () : undef;
 949         }
 950
 951         if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
 952             return (wantarray)
 953               ? @{ $self->uploads->{$upload} }
 954               : $self->uploads->{$upload}->[0];
 955         }
 956         else {
 957             return (wantarray)
 958               ? ( $self->uploads->{$upload} )
 959               : $self->uploads->{$upload};
 960         }
 961     }
 962
 963     if ( @_ > 1 ) {
 964
 965         while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
 966
 967             if ( exists $self->uploads->{$field} ) {
 968                 for ( $self->uploads->{$field} ) {
 969                     $_ = [$_] unless ref($_) eq "ARRAY";
 970                     push( @$_, $upload );
 971                 }
 972             }
 973             else {
 974                 $self->uploads->{$field} = $upload;
 975             }
 976         }
 977     }
 978 }
 979
 980 =head2 $req->uploads
 981
 982 Returns a reference to a hash containing uploads. Values can be either a
 983 L<Catalyst::Request::Upload> object, or an arrayref of
 984 L<Catalyst::Request::Upload> objects.
 985
 986     my $upload = $c->request->uploads->{field};
 987     my $upload = $c->request->uploads->{field}->[0];
 988
 989 =head2 $req->uri
 990
 991 Returns a L<URI> object for the current request. Stringifies to the URI text.
 992
 993 =head2 $req->mangle_params( { key => 'value' }, $appendmode);
 994
 995 Returns a hashref of parameters stemming from the current request's params,
 996 plus the ones supplied.  Keys for which no current param exists will be
 997 added, keys with undefined values will be removed and keys with existing
 998 params will be replaced.  Note that you can supply a true value as the final
 999 argument to change behavior with regards to existing parameters, appending
1000 values rather than replacing them.
1001
1002 A quick example:
1003
1004   # URI query params foo=1
1005   my $hashref = $req->mangle_params({ foo => 2 });
1006   # Result is query params of foo=2
1007
1008 versus append mode:
1009
1010   # URI query params foo=1
1011   my $hashref = $req->mangle_params({ foo => 2 }, 1);
1012   # Result is query params of foo=1&foo=2
1013
1014 This is the code behind C<uri_with>.
1015
1016 =cut
1017
1018 sub mangle_params {
1019     my ($self, $args, $append) = @_;
1020
1021     carp('No arguments passed to mangle_params()') unless $args;
1022
1023     foreach my $value ( values %$args ) {
1024         next unless defined $value;
1025         for ( ref $value eq 'ARRAY' ? @$value : $value ) {
1026             $_ = "$_";
1027             #      utf8::encode($_);
1028         }
1029     };
1030
1031     my %params = %{ $self->uri->query_form_hash };
1032     foreach my $key (keys %{ $args }) {
1033         my $val = $args->{$key};
1034         if(defined($val)) {
1035
1036             if($append && exists($params{$key})) {
1037
1038                 # This little bit of heaven handles appending a new value onto
1039                 # an existing one regardless if the existing value is an array
1040                 # or not, and regardless if the new value is an array or not
1041                 $params{$key} = [
1042                     ref($params{$key}) eq 'ARRAY' ? @{ $params{$key} } : $params{$key},
1043                     ref($val) eq 'ARRAY' ? @{ $val } : $val
1044                 ];
1045
1046             } else {
1047                 $params{$key} = $val;
1048             }
1049         } else {
1050
1051             # If the param wasn't defined then we delete it.
1052             delete($params{$key});
1053         }
1054     }
1055
1056
1057     return \%params;
1058 }
1059
1060 =head2 $req->uri_with( { key => 'value' } );
1061
1062 Returns a rewritten URI object for the current request. Key/value pairs
1063 passed in will override existing parameters. You can remove an existing
1064 parameter by passing in an undef value. Unmodified pairs will be
1065 preserved.
1066
1067 You may also pass an optional second parameter that puts C<uri_with> into
1068 append mode:
1069
1070   $req->uri_with( { key => 'value' }, { mode => 'append' } );
1071
1072 See C<mangle_params> for an explanation of this behavior.
1073
1074 =cut
1075
1076 sub uri_with {
1077     my( $self, $args, $behavior) = @_;
1078
1079     carp( 'No arguments passed to uri_with()' ) unless $args;
1080
1081     my $append = 0;
1082     if((ref($behavior) eq 'HASH') && defined($behavior->{mode}) && ($behavior->{mode} eq 'append')) {
1083         $append = 1;
1084     }
1085
1086     my $params = $self->mangle_params($args, $append);
1087
1088     my $uri = $self->uri->clone;
1089     $uri->query_form($params);
1090
1091     return $uri;
1092 }
1093
1094 =head2 $req->remote_user
1095
1096 Returns the value of the C<REMOTE_USER> environment variable.
1097
1098 =head2 $req->user_agent
1099
1100 Shortcut to $req->headers->user_agent. Returns the user agent (browser)
1101 version string.
1102
1103 =head2 $req->io_fh
1104
1105 Returns a psgix.io bidirectional socket, if your server supports one.  Used for
1106 when you want to jailbreak out of PSGI and handle bidirectional client server
1107 communication manually, such as when you are using cometd or websockets.
1108
1109 =head1 SETUP METHODS
1110
1111 You should never need to call these yourself in application code,
1112 however they are useful if extending Catalyst by applying a request role.
1113
1114 =head2 $self->prepare_headers()
1115
1116 Sets up the C<< $res->headers >> accessor.
1117
1118 =head2 $self->prepare_body()
1119
1120 Sets up the body using L<HTTP::Body>
1121
1122 =head2 $self->prepare_body_chunk()
1123
1124 Add a chunk to the request body.
1125
1126 =head2 $self->prepare_body_parameters()
1127
1128 Sets up parameters from body.
1129
1130 =head2 $self->prepare_cookies()
1131
1132 Parse cookies from header. Sets up a L<CGI::Simple::Cookie> object.
1133
1134 =head2 $self->prepare_connection()
1135
1136 Sets up various fields in the request like the local and remote addresses,
1137 request method, hostname requested etc.
1138
1139 =head2 $self->prepare_parameters()
1140
1141 Ensures that the body has been parsed, then builds the parameters, which are
1142 combined from those in the request and those in the body.
1143
1144 If parameters have already been set will clear the parameters and build them again.
1145
1146 =head2 $self->env
1147
1148 Access to the raw PSGI env.
1149
1150 =head2 meta
1151
1152 Provided by Moose
1153
1154 =head1 AUTHORS
1155
1156 Catalyst Contributors, see Catalyst.pm
1157
1158 =head1 COPYRIGHT
1159
1160 This library is free software. You can redistribute it and/or modify
1161 it under the same terms as Perl itself.
1162
1163 =cut
1164
1165 __PACKAGE__->meta->make_immutable;
1166
1167 1;