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