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