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