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