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