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 action => (is => 'rw');
  18 has address => (is => 'rw');
  19 has arguments => (is => 'rw', default => sub { [] });
  20 has cookies => (is => 'rw', default => sub { {} });
  21 has query_keywords => (is => 'rw');
  22 has match => (is => 'rw');
  23 has method => (is => 'rw');
  24 has protocol => (is => 'rw');
  25 has query_parameters  => (is => 'rw', default => sub { {} });
  26 has secure => (is => 'rw', default => 0);
  27 has captures => (is => 'rw', default => sub { [] });
  28 has uri => (is => 'rw', predicate => 'has_uri');
  29 has remote_user => (is => 'rw');
  30 has headers => (
  31   is      => 'rw',
  32   isa     => 'HTTP::Headers',
  33   handles => [qw(content_encoding content_length content_type header referer user_agent)],
  34   default => sub { HTTP::Headers->new() },
  35   required => 1,
  36   lazy => 1,
  37 );
  38
  39 has _context => (
  40   is => 'rw',
  41   weak_ref => 1,
  42   handles => ['read'],
  43   clearer => '_clear_context',
  44 );
  45
  46 has body_parameters => (
  47   is => 'rw',
  48   required => 1,
  49   lazy => 1,
  50   default => sub { {} },
  51 );
  52
  53 has uploads => (
  54   is => 'rw',
  55   required => 1,
  56   default => sub { {} },
  57 );
  58
  59 has parameters => (
  60   is => 'rw',
  61   required => 1,
  62   lazy => 1,
  63   default => sub { {} },
  64 );
  65
  66 # TODO:
  67 # - Can we lose the before modifiers which just call prepare_body ?
  68 #   they are wasteful, slow us down and feel cluttery.
  69
  70 #  Can we make _body an attribute, have the rest of
  71 #  these lazy build from there and kill all the direct hash access
  72 #  in Catalyst.pm and Engine.pm?
  73
  74 before $_ => sub {
  75     my ($self) = @_;
  76     my $context = $self->_context || return;
  77     $context->prepare_body;
  78 } for qw/parameters body_parameters/;
  79
  80 around parameters => sub {
  81     my ($orig, $self, $params) = @_;
  82     if ($params) {
  83         if ( !ref $params ) {
  84             $self->_context->log->warn(
  85                 "Attempt to retrieve '$params' with req->params(), " .
  86                 "you probably meant to call req->param('$params')"
  87             );
  88             $params = undef;
  89         }
  90         return $self->$orig($params);
  91     }
  92     $self->$orig();
  93 };
  94
  95 has base => (
  96   is => 'rw',
  97   required => 1,
  98   lazy => 1,
  99   default => sub {
 100     my $self = shift;
 101     return $self->path if $self->has_uri;
 102   },
 103 );
 104
 105 has _body => (
 106   is => 'rw', clearer => '_clear_body', predicate => '_has_body',
 107 );
 108 # Eugh, ugly. Should just be able to rename accessor methods to 'body'
 109 #             and provide a custom reader..
 110 sub body {
 111   my $self = shift;
 112   $self->_context->prepare_body();
 113   $self->_body(@_) if scalar @_;
 114   return blessed $self->_body ? $self->_body->body : $self->_body;
 115 }
 116
 117 has hostname => (
 118   is        => 'rw',
 119   required  => 1,
 120   lazy      => 1,
 121   default   => sub {
 122     my ($self) = @_;
 123     gethostbyaddr( inet_aton( $self->address ), AF_INET ) || 'localhost'
 124   },
 125 );
 126
 127 has _path => ( is => 'rw', predicate => '_has_path', clearer => '_clear_path' );
 128
 129 # XXX: Deprecated in docs ages ago (2006), deprecated with warning in 5.8000 due
 130 # to confusion between Engines and Plugin::Authentication. Remove in 5.8100?
 131 has user => (is => 'rw');
 132
 133 sub args            { shift->arguments(@_) }
 134 sub body_params     { shift->body_parameters(@_) }
 135 sub input           { shift->body(@_) }
 136 sub params          { shift->parameters(@_) }
 137 sub query_params    { shift->query_parameters(@_) }
 138 sub path_info       { shift->path(@_) }
 139 sub snippets        { shift->captures(@_) }
 140
 141 =head1 NAME
 142
 143 Catalyst::Request - provides information about the current client request
 144
 145 =head1 SYNOPSIS
 146
 147     $req = $c->request;
 148     $req->action;
 149     $req->address;
 150     $req->arguments;
 151     $req->args;
 152     $req->base;
 153     $req->body;
 154     $req->body_parameters;
 155     $req->content_encoding;
 156     $req->content_length;
 157     $req->content_type;
 158     $req->cookie;
 159     $req->cookies;
 160     $req->header;
 161     $req->headers;
 162     $req->hostname;
 163     $req->input;
 164     $req->query_keywords;
 165     $req->match;
 166     $req->method;
 167     $req->param;
 168     $req->parameters;
 169     $req->params;
 170     $req->path;
 171     $req->protocol;
 172     $req->query_parameters;
 173     $req->read;
 174     $req->referer;
 175     $req->secure;
 176     $req->captures; # previously knows as snippets
 177     $req->upload;
 178     $req->uploads;
 179     $req->uri;
 180     $req->user;
 181     $req->user_agent;
 182
 183 See also L<Catalyst>, L<Catalyst::Request::Upload>.
 184
 185 =head1 DESCRIPTION
 186
 187 This is the Catalyst Request class, which provides an interface to data for the
 188 current client request. The request object is prepared by L<Catalyst::Engine>,
 189 thus hiding the details of the particular engine implementation.
 190
 191 =head1 METHODS
 192
 193 =head2 $req->action
 194
 195 [DEPRECATED] Returns the name of the requested action.
 196
 197
 198 Use C<< $c->action >> instead (which returns a
 199 L<Catalyst::Action|Catalyst::Action> object).
 200
 201 =head2 $req->address
 202
 203 Returns the IP address of the client.
 204
 205 =head2 $req->arguments
 206
 207 Returns a reference to an array containing the arguments.
 208
 209     print $c->request->arguments->[0];
 210
 211 For example, if your action was
 212
 213     package MyApp::C::Foo;
 214
 215     sub moose : Local {
 216         ...
 217     }
 218
 219 and the URI for the request was C<http://.../foo/moose/bah>, the string C<bah>
 220 would be the first and only argument.
 221
 222 Arguments get automatically URI-unescaped for you.
 223
 224 =head2 $req->args
 225
 226 Shortcut for arguments.
 227
 228 =head2 $req->base
 229
 230 Contains the URI base. This will always have a trailing slash. Note that the
 231 URI scheme (eg., http vs. https) must be determined through heuristics;
 232 depending on your server configuration, it may be incorrect. See $req->secure
 233 for more info.
 234
 235 If your application was queried with the URI
 236 C<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>.
 237
 238 =head2 $req->body
 239
 240 Returns the message body of the request, unless Content-Type is
 241 C<application/x-www-form-urlencoded> or C<multipart/form-data>.
 242
 243 =head2 $req->body_parameters
 244
 245 Returns a reference to a hash containing body (POST) parameters. Values can
 246 be either a scalar or an arrayref containing scalars.
 247
 248     print $c->request->body_parameters->{field};
 249     print $c->request->body_parameters->{field}->[0];
 250
 251 These are the parameters from the POST part of the request, if any.
 252
 253 =head2 $req->body_params
 254
 255 Shortcut for body_parameters.
 256
 257 =head2 $req->content_encoding
 258
 259 Shortcut for $req->headers->content_encoding.
 260
 261 =head2 $req->content_length
 262
 263 Shortcut for $req->headers->content_length.
 264
 265 =head2 $req->content_type
 266
 267 Shortcut for $req->headers->content_type.
 268
 269 =head2 $req->cookie
 270
 271 A convenient method to access $req->cookies.
 272
 273     $cookie  = $c->request->cookie('name');
 274     @cookies = $c->request->cookie;
 275
 276 =cut
 277
 278 sub cookie {
 279     my $self = shift;
 280
 281     if ( @_ == 0 ) {
 282         return keys %{ $self->cookies };
 283     }
 284
 285     if ( @_ == 1 ) {
 286
 287         my $name = shift;
 288
 289         unless ( exists $self->cookies->{$name} ) {
 290             return undef;
 291         }
 292
 293         return $self->cookies->{$name};
 294     }
 295 }
 296
 297 =head2 $req->cookies
 298
 299 Returns a reference to a hash containing the cookies.
 300
 301     print $c->request->cookies->{mycookie}->value;
 302
 303 The cookies in the hash are indexed by name, and the values are L<CGI::Cookie>
 304 objects.
 305
 306 =head2 $req->header
 307
 308 Shortcut for $req->headers->header.
 309
 310 =head2 $req->headers
 311
 312 Returns an L<HTTP::Headers> object containing the headers for the current request.
 313
 314     print $c->request->headers->header('X-Catalyst');
 315
 316 =head2 $req->hostname
 317
 318 Returns the hostname of the client.
 319
 320 =head2 $req->input
 321
 322 Alias for $req->body.
 323
 324 =head2 $req->query_keywords
 325
 326 Contains the keywords portion of a query string, when no '=' signs are
 327 present.
 328
 329     http://localhost/path?some+keywords
 330
 331     $c->request->query_keywords will contain 'some keywords'
 332
 333 =head2 $req->match
 334
 335 This contains the matching part of a Regex action. Otherwise
 336 it returns the same as 'action', except for default actions,
 337 which return an empty string.
 338
 339 =head2 $req->method
 340
 341 Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
 342
 343 =head2 $req->param
 344
 345 Returns GET and POST parameters with a CGI.pm-compatible param method. This
 346 is an alternative method for accessing parameters in $c->req->parameters.
 347
 348     $value  = $c->request->param( 'foo' );
 349     @values = $c->request->param( 'foo' );
 350     @params = $c->request->param;
 351
 352 Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
 353 arguments to this method, like this:
 354
 355     $c->request->param( 'foo', 'bar', 'gorch', 'quxx' );
 356
 357 will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
 358 C<quxx>. Previously this would have added C<bar> as another value to C<foo>
 359 (creating it if it didn't exist before), and C<quxx> as another value for
 360 C<gorch>.
 361
 362 B<NOTE> this is considered a legacy interface and care should be taken when
 363 using it. C<< scalar $c->req->param( 'foo' ) >> will return only the first
 364 C<foo> param even if multiple are present; C<< $c->req->param( 'foo' ) >> will
 365 return a list of as many are present, which can have unexpected consequences
 366 when writing code of the form:
 367
 368     $foo->bar(
 369         a => 'b',
 370         baz => $c->req->param( 'baz' ),
 371     );
 372
 373 If multiple C<baz> parameters are provided this code might corrupt data or
 374 cause a hash initialization error. For a more straightforward interface see
 375 C<< $c->req->parameters >>.
 376
 377 =cut
 378
 379 sub param {
 380     my $self = shift;
 381
 382     if ( @_ == 0 ) {
 383         return keys %{ $self->parameters };
 384     }
 385
 386     if ( @_ == 1 ) {
 387
 388         my $param = shift;
 389
 390         unless ( exists $self->parameters->{$param} ) {
 391             return wantarray ? () : undef;
 392         }
 393
 394         if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
 395             return (wantarray)
 396               ? @{ $self->parameters->{$param} }
 397               : $self->parameters->{$param}->[0];
 398         }
 399         else {
 400             return (wantarray)
 401               ? ( $self->parameters->{$param} )
 402               : $self->parameters->{$param};
 403         }
 404     }
 405     elsif ( @_ > 1 ) {
 406         my $field = shift;
 407         $self->parameters->{$field} = [@_];
 408     }
 409 }
 410
 411 =head2 $req->parameters
 412
 413 Returns a reference to a hash containing GET and POST parameters. Values can
 414 be either a scalar or an arrayref containing scalars.
 415
 416     print $c->request->parameters->{field};
 417     print $c->request->parameters->{field}->[0];
 418
 419 This is the combination of C<query_parameters> and C<body_parameters>.
 420
 421 =head2 $req->params
 422
 423 Shortcut for $req->parameters.
 424
 425 =head2 $req->path
 426
 427 Returns the path, i.e. the part of the URI after $req->base, for the current request.
 428
 429 =head2 $req->path_info
 430
 431 Alias for path, added for compatibility with L<CGI>.
 432
 433 =cut
 434
 435 sub path {
 436     my ( $self, @params ) = @_;
 437
 438     if (@params) {
 439         $self->uri->path(@params);
 440         $self->_clear_path;
 441     }
 442     elsif ( $self->_has_path ) {
 443         return $self->_path;
 444     }
 445     else {
 446         my $path     = $self->uri->path;
 447         my $location = $self->base->path;
 448         $path =~ s/^(\Q$location\E)?//;
 449         $path =~ s/^\///;
 450         $self->_path($path);
 451
 452         return $path;
 453     }
 454 }
 455
 456 =head2 $req->protocol
 457
 458 Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
 459
 460 =head2 $req->query_parameters
 461
 462 =head2 $req->query_params
 463
 464 Returns a reference to a hash containing query string (GET) parameters. Values can
 465 be either a scalar or an arrayref containing scalars.
 466
 467     print $c->request->query_parameters->{field};
 468     print $c->request->query_parameters->{field}->[0];
 469
 470 =head2 $req->read( [$maxlength] )
 471
 472 Reads a chunk of data from the request body. This method is intended to be
 473 used in a while loop, reading $maxlength bytes on every call. $maxlength
 474 defaults to the size of the request if not specified.
 475
 476 You have to set MyApp->config(parse_on_demand => 1) to use this directly.
 477
 478 =head2 $req->referer
 479
 480 Shortcut for $req->headers->referer. Returns the referring page.
 481
 482 =head2 $req->secure
 483
 484 Returns true or false, indicating whether the connection is secure
 485 (https). Note that the URI scheme (eg., http vs. https) must be determined
 486 through heuristics, and therefore the reliablity of $req->secure will depend
 487 on your server configuration. If you are serving secure pages on the standard
 488 SSL port (443) and/or setting the HTTPS environment variable, $req->secure
 489 should be valid.
 490
 491 =head2 $req->captures
 492
 493 Returns a reference to an array containing captured args from chained
 494 actions or regex captures.
 495
 496     my @captures = @{ $c->request->captures };
 497
 498 =head2 $req->snippets
 499
 500 C<captures> used to be called snippets. This is still available for backwards
 501 compatibility, but is considered deprecated.
 502
 503 =head2 $req->upload
 504
 505 A convenient method to access $req->uploads.
 506
 507     $upload  = $c->request->upload('field');
 508     @uploads = $c->request->upload('field');
 509     @fields  = $c->request->upload;
 510
 511     for my $upload ( $c->request->upload('field') ) {
 512         print $upload->filename;
 513     }
 514
 515 =cut
 516
 517 sub upload {
 518     my $self = shift;
 519
 520     if ( @_ == 0 ) {
 521         return keys %{ $self->uploads };
 522     }
 523
 524     if ( @_ == 1 ) {
 525
 526         my $upload = shift;
 527
 528         unless ( exists $self->uploads->{$upload} ) {
 529             return wantarray ? () : undef;
 530         }
 531
 532         if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
 533             return (wantarray)
 534               ? @{ $self->uploads->{$upload} }
 535               : $self->uploads->{$upload}->[0];
 536         }
 537         else {
 538             return (wantarray)
 539               ? ( $self->uploads->{$upload} )
 540               : $self->uploads->{$upload};
 541         }
 542     }
 543
 544     if ( @_ > 1 ) {
 545
 546         while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
 547
 548             if ( exists $self->uploads->{$field} ) {
 549                 for ( $self->uploads->{$field} ) {
 550                     $_ = [$_] unless ref($_) eq "ARRAY";
 551                     push( @$_, $upload );
 552                 }
 553             }
 554             else {
 555                 $self->uploads->{$field} = $upload;
 556             }
 557         }
 558     }
 559 }
 560
 561 =head2 $req->uploads
 562
 563 Returns a reference to a hash containing uploads. Values can be either a
 564 L<Catalyst::Request::Upload> object, or an arrayref of
 565 L<Catalyst::Request::Upload> objects.
 566
 567     my $upload = $c->request->uploads->{field};
 568     my $upload = $c->request->uploads->{field}->[0];
 569
 570 =head2 $req->uri
 571
 572 Returns a URI object for the current request. Stringifies to the URI text.
 573
 574 =head2 $req->mangle_params( { key => 'value' }, $appendmode);
 575
 576 Returns a hashref of parameters stemming from the current request's params,
 577 plus the ones supplied.  Keys for which no current param exists will be
 578 added, keys with undefined values will be removed and keys with existing
 579 params will be replaced.  Note that you can supply a true value as the final
 580 argument to change behavior with regards to existing parameters, appending
 581 values rather than replacing them.
 582
 583 A quick example:
 584
 585   # URI query params foo=1
 586   my $hashref = $req->mangle_params({ foo => 2 });
 587   # Result is query params of foo=2
 588
 589 versus append mode:
 590
 591   # URI query params foo=1
 592   my $hashref = $req->mangle_params({ foo => 2 }, 1);
 593   # Result is query params of foo=1&foo=2
 594
 595 This is the code behind C<uri_with>.
 596
 597 =cut
 598
 599 sub mangle_params {
 600     my ($self, $args, $append) = @_;
 601
 602     carp('No arguments passed to mangle_params()') unless $args;
 603
 604     foreach my $value ( values %$args ) {
 605         next unless defined $value;
 606         for ( ref $value eq 'ARRAY' ? @$value : $value ) {
 607             $_ = "$_";
 608             utf8::encode( $_ ) if utf8::is_utf8($_);
 609         }
 610     };
 611
 612     my %params = %{ $self->uri->query_form_hash };
 613     foreach my $key (keys %{ $args }) {
 614         my $val = $args->{$key};
 615         if(defined($val)) {
 616
 617             if($append && exists($params{$key})) {
 618
 619                 # This little bit of heaven handles appending a new value onto
 620                 # an existing one regardless if the existing value is an array
 621                 # or not, and regardless if the new value is an array or not
 622                 $params{$key} = [
 623                     ref($params{$key}) eq 'ARRAY' ? @{ $params{$key} } : $params{$key},
 624                     ref($val) eq 'ARRAY' ? @{ $val } : $val
 625                 ];
 626
 627             } else {
 628                 $params{$key} = $val;
 629             }
 630         } else {
 631
 632             # If the param wasn't defined then we delete it.
 633             delete($params{$key});
 634         }
 635     }
 636
 637
 638     return \%params;
 639 }
 640
 641 =head2 $req->uri_with( { key => 'value' } );
 642
 643 Returns a rewritten URI object for the current request. Key/value pairs
 644 passed in will override existing parameters. You can remove an existing
 645 parameter by passing in an undef value. Unmodified pairs will be
 646 preserved.
 647
 648 You may also pass an optional second parameter that puts C<uri_with> into
 649 append mode:
 650
 651   $req->uri_with( { key => 'value' }, { mode => 'append' } );
 652
 653 See C<mangle_params> for an explanation of this behavior.
 654
 655 =cut
 656
 657 sub uri_with {
 658     my( $self, $args, $behavior) = @_;
 659
 660     carp( 'No arguments passed to uri_with()' ) unless $args;
 661
 662     my $append = 0;
 663     if((ref($behavior) eq 'HASH') && defined($behavior->{mode}) && ($behavior->{mode} eq 'append')) {
 664         $append = 1;
 665     }
 666
 667     my $params = $self->mangle_params($args, $append);
 668
 669     my $uri = $self->uri->clone;
 670     $uri->query_form($params);
 671
 672     return $uri;
 673 }
 674
 675 =head2 $req->user
 676
 677 Returns the currently logged in user. B<Highly deprecated>, do not call,
 678 this will be removed in version 5.81.
 679
 680 =head2 $req->remote_user
 681
 682 Returns the value of the C<REMOTE_USER> environment variable.
 683
 684 =head2 $req->user_agent
 685
 686 Shortcut to $req->headers->user_agent. Returns the user agent (browser)
 687 version string.
 688
 689 =head2 meta
 690
 691 Provided by Moose
 692
 693 =head1 AUTHORS
 694
 695 Catalyst Contributors, see Catalyst.pm
 696
 697 =head1 COPYRIGHT
 698
 699 This library is free software. You can redistribute it and/or modify
 700 it under the same terms as Perl itself.
 701
 702 =cut
 703
 704 __PACKAGE__->meta->make_immutable;
 705
 706 1;