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