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