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