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