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