lib/Catalyst/Request.pm

   1 package Catalyst::Request;
   2
   3 use strict;
   4 use base 'Class::Accessor::Fast';
   5
   6 use IO::Socket qw[AF_INET inet_aton];
   7
   8 __PACKAGE__->mk_accessors(
   9     qw/action address arguments base cookies headers match method
  10       protocol query_parameters secure snippets uri user/
  11 );
  12
  13 *args         = \&arguments;
  14 *body_params  = \&body_parameters;
  15 *input        = \&body;
  16 *params       = \&parameters;
  17 *query_params = \&query_parameters;
  18 *path_info    = \&path;
  19
  20 sub content_encoding { shift->headers->content_encoding(@_) }
  21 sub content_length   { shift->headers->content_length(@_) }
  22 sub content_type     { shift->headers->content_type(@_) }
  23 sub header           { shift->headers->header(@_) }
  24 sub referer          { shift->headers->referer(@_) }
  25 sub user_agent       { shift->headers->user_agent(@_) }
  26
  27 =head1 NAME
  28
  29 Catalyst::Request - Catalyst Request Class
  30
  31 =head1 SYNOPSIS
  32
  33
  34     $req = $c->request;
  35     $req->action;
  36     $req->address;
  37     $req->args;
  38     $req->arguments;
  39     $req->base;
  40     $req->body;
  41     $req->body_parameters;
  42     $req->content_encoding;
  43     $req->content_length;
  44     $req->content_type;
  45     $req->cookie;
  46     $req->cookies;
  47     $req->header;
  48     $req->headers;
  49     $req->hostname;
  50     $req->input;
  51     $req->match;
  52     $req->method;
  53     $req->param;
  54     $req->params;
  55     $req->parameters;
  56     $req->path;
  57     $req->protocol;
  58     $req->query_parameters;
  59     $req->read;
  60     $req->referer;
  61     $req->secure;
  62     $req->snippets;
  63     $req->upload;
  64     $req->uploads;
  65     $req->uri;
  66     $req->user;
  67     $req->user_agent;
  68
  69 See also L<Catalyst>.
  70
  71 =head1 DESCRIPTION
  72
  73 This is the Catalyst Request class, which provides a set of accessors to the
  74 request data.  The request object is prepared by the specialized Catalyst
  75 Engine module thus hiding the details of the particular engine implementation.
  76
  77
  78 =head1 METHODS
  79
  80 =over 4
  81
  82 =item $req->action
  83
  84 Contains the requested action.
  85
  86     print $c->request->action;
  87
  88 =item $req->address
  89
  90 Contains the remote address.
  91
  92     print $c->request->address
  93
  94 =item $req->args
  95
  96 Shortcut for arguments
  97
  98 =item $req->arguments
  99
 100 Returns a reference to an array containing the arguments.
 101
 102     print $c->request->arguments->[0];
 103
 104 =item $req->base
 105
 106 Contains the url base. This will always have a trailing slash.
 107
 108 =item $req->body
 109
 110 Contains the message body of the request unless Content-Type is
 111 C<application/x-www-form-urlencoded> or C<multipart/form-data>.
 112
 113     print $c->request->body
 114
 115 =cut
 116
 117 sub body {
 118     my ( $self, $body ) = @_;
 119     $self->{_context}->prepare_body;
 120     return $self->{_body}->body;
 121 }
 122
 123 =item $req->body_parameters
 124
 125 Returns a reference to a hash containing body parameters. Values can
 126 be either a scalar or an arrayref containing scalars.
 127
 128     print $c->request->body_parameters->{field};
 129     print $c->request->body_parameters->{field}->[0];
 130
 131 =item $req->body_params
 132
 133 An alias for body_parameters.
 134
 135 =cut
 136
 137 sub body_parameters {
 138     my ( $self, $params ) = @_;
 139     $self->{_context}->prepare_body;
 140     $self->{body_parameters} = $params if $params;
 141     return $self->{body_parameters};
 142 }
 143
 144 =item $req->content_encoding
 145
 146 Shortcut to $req->headers->content_encoding
 147
 148 =item $req->content_length
 149
 150 Shortcut to $req->headers->content_length
 151
 152 =item $req->content_type
 153
 154 Shortcut to $req->headers->content_type
 155
 156 =item $req->cookie
 157
 158 A convenient method to $req->cookies.
 159
 160     $cookie  = $c->request->cookie('name');
 161     @cookies = $c->request->cookie;
 162
 163 =cut
 164
 165 sub cookie {
 166     my $self = shift;
 167
 168     if ( @_ == 0 ) {
 169         return keys %{ $self->cookies };
 170     }
 171
 172     if ( @_ == 1 ) {
 173
 174         my $name = shift;
 175
 176         unless ( exists $self->cookies->{$name} ) {
 177             return undef;
 178         }
 179
 180         return $self->cookies->{$name};
 181     }
 182 }
 183
 184 =item $req->cookies
 185
 186 Returns a reference to a hash containing the cookies.
 187
 188     print $c->request->cookies->{mycookie}->value;
 189
 190 =item $req->header
 191
 192 Shortcut to $req->headers->header
 193
 194 =item $req->headers
 195
 196 Returns an L<HTTP::Headers> object containing the headers.
 197
 198     print $c->request->headers->header('X-Catalyst');
 199
 200 =item $req->hostname
 201
 202 Lookup the current users DNS hostname.
 203
 204     print $c->request->hostname
 205
 206 =cut
 207
 208 sub hostname {
 209     my $self = shift;
 210
 211     if ( @_ == 0 && not $self->{hostname} ) {
 212         $self->{hostname} =
 213           gethostbyaddr( inet_aton( $self->address ), AF_INET );
 214     }
 215
 216     if ( @_ == 1 ) {
 217         $self->{hostname} = shift;
 218     }
 219
 220     return $self->{hostname};
 221 }
 222
 223 =item $req->input
 224
 225 Shortcut for $req->body.
 226
 227 =item $req->match
 228
 229 This contains the matching part of a regexp action. Otherwise
 230 it returns the same as 'action'.
 231
 232     print $c->request->match;
 233
 234 =item $req->method
 235
 236 Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
 237
 238     print $c->request->method;
 239
 240 =item $req->param
 241
 242 Get request parameters with a CGI.pm-compatible param method. This
 243 is a method for accessing parameters in $c->req->parameters.
 244
 245     $value  = $c->request->param('foo');
 246     @values = $c->request->param('foo');
 247     @params = $c->request->param;
 248
 249 =cut
 250
 251 sub param {
 252     my $self = shift;
 253
 254     if ( @_ == 0 ) {
 255         return keys %{ $self->parameters };
 256     }
 257
 258     if ( @_ == 1 ) {
 259
 260         my $param = shift;
 261
 262         unless ( exists $self->parameters->{$param} ) {
 263             return wantarray ? () : undef;
 264         }
 265
 266         if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
 267             return (wantarray)
 268               ? @{ $self->parameters->{$param} }
 269               : $self->parameters->{$param}->[0];
 270         }
 271         else {
 272             return (wantarray)
 273               ? ( $self->parameters->{$param} )
 274               : $self->parameters->{$param};
 275         }
 276     }
 277
 278     if ( @_ > 1 ) {
 279
 280         while ( my ( $field, $value ) = splice( @_, 0, 2 ) ) {
 281
 282             next unless defined $field;
 283
 284             if ( exists $self->parameters->{$field} ) {
 285                 for ( $self->parameters->{$field} ) {
 286                     $_ = [$_] unless ref($_) eq "ARRAY";
 287                     push( @$_, $value );
 288                 }
 289             }
 290             else {
 291                 $self->parameters->{$field} = $value;
 292             }
 293         }
 294     }
 295 }
 296
 297 =item $req->params
 298
 299 Shortcut for $req->parameters.
 300
 301 =item $req->parameters
 302
 303 Returns a reference to a hash containing parameters. Values can
 304 be either a scalar or an arrayref containing scalars.
 305
 306     print $c->request->parameters->{field};
 307     print $c->request->parameters->{field}->[0];
 308
 309 =cut
 310
 311 sub parameters {
 312     my ( $self, $params ) = @_;
 313     $self->{_context}->prepare_body;
 314     $self->{parameters} = $params if $params;
 315     return $self->{parameters};
 316 }
 317
 318 =item $req->path
 319
 320 Contains the path.
 321
 322     print $c->request->path;
 323
 324 =item $req->path_info
 325
 326 alias for path, added for compability with L<CGI>
 327
 328 =cut
 329
 330 sub path {
 331     my ( $self, $params ) = @_;
 332
 333     if ($params) {
 334         $self->uri->path($params);
 335     }
 336
 337     my $path     = $self->uri->path;
 338     my $location = $self->base->path;
 339     $path =~ s/^(\Q$location\E)?//;
 340     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 341     $path =~ s/^\///;
 342
 343     return $path;
 344 }
 345
 346 =item $req->protocol
 347
 348 Contains the protocol.
 349
 350 =item $req->query_parameters
 351
 352 Returns a reference to a hash containing query parameters. Values can
 353 be either a scalar or an arrayref containing scalars.
 354
 355     print $c->request->query_parameters->{field};
 356     print $c->request->query_parameters->{field}->[0];
 357
 358 =item $req->read( [$maxlength] )
 359
 360 Read a chunk of data from the request body.  This method is designed to be
 361 used in a while loop, reading $maxlength bytes on every call.  $maxlength
 362 defaults to the size of the request if not specified.
 363
 364 You have to set MyApp->config->{parse_on_demand} to use this directly.
 365
 366 =cut
 367
 368 sub read { shift->{_context}->read(@_); }
 369
 370 =item $req->referer
 371
 372 Shortcut to $req->headers->referer. Referring page.
 373
 374 =item $req->secure
 375
 376 Contains a boolean denoting whether the communication is secure.
 377
 378 =item $req->snippets
 379
 380 Returns a reference to an array containing regex snippets.
 381
 382     my @snippets = @{ $c->request->snippets };
 383
 384 =item $req->upload
 385
 386 A convenient method to $req->uploads.
 387
 388     $upload  = $c->request->upload('field');
 389     @uploads = $c->request->upload('field');
 390     @fields  = $c->request->upload;
 391
 392     for my $upload ( $c->request->upload('field') ) {
 393         print $upload->filename;
 394     }
 395
 396 =cut
 397
 398 sub upload {
 399     my $self = shift;
 400
 401     if ( @_ == 0 ) {
 402         return keys %{ $self->uploads };
 403     }
 404
 405     if ( @_ == 1 ) {
 406
 407         my $upload = shift;
 408
 409         unless ( exists $self->uploads->{$upload} ) {
 410             return wantarray ? () : undef;
 411         }
 412
 413         if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
 414             return (wantarray)
 415               ? @{ $self->uploads->{$upload} }
 416               : $self->uploads->{$upload}->[0];
 417         }
 418         else {
 419             return (wantarray)
 420               ? ( $self->uploads->{$upload} )
 421               : $self->uploads->{$upload};
 422         }
 423     }
 424
 425     if ( @_ > 1 ) {
 426
 427         while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
 428
 429             if ( exists $self->uploads->{$field} ) {
 430                 for ( $self->uploads->{$field} ) {
 431                     $_ = [$_] unless ref($_) eq "ARRAY";
 432                     push( @$_, $upload );
 433                 }
 434             }
 435             else {
 436                 $self->uploads->{$field} = $upload;
 437             }
 438         }
 439     }
 440 }
 441
 442 =item $req->uploads
 443
 444 Returns a reference to a hash containing uploads. Values can be either a
 445 hashref or a arrayref containing C<Catalyst::Request::Upload> objects.
 446
 447     my $upload = $c->request->uploads->{field};
 448     my $upload = $c->request->uploads->{field}->[0];
 449
 450 =cut
 451
 452 sub uploads {
 453     my ( $self, $uploads ) = @_;
 454     $self->{_context}->prepare_body;
 455     $self->{uploads} = $uploads if $uploads;
 456     return $self->{uploads};
 457 }
 458
 459 =item $req->uri
 460
 461 Returns a URI object for the request.
 462
 463 =item $req->user
 464
 465 Contains the user name of user if authentication check was successful.
 466
 467 =item $req->user_agent
 468
 469 Shortcut to $req->headers->user_agent. User Agent version string.
 470
 471 =back
 472
 473 =head1 AUTHOR
 474
 475 Sebastian Riedel, C<sri@cpan.org>
 476 Marcus Ramberg, C<mramberg@cpan.org>
 477
 478 =head1 COPYRIGHT
 479
 480 This program is free software, you can redistribute it and/or modify
 481 it under the same terms as Perl itself.
 482
 483 =cut
 484
 485 1;