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 available 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 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 a
 674 whitepaper of the exploit:
 675
 676 L<http://blog.gerv.net/2014/10/new-class-of-vulnerability-in-perl-web-applications/>
 677
 678 B<NOTE> Further discussion on IRC indicate that the L<Catalyst> core team from 'back then'
 679 were well aware of this hack and this is the main reason we added the new approach to
 680 getting parameters in the first place.
 681
 682 Basically this is an exploit that takes advantage of how L<\param> will do one thing
 683 in scalar context and another thing in list context.  This is combined with how Perl
 684 chooses to deal with duplicate keys in a hash definition by overwriting the value of
 685 existing keys with a new value if the same key shows up again.  Generally you will be
 686 vulnerable to this exploit if you are using this method in a direct assignment in a
 687 hash, such as with a L<DBIx::Class> create statement.  For example, if you have
 688 parameters like:
 689
 690     user?user=123&foo=a&foo=user&foo=456
 691
 692 You could end up with extra parameters injected into your method calls:
 693
 694     $c->model('User')->create({
 695       user => $c->req->param('user'),
 696       foo => $c->req->param('foo'),
 697     });
 698
 699 Which would look like:
 700
 701     $c->model('User')->create({
 702       user => 123,
 703       foo => qw(a user 456),
 704     });
 705
 706 (or to be absolutely clear if you are not seeing it):
 707
 708     $c->model('User')->create({
 709       user => 456,
 710       foo => 'a',
 711     });
 712
 713 Possible remediations include scrubbing your parameters with a form validator like
 714 L<HTML::FormHandler> or being careful to force scalar context using the scalar
 715 keyword:
 716
 717     $c->model('User')->create({
 718       user => scalar($c->req->param('user')),
 719       foo => scalar($c->req->param('foo')),
 720     });
 721
 722 Upcoming versions of L<Catalyst> will disable this interface by default and require
 723 you to positively enable it should you require it for backwards compatibility reasons.
 724
 725 =cut
 726
 727 sub param {
 728     my $self = shift;
 729
 730     if ( @_ == 0 ) {
 731         return keys %{ $self->parameters };
 732     }
 733
 734     # If anything in @_ is undef, carp about that, and remove it from
 735     # the list;
 736
 737     my @params = grep { defined($_) ? 1 : do {carp "You called ->params with an undefined value"; 0} } @_;
 738
 739     if ( @params == 1 ) {
 740
 741         defined(my $param = shift @params) ||
 742           carp "You called ->params with an undefined value 2";
 743
 744         unless ( exists $self->parameters->{$param} ) {
 745             return wantarray ? () : undef;
 746         }
 747
 748         if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
 749             return (wantarray)
 750               ? @{ $self->parameters->{$param} }
 751               : $self->parameters->{$param}->[0];
 752         }
 753         else {
 754             return (wantarray)
 755               ? ( $self->parameters->{$param} )
 756               : $self->parameters->{$param};
 757         }
 758     }
 759     elsif ( @params > 1 ) {
 760         my $field = shift @params;
 761         $self->parameters->{$field} = [@params];
 762     }
 763 }
 764
 765 =head2 $req->parameters
 766
 767 Returns a reference to a hash containing GET and POST parameters. Values can
 768 be either a scalar or an arrayref containing scalars.
 769
 770     print $c->request->parameters->{field};
 771     print $c->request->parameters->{field}->[0];
 772
 773 This is the combination of C<query_parameters> and C<body_parameters>.
 774
 775 =head2 $req->params
 776
 777 Shortcut for $req->parameters.
 778
 779 =head2 $req->path
 780
 781 Returns the path, i.e. the part of the URI after $req->base, for the current request.
 782
 783     http://localhost/path/foo
 784
 785     $c->request->path will contain 'path/foo'
 786
 787 =head2 $req->path_info
 788
 789 Alias for path, added for compatibility with L<CGI>.
 790
 791 =cut
 792
 793 sub path {
 794     my ( $self, @params ) = @_;
 795
 796     if (@params) {
 797         $self->uri->path(@params);
 798         $self->_clear_path;
 799     }
 800     elsif ( $self->_has_path ) {
 801         return $self->_path;
 802     }
 803     else {
 804         my $path     = $self->uri->path;
 805         my $location = $self->base->path;
 806         $path =~ s/^(\Q$location\E)?//;
 807         $path =~ s/^\///;
 808         $self->_path($path);
 809
 810         return $path;
 811     }
 812 }
 813
 814 =head2 $req->protocol
 815
 816 Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
 817
 818 =head2 $req->query_parameters
 819
 820 =head2 $req->query_params
 821
 822 Returns a reference to a hash containing query string (GET) parameters. Values can
 823 be either a scalar or an arrayref containing scalars.
 824
 825     print $c->request->query_parameters->{field};
 826     print $c->request->query_parameters->{field}->[0];
 827
 828 =head2 $req->read( [$maxlength] )
 829
 830 Reads a chunk of data from the request body. This method is intended to be
 831 used in a while loop, reading $maxlength bytes on every call. $maxlength
 832 defaults to the size of the request if not specified.
 833
 834 =head2 $req->read_chunk(\$buff, $max)
 835
 836 Reads a chunk.
 837
 838 You have to set MyApp->config(parse_on_demand => 1) to use this directly.
 839
 840 =head2 $req->referer
 841
 842 Shortcut for $req->headers->referer. Returns the referring page.
 843
 844 =head2 $req->secure
 845
 846 Returns true or false, indicating whether the connection is secure
 847 (https). The reliability of $req->secure may depend on your server
 848 configuration; Catalyst relies on PSGI to determine whether or not a
 849 request is secure (Catalyst looks at psgi.url_scheme), and different
 850 PSGI servers may make this determination in different ways (as by
 851 directly passing along information from the server, interpreting any of
 852 several HTTP headers, or using heuristics of their own).
 853
 854 =head2 $req->captures
 855
 856 Returns a reference to an array containing captured args from chained
 857 actions or regex captures.
 858
 859     my @captures = @{ $c->request->captures };
 860
 861 =head2 $req->upload
 862
 863 A convenient method to access $req->uploads.
 864
 865     $upload  = $c->request->upload('field');
 866     @uploads = $c->request->upload('field');
 867     @fields  = $c->request->upload;
 868
 869     for my $upload ( $c->request->upload('field') ) {
 870         print $upload->filename;
 871     }
 872
 873 =cut
 874
 875 sub upload {
 876     my $self = shift;
 877
 878     if ( @_ == 0 ) {
 879         return keys %{ $self->uploads };
 880     }
 881
 882     if ( @_ == 1 ) {
 883
 884         my $upload = shift;
 885
 886         unless ( exists $self->uploads->{$upload} ) {
 887             return wantarray ? () : undef;
 888         }
 889
 890         if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
 891             return (wantarray)
 892               ? @{ $self->uploads->{$upload} }
 893               : $self->uploads->{$upload}->[0];
 894         }
 895         else {
 896             return (wantarray)
 897               ? ( $self->uploads->{$upload} )
 898               : $self->uploads->{$upload};
 899         }
 900     }
 901
 902     if ( @_ > 1 ) {
 903
 904         while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
 905
 906             if ( exists $self->uploads->{$field} ) {
 907                 for ( $self->uploads->{$field} ) {
 908                     $_ = [$_] unless ref($_) eq "ARRAY";
 909                     push( @$_, $upload );
 910                 }
 911             }
 912             else {
 913                 $self->uploads->{$field} = $upload;
 914             }
 915         }
 916     }
 917 }
 918
 919 =head2 $req->uploads
 920
 921 Returns a reference to a hash containing uploads. Values can be either a
 922 L<Catalyst::Request::Upload> object, or an arrayref of
 923 L<Catalyst::Request::Upload> objects.
 924
 925     my $upload = $c->request->uploads->{field};
 926     my $upload = $c->request->uploads->{field}->[0];
 927
 928 =head2 $req->uri
 929
 930 Returns a L<URI> object for the current request. Stringifies to the URI text.
 931
 932 =head2 $req->mangle_params( { key => 'value' }, $appendmode);
 933
 934 Returns a hashref of parameters stemming from the current request's params,
 935 plus the ones supplied.  Keys for which no current param exists will be
 936 added, keys with undefined values will be removed and keys with existing
 937 params will be replaced.  Note that you can supply a true value as the final
 938 argument to change behavior with regards to existing parameters, appending
 939 values rather than replacing them.
 940
 941 A quick example:
 942
 943   # URI query params foo=1
 944   my $hashref = $req->mangle_params({ foo => 2 });
 945   # Result is query params of foo=2
 946
 947 versus append mode:
 948
 949   # URI query params foo=1
 950   my $hashref = $req->mangle_params({ foo => 2 }, 1);
 951   # Result is query params of foo=1&foo=2
 952
 953 This is the code behind C<uri_with>.
 954
 955 =cut
 956
 957 sub mangle_params {
 958     my ($self, $args, $append) = @_;
 959
 960     carp('No arguments passed to mangle_params()') unless $args;
 961
 962     foreach my $value ( values %$args ) {
 963         next unless defined $value;
 964         for ( ref $value eq 'ARRAY' ? @$value : $value ) {
 965             $_ = "$_";
 966             #      utf8::encode($_);
 967         }
 968     };
 969
 970     my %params = %{ $self->uri->query_form_hash };
 971     foreach my $key (keys %{ $args }) {
 972         my $val = $args->{$key};
 973         if(defined($val)) {
 974
 975             if($append && exists($params{$key})) {
 976
 977                 # This little bit of heaven handles appending a new value onto
 978                 # an existing one regardless if the existing value is an array
 979                 # or not, and regardless if the new value is an array or not
 980                 $params{$key} = [
 981                     ref($params{$key}) eq 'ARRAY' ? @{ $params{$key} } : $params{$key},
 982                     ref($val) eq 'ARRAY' ? @{ $val } : $val
 983                 ];
 984
 985             } else {
 986                 $params{$key} = $val;
 987             }
 988         } else {
 989
 990             # If the param wasn't defined then we delete it.
 991             delete($params{$key});
 992         }
 993     }
 994
 995
 996     return \%params;
 997 }
 998
 999 =head2 $req->uri_with( { key => 'value' } );
