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