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