1000
1001 Returns a rewritten URI object for the current request. Key/value pairs
1002 passed in will override existing parameters. You can remove an existing
1003 parameter by passing in an undef value. Unmodified pairs will be
1004 preserved.
1005
1006 You may also pass an optional second parameter that puts C<uri_with> into
1007 append mode:
1008
1009   $req->uri_with( { key => 'value' }, { mode => 'append' } );
1010
1011 See C<mangle_params> for an explanation of this behavior.
1012
1013 =cut
1014
1015 sub uri_with {
1016     my( $self, $args, $behavior) = @_;
1017
1018     carp( 'No arguments passed to uri_with()' ) unless $args;
1019
1020     my $append = 0;
1021     if((ref($behavior) eq 'HASH') && defined($behavior->{mode}) && ($behavior->{mode} eq 'append')) {
1022         $append = 1;
1023     }
1024
1025     my $params = $self->mangle_params($args, $append);
1026
1027     my $uri = $self->uri->clone;
1028     $uri->query_form($params);
1029
1030     return $uri;
1031 }
1032
1033 =head2 $req->remote_user
1034
1035 Returns the value of the C<REMOTE_USER> environment variable.
1036
1037 =head2 $req->user_agent
1038
1039 Shortcut to $req->headers->user_agent. Returns the user agent (browser)
1040 version string.
1041
1042 =head2 $req->io_fh
1043
1044 Returns a psgix.io bidirectional socket, if your server supports one.  Used for
1045 when you want to jailbreak out of PSGI and handle bidirectional client server
1046 communication manually, such as when you are using cometd or websockets.
1047
1048 =head1 SETUP METHODS
1049
1050 You should never need to call these yourself in application code,
1051 however they are useful if extending Catalyst by applying a request role.
1052
1053 =head2 $self->prepare_headers()
1054
1055 Sets up the C<< $res->headers >> accessor.
1056
1057 =head2 $self->prepare_body()
1058
1059 Sets up the body using L<HTTP::Body>
1060
1061 =head2 $self->prepare_body_chunk()
1062
1063 Add a chunk to the request body.
1064
1065 =head2 $self->prepare_body_parameters()
1066
1067 Sets up parameters from body.
1068
1069 =head2 $self->prepare_cookies()
1070
1071 Parse cookies from header. Sets up a L<CGI::Simple::Cookie> object.
1072
1073 =head2 $self->prepare_connection()
1074
1075 Sets up various fields in the request like the local and remote addresses,
1076 request method, hostname requested etc.
1077
1078 =head2 $self->prepare_parameters()
1079
1080 Ensures that the body has been parsed, then builds the parameters, which are
1081 combined from those in the request and those in the body.
1082
1083 If parameters have already been set will clear the parameters and build them again.
1084
1085 =head2 $self->env
1086
1087 Access to the raw PSGI env.
1088
1089 =head2 meta
1090
1091 Provided by Moose
1092
1093 =head1 AUTHORS
1094
1095 Catalyst Contributors, see Catalyst.pm
1096
1097 =head1 COPYRIGHT
1098
1099 This library is free software. You can redistribute it and/or modify
1100 it under the same terms as Perl itself.
1101
1102 =cut
1103
1104 __PACKAGE__->meta->make_immutable;
1105
1106 1;