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