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