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