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