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');
  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 _context => (
  85   is => 'rw',
  86   weak_ref => 1,
  87   clearer => '_clear_context',
  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->_context->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->action;
 335     $req->address;
 336     $req->arguments;
 337     $req->args;
 338     $req->base;
 339     $req->body;
 340     $req->body_parameters;
 341     $req->content_encoding;
 342     $req->content_length;
 343     $req->content_type;
 344     $req->cookie;
 345     $req->cookies;
 346     $req->header;
 347     $req->headers;
 348     $req->hostname;
 349     $req->input;
 350     $req->query_keywords;
 351     $req->match;
 352     $req->method;
 353     $req->param;
 354     $req->parameters;
 355     $req->params;
 356     $req->path;
 357     $req->protocol;
 358     $req->query_parameters;
 359     $req->read;
 360     $req->referer;
 361     $req->secure;
 362     $req->captures; # previously knows as snippets
 363     $req->upload;
 364     $req->uploads;
 365     $req->uri;
 366     $req->user;
 367     $req->user_agent;
 368
 369 See also L<Catalyst>, L<Catalyst::Request::Upload>.
 370
 371 =head1 DESCRIPTION
 372
 373 This is the Catalyst Request class, which provides an interface to data for the
 374 current client request. The request object is prepared by L<Catalyst::Engine>,
 375 thus hiding the details of the particular engine implementation.
 376
 377 =head1 METHODS
 378
 379 =head2 $req->action
 380
 381 [DEPRECATED] Returns the name of the requested action.
 382
 383
 384 Use C<< $c->action >> instead (which returns a
 385 L<Catalyst::Action|Catalyst::Action> object).
 386
 387 =head2 $req->address
 388
 389 Returns the IP address of the client.
 390
 391 =head2 $req->arguments
 392
 393 Returns a reference to an array containing the arguments.
 394
 395     print $c->request->arguments->[0];
 396
 397 For example, if your action was
 398
 399     package MyApp::Controller::Foo;
 400
 401     sub moose : Local {
 402         ...
 403     }
 404
 405 and the URI for the request was C<http://.../foo/moose/bah>, the string C<bah>
 406 would be the first and only argument.
 407
 408 Arguments get automatically URI-unescaped for you.
 409
 410 =head2 $req->args
 411
 412 Shortcut for L</arguments>.
 413
 414 =head2 $req->base
 415
 416 Contains the URI base. This will always have a trailing slash. Note that the
 417 URI scheme (e.g., http vs. https) must be determined through heuristics;
 418 depending on your server configuration, it may be incorrect. See $req->secure
 419 for more info.
 420
 421 If your application was queried with the URI
 422 C<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>.
 423
 424 =head2 $req->body
 425
 426 Returns the message body of the request, as returned by L<HTTP::Body>: a string,
 427 unless Content-Type is C<application/x-www-form-urlencoded>, C<text/xml>, or
 428 C<multipart/form-data>, in which case a L<File::Temp> object is returned.
 429
 430 =head2 $req->body_parameters
 431
 432 Returns a reference to a hash containing body (POST) parameters. Values can
 433 be either a scalar or an arrayref containing scalars.
 434
 435     print $c->request->body_parameters->{field};
 436     print $c->request->body_parameters->{field}->[0];
 437
 438 These are the parameters from the POST part of the request, if any.
 439
 440 =head2 $req->body_params
 441
 442 Shortcut for body_parameters.
 443
 444 =head2 $req->content_encoding
 445
 446 Shortcut for $req->headers->content_encoding.
 447
 448 =head2 $req->content_length
 449
 450 Shortcut for $req->headers->content_length.
 451
 452 =head2 $req->content_type
 453
 454 Shortcut for $req->headers->content_type.
 455
 456 =head2 $req->cookie
 457
 458 A convenient method to access $req->cookies.
 459
 460     $cookie  = $c->request->cookie('name');
 461     @cookies = $c->request->cookie;
 462
 463 =cut
 464
 465 sub cookie {
 466     my $self = shift;
 467
 468     if ( @_ == 0 ) {
 469         return keys %{ $self->cookies };
 470     }
 471
 472     if ( @_ == 1 ) {
 473
 474         my $name = shift;
 475
 476         unless ( exists $self->cookies->{$name} ) {
 477             return undef;
 478         }
 479
 480         return $self->cookies->{$name};
 481     }
 482 }
 483
 484 =head2 $req->cookies
 485
 486 Returns a reference to a hash containing the cookies.
 487
 488     print $c->request->cookies->{mycookie}->value;
 489
 490 The cookies in the hash are indexed by name, and the values are L<CGI::Simple::Cookie>
 491 objects.
 492
 493 =head2 $req->header
 494
 495 Shortcut for $req->headers->header.
 496
 497 =head2 $req->headers
 498
 499 Returns an L<HTTP::Headers> object containing the headers for the current request.
 500
 501     print $c->request->headers->header('X-Catalyst');
 502
 503 =head2 $req->hostname
 504
 505 Returns the hostname of the client. Use C<< $req->uri->host >> to get the hostname of the server.
 506
 507 =head2 $req->input
 508
 509 Alias for $req->body.
 510
 511 =head2 $req->query_keywords
 512
 513 Contains the keywords portion of a query string, when no '=' signs are
 514 present.
 515
 516     http://localhost/path?some+keywords
 517
 518     $c->request->query_keywords will contain 'some keywords'
 519
 520 =head2 $req->match
 521
 522 This contains the matching part of a Regex action. Otherwise
 523 it returns the same as 'action', except for default actions,
 524 which return an empty string.
 525
 526 =head2 $req->method
 527
 528 Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
 529
 530 =head2 $req->param
 531
 532 Returns GET and POST parameters with a CGI.pm-compatible param method. This
 533 is an alternative method for accessing parameters in $c->req->parameters.
 534
 535     $value  = $c->request->param( 'foo' );
 536     @values = $c->request->param( 'foo' );
 537     @params = $c->request->param;
 538
 539 Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
 540 arguments to this method, like this:
 541
 542     $c->request->param( 'foo', 'bar', 'gorch', 'quxx' );
 543
 544 will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
 545 C<quxx>. Previously this would have added C<bar> as another value to C<foo>
 546 (creating it if it didn't exist before), and C<quxx> as another value for
 547 C<gorch>.
 548
 549 B<NOTE> this is considered a legacy interface and care should be taken when
 550 using it. C<< scalar $c->req->param( 'foo' ) >> will return only the first
 551 C<foo> param even if multiple are present; C<< $c->req->param( 'foo' ) >> will
 552 return a list of as many are present, which can have unexpected consequences
 553 when writing code of the form:
 554
 555     $foo->bar(
 556         a => 'b',
 557         baz => $c->req->param( 'baz' ),
 558     );
 559
 560 If multiple C<baz> parameters are provided this code might corrupt data or
 561 cause a hash initialization error. For a more straightforward interface see
 562 C<< $c->req->parameters >>.
 563
 564 =cut
 565
 566 sub param {
 567     my $self = shift;
 568
 569     if ( @_ == 0 ) {
 570         return keys %{ $self->parameters };
 571     }
 572
 573     if ( @_ == 1 ) {
 574
 575         my $param = shift;
 576
 577         unless ( exists $self->parameters->{$param} ) {
 578             return wantarray ? () : undef;
 579         }
 580
 581         if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
 582             return (wantarray)
 583               ? @{ $self->parameters->{$param} }
 584               : $self->parameters->{$param}->[0];
 585         }
 586         else {
 587             return (wantarray)
 588               ? ( $self->parameters->{$param} )
 589               : $self->parameters->{$param};
 590         }
 591     }
 592     elsif ( @_ > 1 ) {
 593         my $field = shift;
 594         $self->parameters->{$field} = [@_];
 595     }
 596 }
 597
 598 =head2 $req->parameters
 599
 600 Returns a reference to a hash containing GET and POST parameters. Values can
 601 be either a scalar or an arrayref containing scalars.
 602
 603     print $c->request->parameters->{field};
 604     print $c->request->parameters->{field}->[0];
 605
 606 This is the combination of C<query_parameters> and C<body_parameters>.
 607
 608 =head2 $req->params
 609
 610 Shortcut for $req->parameters.
 611
 612 =head2 $req->path
 613
 614 Returns the path, i.e. the part of the URI after $req->base, for the current request.
 615
 616     http://localhost/path/foo
 617
 618     $c->request->path will contain 'path/foo'
 619
 620 =head2 $req->path_info
 621
 622 Alias for path, added for compatibility with L<CGI>.
 623
 624 =cut
 625
 626 sub path {
 627     my ( $self, @params ) = @_;
 628
 629     if (@params) {
 630         $self->uri->path(@params);
 631         $self->_clear_path;
 632     }
 633     elsif ( $self->_has_path ) {
 634         return $self->_path;
 635     }
 636     else {
 637         my $path     = $self->uri->path;
 638         my $location = $self->base->path;
 639         $path =~ s/^(\Q$location\E)?//;
 640         $path =~ s/^\///;
 641         $self->_path($path);
 642
 643         return $path;
 644     }
 645 }
 646
 647 =head2 $req->protocol
 648
 649 Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
 650
 651 =head2 $req->query_parameters
 652
 653 =head2 $req->query_params
 654
 655 Returns a reference to a hash containing query string (GET) parameters. Values can
 656 be either a scalar or an arrayref containing scalars.
 657
 658     print $c->request->query_parameters->{field};
 659     print $c->request->query_parameters->{field}->[0];
 660
 661 =head2 $req->read( [$maxlength] )
 662
 663 Reads a chunk of data from the request body. This method is intended to be
 664 used in a while loop, reading $maxlength bytes on every call. $maxlength
 665 defaults to the size of the request if not specified.
 666
 667 =head2 $req->read_chunk(\$buff, $max)
 668
 669 Reads a chunk..
 670
 671 You have to set MyApp->config(parse_on_demand => 1) to use this directly.
 672
 673 =head2 $req->referer
 674
 675 Shortcut for $req->headers->referer. Returns the referring page.
 676
 677 =head2 $req->secure
 678
 679 Returns true or false, indicating whether the connection is secure
 680 (https). Note that the URI scheme (e.g., http vs. https) must be determined
 681 through heuristics, and therefore the reliability of $req->secure will depend
 682 on your server configuration. If you are serving secure pages on the standard
 683 SSL port (443) and/or setting the HTTPS environment variable, $req->secure
 684 should be valid.
 685
 686 =head2 $req->captures
 687
 688 Returns a reference to an array containing captured args from chained
 689 actions or regex captures.
 690
 691     my @captures = @{ $c->request->captures };
 692
 693 =head2 $req->snippets
 694
 695 C<captures> used to be called snippets. This is still available for backwards
 696 compatibility, but is considered deprecated.
 697
 698 =head2 $req->upload
 699
 700 A convenient method to access $req->uploads.
 701
 702     $upload  = $c->request->upload('field');
 703     @uploads = $c->request->upload('field');
 704     @fields  = $c->request->upload;
 705
 706     for my $upload ( $c->request->upload('field') ) {
 707         print $upload->filename;
 708     }
 709
 710 =cut
 711
 712 sub upload {
 713     my $self = shift;
 714
 715     if ( @_ == 0 ) {
 716         return keys %{ $self->uploads };
 717     }
 718
 719     if ( @_ == 1 ) {
 720
 721         my $upload = shift;
 722
 723         unless ( exists $self->uploads->{$upload} ) {
 724             return wantarray ? () : undef;
 725         }
 726
 727         if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
 728             return (wantarray)
 729               ? @{ $self->uploads->{$upload} }
 730               : $self->uploads->{$upload}->[0];
 731         }
 732         else {
 733             return (wantarray)
 734               ? ( $self->uploads->{$upload} )
 735               : $self->uploads->{$upload};
 736         }
 737     }
 738
 739     if ( @_ > 1 ) {
 740
 741         while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
 742
 743             if ( exists $self->uploads->{$field} ) {
 744                 for ( $self->uploads->{$field} ) {
 745                     $_ = [$_] unless ref($_) eq "ARRAY";
 746                     push( @$_, $upload );
 747                 }
 748             }
 749             else {
 750                 $self->uploads->{$field} = $upload;
 751             }
 752         }
 753     }
 754 }
 755
 756 =head2 $req->uploads
 757
 758 Returns a reference to a hash containing uploads. Values can be either a
 759 L<Catalyst::Request::Upload> object, or an arrayref of
 760 L<Catalyst::Request::Upload> objects.
 761
 762     my $upload = $c->request->uploads->{field};
 763     my $upload = $c->request->uploads->{field}->[0];
 764
 765 =head2 $req->uri
 766
 767 Returns a L<URI> object for the current request. Stringifies to the URI text.
 768
 769 =head2 $req->mangle_params( { key => 'value' }, $appendmode);
 770
 771 Returns a hashref of parameters stemming from the current request's params,
 772 plus the ones supplied.  Keys for which no current param exists will be
 773 added, keys with undefined values will be removed and keys with existing
 774 params will be replaced.  Note that you can supply a true value as the final
 775 argument to change behavior with regards to existing parameters, appending
 776 values rather than replacing them.
 777
 778 A quick example:
 779
 780   # URI query params foo=1
 781   my $hashref = $req->mangle_params({ foo => 2 });
 782   # Result is query params of foo=2
 783
 784 versus append mode:
 785
 786   # URI query params foo=1
 787   my $hashref = $req->mangle_params({ foo => 2 }, 1);
 788   # Result is query params of foo=1&foo=2
 789
 790 This is the code behind C<uri_with>.
 791
 792 =cut
 793
 794 sub mangle_params {
 795     my ($self, $args, $append) = @_;
 796
 797     carp('No arguments passed to mangle_params()') unless $args;
 798
 799     foreach my $value ( values %$args ) {
 800         next unless defined $value;
 801         for ( ref $value eq 'ARRAY' ? @$value : $value ) {
 802             $_ = "$_";
 803             utf8::encode( $_ ) if utf8::is_utf8($_);
 804         }
 805     };
 806
 807     my %params = %{ $self->uri->query_form_hash };
 808     foreach my $key (keys %{ $args }) {
 809         my $val = $args->{$key};
 810         if(defined($val)) {
 811
 812             if($append && exists($params{$key})) {
 813
 814                 # This little bit of heaven handles appending a new value onto
 815                 # an existing one regardless if the existing value is an array
 816                 # or not, and regardless if the new value is an array or not
 817                 $params{$key} = [
 818                     ref($params{$key}) eq 'ARRAY' ? @{ $params{$key} } : $params{$key},
 819                     ref($val) eq 'ARRAY' ? @{ $val } : $val
 820                 ];
 821
 822             } else {
 823                 $params{$key} = $val;
 824             }
 825         } else {
 826
 827             # If the param wasn't defined then we delete it.
 828             delete($params{$key});
 829         }
 830     }
 831
 832
 833     return \%params;
 834 }
 835
 836 =head2 $req->uri_with( { key => 'value' } );
 837
 838 Returns a rewritten URI object for the current request. Key/value pairs
 839 passed in will override existing parameters. You can remove an existing
 840 parameter by passing in an undef value. Unmodified pairs will be
 841 preserved.
 842
 843 You may also pass an optional second parameter that puts C<uri_with> into
 844 append mode:
 845
 846   $req->uri_with( { key => 'value' }, { mode => 'append' } );
 847
 848 See C<mangle_params> for an explanation of this behavior.
 849
 850 =cut
 851
 852 sub uri_with {
 853     my( $self, $args, $behavior) = @_;
 854
 855     carp( 'No arguments passed to uri_with()' ) unless $args;
 856
 857     my $append = 0;
 858     if((ref($behavior) eq 'HASH') && defined($behavior->{mode}) && ($behavior->{mode} eq 'append')) {
 859         $append = 1;
 860     }
 861
 862     my $params = $self->mangle_params($args, $append);
 863
 864     my $uri = $self->uri->clone;
 865     $uri->query_form($params);
 866
 867     return $uri;
 868 }
 869
 870 =head2 $req->remote_user
 871
 872 Returns the value of the C<REMOTE_USER> environment variable.
 873
 874 =head2 $req->user_agent
 875
 876 Shortcut to $req->headers->user_agent. Returns the user agent (browser)
 877 version string.
 878
 879 =head2 meta
 880
 881 Provided by Moose
 882
 883 =head1 AUTHORS
 884
 885 Catalyst Contributors, see Catalyst.pm
 886
 887 =head1 COPYRIGHT
 888
 889 This library is free software. You can redistribute it and/or modify
 890 it under the same terms as Perl itself.
 891
 892 =cut
 893
 894 __PACKAGE__->meta->make_immutable;
 895
 896 1;