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
 335         # base must always have a trailing slash
 336         $params .= '/' unless ( $params =~ /\/$/ );
 337         $self->uri->path($params);
 338     }
 339
 340     my $path     = $self->uri->path;
 341     my $location = $self->base->path;
 342     $path =~ s/^(\Q$location\E)?//;
 343     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 344     $path =~ s/^\///;
 345
 346     return $path;
 347 }
 348
 349 =item $req->protocol
 350
 351 Contains the protocol.
 352
 353 =item $req->query_parameters
 354
 355 Returns a reference to a hash containing query parameters. Values can
 356 be either a scalar or an arrayref containing scalars.
 357
 358     print $c->request->query_parameters->{field};
 359     print $c->request->query_parameters->{field}->[0];
 360
 361 =item $req->read( [$maxlength] )
 362
 363 Read a chunk of data from the request body.  This method is designed to be
 364 used in a while loop, reading $maxlength bytes on every call.  $maxlength
 365 defaults to the size of the request if not specified.
 366
 367 You have to set MyApp->config->{parse_on_demand} to use this directly.
 368
 369 =cut
 370
 371 sub read { shift->{_context}->read(@_); }
 372
 373 =item $req->referer
 374
 375 Shortcut to $req->headers->referer. Referring page.
 376
 377 =item $req->secure
 378
 379 Contains a boolean denoting whether the communication is secure.
 380
 381 =item $req->snippets
 382
 383 Returns a reference to an array containing regex snippets.
 384
 385     my @snippets = @{ $c->request->snippets };
 386
 387 =item $req->upload
 388
 389 A convenient method to $req->uploads.
 390
 391     $upload  = $c->request->upload('field');
 392     @uploads = $c->request->upload('field');
 393     @fields  = $c->request->upload;
 394
 395     for my $upload ( $c->request->upload('field') ) {
 396         print $upload->filename;
 397     }
 398
 399 =cut
 400
 401 sub upload {
 402     my $self = shift;
 403
 404     if ( @_ == 0 ) {
 405         return keys %{ $self->uploads };
 406     }
 407
 408     if ( @_ == 1 ) {
 409
 410         my $upload = shift;
 411
 412         unless ( exists $self->uploads->{$upload} ) {
 413             return wantarray ? () : undef;
 414         }
 415
 416         if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
 417             return (wantarray)
 418               ? @{ $self->uploads->{$upload} }
 419               : $self->uploads->{$upload}->[0];
 420         }
 421         else {
 422             return (wantarray)
 423               ? ( $self->uploads->{$upload} )
 424               : $self->uploads->{$upload};
 425         }
 426     }
 427
 428     if ( @_ > 1 ) {
 429
 430         while ( my ( $field, $upload ) = splice( @_, 0, 2 ) ) {
 431
 432             if ( exists $self->uploads->{$field} ) {
 433                 for ( $self->uploads->{$field} ) {
 434                     $_ = [$_] unless ref($_) eq "ARRAY";
 435                     push( @$_, $upload );
 436                 }
 437             }
 438             else {
 439                 $self->uploads->{$field} = $upload;
 440             }
 441         }
 442     }
 443 }
 444
 445 =item $req->uploads
 446
 447 Returns a reference to a hash containing uploads. Values can be either a
 448 hashref or a arrayref containing C<Catalyst::Request::Upload> objects.
 449
 450     my $upload = $c->request->uploads->{field};
 451     my $upload = $c->request->uploads->{field}->[0];
 452
 453 =cut
 454
 455 sub uploads {
 456     my ( $self, $uploads ) = @_;
 457     $self->{_context}->prepare_body;
 458     $self->{uploads} = $uploads if $uploads;
 459     return $self->{uploads};
 460 }
 461
 462 =item $req->uri
 463
 464 Returns a URI object for the request.
 465
 466 =item $req->user
 467
 468 Contains the user name of user if authentication check was successful.
 469
 470 =item $req->user_agent
 471
 472 Shortcut to $req->headers->user_agent. User Agent version string.
 473
 474 =back
 475
 476 =head1 AUTHOR
 477
 478 Sebastian Riedel, C<sri@cpan.org>
 479 Marcus Ramberg, C<mramberg@cpan.org>
 480
 481 =head1 COPYRIGHT
 482
 483 This program is free software, you can redistribute it and/or modify
 484 it under the same terms as Perl itself.
 485
 486 =cut
 487
 488 1;