lib/Catalyst/Request.pm

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