lib/Catalyst/Request.pm

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