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