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 L</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, as returned by L<HTTP::Body>: a string,
 241 unless Content-Type is C<application/x-www-form-urlencoded>, C<text/xml>, or
 242 C<multipart/form-data>, in which case a L<File::Temp> object is returned.
 243
 244 =head2 $req->body_parameters
 245
 246 Returns a reference to a hash containing body (POST) parameters. Values can
 247 be either a scalar or an arrayref containing scalars.
 248
 249     print $c->request->body_parameters->{field};
 250     print $c->request->body_parameters->{field}->[0];
 251
 252 These are the parameters from the POST part of the request, if any.
 253
 254 =head2 $req->body_params
 255
 256 Shortcut for body_parameters.
 257
 258 =head2 $req->content_encoding
 259
 260 Shortcut for $req->headers->content_encoding.
 261
 262 =head2 $req->content_length
 263
 264 Shortcut for $req->headers->content_length.
 265
 266 =head2 $req->content_type
 267
 268 Shortcut for $req->headers->content_type.
 269
 270 =head2 $req->cookie
 271
 272 A convenient method to access $req->cookies.
 273
 274     $cookie  = $c->request->cookie('name');
 275     @cookies = $c->request->cookie;
 276
 277 =cut
 278
 279 sub cookie {
 280     my $self = shift;
 281
 282     if ( @_ == 0 ) {
 283         return keys %{ $self->cookies };
 284     }
 285
 286     if ( @_ == 1 ) {
 287
 288         my $name = shift;
 289
 290         unless ( exists $self->cookies->{$name} ) {
 291             return undef;
 292         }
 293
 294         return $self->cookies->{$name};
 295     }
 296 }
 297
 298 =head2 $req->cookies
 299
 300 Returns a reference to a hash containing the cookies.
 301
 302     print $c->request->cookies->{mycookie}->value;
 303
 304 The cookies in the hash are indexed by name, and the values are L<CGI::Simple::Cookie>
 305 objects.
 306
 307 =head2 $req->header
 308
 309 Shortcut for $req->headers->header.
 310
 311 =head2 $req->headers
 312
 313 Returns an L<HTTP::Headers> object containing the headers for the current request.
 314
 315     print $c->request->headers->header('X-Catalyst');
 316
 317 =head2 $req->hostname
 318
 319 Returns the hostname of the client.
 320
 321 =head2 $req->input
 322
 323 Alias for $req->body.
 324
 325 =head2 $req->query_keywords
 326
 327 Contains the keywords portion of a query string, when no '=' signs are
 328 present.
 329
 330     http://localhost/path?some+keywords
 331
 332     $c->request->query_keywords will contain 'some keywords'
 333
 334 =head2 $req->match
 335
 336 This contains the matching part of a Regex action. Otherwise
 337 it returns the same as 'action', except for default actions,
 338 which return an empty string.
 339
 340 =head2 $req->method
 341
 342 Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
 343
 344 =head2 $req->param
 345
 346 Returns GET and POST parameters with a CGI.pm-compatible param method. This
 347 is an alternative method for accessing parameters in $c->req->parameters.
 348
 349     $value  = $c->request->param( 'foo' );
 350     @values = $c->request->param( 'foo' );
 351     @params = $c->request->param;
 352
 353 Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
 354 arguments to this method, like this:
 355
 356     $c->request->param( 'foo', 'bar', 'gorch', 'quxx' );
 357
 358 will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
 359 C<quxx>. Previously this would have added C<bar> as another value to C<foo>
 360 (creating it if it didn't exist before), and C<quxx> as another value for
 361 C<gorch>.
 362
 363 B<NOTE> this is considered a legacy interface and care should be taken when
 364 using it. C<< scalar $c->req->param( 'foo' ) >> will return only the first
 365 C<foo> param even if multiple are present; C<< $c->req->param( 'foo' ) >> will
 366 return a list of as many are present, which can have unexpected consequences
 367 when writing code of the form:
 368
 369     $foo->bar(
 370         a => 'b',
 371         baz => $c->req->param( 'baz' ),
 372     );
 373
 374 If multiple C<baz> parameters are provided this code might corrupt data or
 375 cause a hash initialization error. For a more straightforward interface see
 376 C<< $c->req->parameters >>.
 377
 378 =cut
 379
 380 sub param {
 381     my $self = shift;
 382
 383     if ( @_ == 0 ) {
 384         return keys %{ $self->parameters };
 385     }
 386
 387     if ( @_ == 1 ) {
 388
 389         my $param = shift;
 390
 391         unless ( exists $self->parameters->{$param} ) {
 392             return wantarray ? () : undef;
 393         }
 394
 395         if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
 396             return (wantarray)
 397               ? @{ $self->parameters->{$param} }
 398               : $self->parameters->{$param}->[0];
 399         }
 400         else {
 401             return (wantarray)
 402               ? ( $self->parameters->{$param} )
 403               : $self->parameters->{$param};
 404         }
 405     }
 406     elsif ( @_ > 1 ) {
 407         my $field = shift;
 408         $self->parameters->{$field} = [@_];
 409     }
 410 }
 411
 412 =head2 $req->parameters
 413
 414 Returns a reference to a hash containing GET and POST parameters. Values can
 415 be either a scalar or an arrayref containing scalars.
 416
 417     print $c->request->parameters->{field};
 418     print $c->request->parameters->{field}->[0];
 419
 420 This is the combination of C<query_parameters> and C<body_parameters>.
 421
 422 =head2 $req->params
 423
 424 Shortcut for $req->parameters.
 425
 426 =head2 $req->path
 427
 428 Returns the path, i.e. the part of the URI after $req->base, for the current request.
 429
 430 =head2 $req->path_info
 431
 432 Alias for path, added for compatibility with L<CGI>.
 433
 434 =cut
 435
 436 sub path {
 437     my ( $self, @params ) = @_;
 438
 439     if (@params) {
 440         $self->uri->path(@params);
 441         $self->_clear_path;
 442     }
 443     elsif ( $self->_has_path ) {
 444         return $self->_path;
 445     }
 446     else {
 447         my $path     = $self->uri->path;
 448         my $location = $self->base->path;
 449         $path =~ s/^(\Q$location\E)?//;
 450         $path =~ s/^\///;
 451         $self->_path($path);
 452
 453         return $path;
 454     }
 455 }
 456
 457 =head2 $req->protocol
 458
 459 Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
 460
 461 =head2 $req->query_parameters
 462
 463 =head2 $req->query_params
 464
 465 Returns a reference to a hash containing query string (GET) parameters. Values can
 466 be either a scalar or an arrayref containing scalars.
 467
 468     print $c->request->query_parameters->{field};
 469     print $c->request->query_parameters->{field}->[0];
 470
 471 =head2 $req->read( [$maxlength] )
 472
 473 Reads a chunk of data from the request body. This method is intended to be
 474 used in a while loop, reading $maxlength bytes on every call. $maxlength
 475 defaults to the size of the request if not specified.
 476
 477 You have to set MyApp->config(parse_on_demand => 1) to use this directly.
 478
 479 =head2 $req->referer
 480
 481 Shortcut for $req->headers->referer. Returns the referring page.
 482
 483 =head2 $req->secure
 484
 485 Returns true or false, indicating whether the connection is secure
 486 (https). Note that the URI scheme (eg., http vs. https) must be determined
 487 through heuristics, and therefore the reliablity of $req->secure will depend
 488 on your server configuration. If you are serving secure pages on the standard
 489 SSL port (443) and/or setting the HTTPS environment variable, $req->secure
 490 should be valid.
 491
 492 =head2 $req->captures
 493
 494 Returns a reference to an array containing captured args from chained
 495 actions or regex captures.
 496
 497     my @captures = @{ $c->request->captures };
 498
 499 =head2 $req->snippets
 500
 501 C<captures> used to be called snippets. This is still available for backwards
 502 compatibility, but is considered deprecated.
 503
 504 =head2 $req->upload
 505
 506 A convenient method to access $req->uploads.
 507
 508     $upload  = $c->request->upload('field');
 509     @uploads = $c->request->upload('field');
 510     @fields  = $c->request->upload;
 511
 512     for my $upload ( $c->request->upload('field') ) {
 513         print $upload->filename;
 514     }
 515
 516 =cut
 517
 518 sub upload {
 519     my $self = shift;
 520
 521     if ( @_ == 0 ) {
 522         return keys %{ $self->uploads };
 523     }
 524
 525     if ( @_ == 1 ) {
 526
 527         my $upload = shift;
 528
 529         unless ( exists $self->uploads->{$upload} ) {
 530             return wantarray ? () : undef;
 531         }
 532
 533         if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
 534             return (wantarray)
 535               ? @{ $self->uploads->{$upload} }
 536               : $self->uploads->{$upload}->[0];
 537         }
 538         else {
 539             return (wantarray)
 540               ? ( $self->uploads->{$upload} )
 541               : $self->uploads->{$upload};
 542         }
 543     }
 544
 545     if ( @_ > 1 ) {
 546
 547         while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
 548
 549             if ( exists $self->uploads->{$field} ) {
 550                 for ( $self->uploads->{$field} ) {
 551                     $_ = [$_] unless ref($_) eq "ARRAY";
 552                     push( @$_, $upload );
 553                 }
 554             }
 555             else {
 556                 $self->uploads->{$field} = $upload;
 557             }
 558         }
 559     }
 560 }
 561
 562 =head2 $req->uploads
 563
 564 Returns a reference to a hash containing uploads. Values can be either a
 565 L<Catalyst::Request::Upload> object, or an arrayref of
 566 L<Catalyst::Request::Upload> objects.
 567
 568     my $upload = $c->request->uploads->{field};
 569     my $upload = $c->request->uploads->{field}->[0];
 570
 571 =head2 $req->uri
 572
 573 Returns a URI object for the current request. Stringifies to the URI text.
 574
 575 =head2 $req->mangle_params( { key => 'value' }, $appendmode);
 576
 577 Returns a hashref of parameters stemming from the current request's params,
 578 plus the ones supplied.  Keys for which no current param exists will be
 579 added, keys with undefined values will be removed and keys with existing
 580 params will be replaced.  Note that you can supply a true value as the final
 581 argument to change behavior with regards to existing parameters, appending
 582 values rather than replacing them.
 583
 584 A quick example:
 585
 586   # URI query params foo=1
 587   my $hashref = $req->mangle_params({ foo => 2 });
 588   # Result is query params of foo=2
 589
 590 versus append mode:
 591
 592   # URI query params foo=1
 593   my $hashref = $req->mangle_params({ foo => 2 }, 1);
 594   # Result is query params of foo=1&foo=2
 595
 596 This is the code behind C<uri_with>.
 597
 598 =cut
 599
 600 sub mangle_params {
 601     my ($self, $args, $append) = @_;
 602
 603     carp('No arguments passed to mangle_params()') unless $args;
 604
 605     foreach my $value ( values %$args ) {
 606         next unless defined $value;
 607         for ( ref $value eq 'ARRAY' ? @$value : $value ) {
 608             $_ = "$_";
 609             utf8::encode( $_ ) if utf8::is_utf8($_);
 610         }
 611     };
 612
 613     my %params = %{ $self->uri->query_form_hash };
 614     foreach my $key (keys %{ $args }) {
 615         my $val = $args->{$key};
 616         if(defined($val)) {
 617
 618             if($append && exists($params{$key})) {
 619
 620                 # This little bit of heaven handles appending a new value onto
 621                 # an existing one regardless if the existing value is an array
 622                 # or not, and regardless if the new value is an array or not
 623                 $params{$key} = [
 624                     ref($params{$key}) eq 'ARRAY' ? @{ $params{$key} } : $params{$key},
 625                     ref($val) eq 'ARRAY' ? @{ $val } : $val
 626                 ];
 627
 628             } else {
 629                 $params{$key} = $val;
 630             }
 631         } else {
 632
 633             # If the param wasn't defined then we delete it.
 634             delete($params{$key});
 635         }
 636     }
 637
 638
 639     return \%params;
 640 }
 641
 642 =head2 $req->uri_with( { key => 'value' } );
 643
 644 Returns a rewritten URI object for the current request. Key/value pairs
 645 passed in will override existing parameters. You can remove an existing
 646 parameter by passing in an undef value. Unmodified pairs will be
 647 preserved.
 648
 649 You may also pass an optional second parameter that puts C<uri_with> into
 650 append mode:
 651
 652   $req->uri_with( { key => 'value' }, { mode => 'append' } );
 653
 654 See C<mangle_params> for an explanation of this behavior.
 655
 656 =cut
 657
 658 sub uri_with {
 659     my( $self, $args, $behavior) = @_;
 660
 661     carp( 'No arguments passed to uri_with()' ) unless $args;
 662
 663     my $append = 0;
 664     if((ref($behavior) eq 'HASH') && defined($behavior->{mode}) && ($behavior->{mode} eq 'append')) {
 665         $append = 1;
 666     }
 667
 668     my $params = $self->mangle_params($args, $append);
 669
 670     my $uri = $self->uri->clone;
 671     $uri->query_form($params);
 672
 673     return $uri;
 674 }
 675
 676 =head2 $req->user
 677
 678 Returns the currently logged in user. B<Highly deprecated>, do not call,
 679 this will be removed in version 5.81.
 680
 681 =head2 $req->remote_user
 682
 683 Returns the value of the C<REMOTE_USER> environment variable.
 684
 685 =head2 $req->user_agent
 686
 687 Shortcut to $req->headers->user_agent. Returns the user agent (browser)
 688 version string.
 689
 690 =head2 meta
 691
 692 Provided by Moose
 693
 694 =head1 AUTHORS
 695
 696 Catalyst Contributors, see Catalyst.pm
 697
 698 =head1 COPYRIGHT
 699
 700 This library is free software. You can redistribute it and/or modify
 701 it under the same terms as Perl itself.
 702
 703 =cut
 704
 705 __PACKAGE__->meta->make_immutable;
 706
 707 1;