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