X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FRequest.pm;h=afaa4144aeabecc004118c3006b4a706f8b61bb0;hp=b8caa11007aaa6be693042c5d8ff4578134b4dba;hb=536bee890cf24e0e4bcda7562e7b70cc03ca0620;hpb=3e7052548f826497e8b065fb08c64bce4be3810f diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm index b8caa11..afaa414 100644 --- a/lib/Catalyst/Request.pm +++ b/lib/Catalyst/Request.pm @@ -1,28 +1,142 @@ package Catalyst::Request; -use strict; -use base 'Class::Accessor::Fast'; - use IO::Socket qw[AF_INET inet_aton]; +use Carp; +use utf8; +use URI::http; +use URI::https; +use URI::QueryParam; +use HTTP::Headers; + +use Moose; + +use namespace::clean -except => 'meta'; + +with 'MooseX::Emulate::Class::Accessor::Fast'; + +has action => (is => 'rw'); +has address => (is => 'rw'); +has arguments => (is => 'rw', default => sub { [] }); +has cookies => (is => 'rw', default => sub { {} }); +has query_keywords => (is => 'rw'); +has match => (is => 'rw'); +has method => (is => 'rw'); +has protocol => (is => 'rw'); +has query_parameters => (is => 'rw', default => sub { {} }); +has secure => (is => 'rw', default => 0); +has captures => (is => 'rw', default => sub { [] }); +has uri => (is => 'rw', predicate => 'has_uri'); +has remote_user => (is => 'rw'); +has headers => ( + is => 'rw', + isa => 'HTTP::Headers', + handles => [qw(content_encoding content_length content_type header referer user_agent)], + default => sub { HTTP::Headers->new() }, + required => 1, + lazy => 1, +); + +has _context => ( + is => 'rw', + weak_ref => 1, + handles => ['read'], + clearer => '_clear_context', +); + +has body_parameters => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, +); + +has uploads => ( + is => 'rw', + required => 1, + default => sub { {} }, +); + +has parameters => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, +); + +# TODO: +# - Can we lose the before modifiers which just call prepare_body ? +# they are wasteful, slow us down and feel cluttery. -__PACKAGE__->mk_accessors( - qw/action address arguments cookies headers match method - protocol query_parameters secure snippets uri user/ +# Can we make _body an attribute, have the rest of +# these lazy build from there and kill all the direct hash access +# in Catalyst.pm and Engine.pm? + +before $_ => sub { + my ($self) = @_; + my $context = $self->_context || return; + $context->prepare_body; +} for qw/parameters body_parameters/; + +around parameters => sub { + my ($orig, $self, $params) = @_; + if ($params) { + if ( !ref $params ) { + $self->_context->log->warn( + "Attempt to retrieve '$params' with req->params(), " . + "you probably meant to call req->param('$params')" + ); + $params = undef; + } + return $self->$orig($params); + } + $self->$orig(); +}; + +has base => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my $self = shift; + return $self->path if $self->has_uri; + }, ); -*args = \&arguments; -*body_params = \&body_parameters; -*input = \&body; -*params = \¶meters; -*query_params = \&query_parameters; -*path_info = \&path; +has _body => ( + is => 'rw', clearer => '_clear_body', predicate => '_has_body', +); +# Eugh, ugly. Should just be able to rename accessor methods to 'body' +# and provide a custom reader.. +sub body { + my $self = shift; + $self->_context->prepare_body(); + $self->_body(@_) if scalar @_; + return blessed $self->_body ? $self->_body->body : $self->_body; +} + +has hostname => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my ($self) = @_; + gethostbyaddr( inet_aton( $self->address ), AF_INET ) || 'localhost' + }, +); -sub content_encoding { shift->headers->content_encoding(@_) } -sub content_length { shift->headers->content_length(@_) } -sub content_type { shift->headers->content_type(@_) } -sub header { shift->headers->header(@_) } -sub referer { shift->headers->referer(@_) } -sub user_agent { shift->headers->user_agent(@_) } +has _path => ( is => 'rw', predicate => '_has_path', clearer => '_clear_path' ); + +# XXX: Deprecated in docs ages ago (2006), deprecated with warning in 5.8000 due +# to confusion between Engines and Plugin::Authentication. Remove in 5.8100? +has user => (is => 'rw'); + +sub args { shift->arguments(@_) } +sub body_params { shift->body_parameters(@_) } +sub input { shift->body(@_) } +sub params { shift->parameters(@_) } +sub query_params { shift->query_parameters(@_) } +sub path_info { shift->path(@_) } +sub snippets { shift->captures(@_) } =head1 NAME @@ -47,6 +161,7 @@ Catalyst::Request - provides information about the current client request $req->headers; $req->hostname; $req->input; + $req->query_keywords; $req->match; $req->method; $req->param; @@ -58,14 +173,14 @@ Catalyst::Request - provides information about the current client request $req->read; $req->referer; $req->secure; - $req->snippets; + $req->captures; # previously knows as snippets $req->upload; $req->uploads; $req->uri; $req->user; $req->user_agent; -See also L. +See also L, L. =head1 DESCRIPTION @@ -75,17 +190,19 @@ thus hiding the details of the particular engine implementation. =head1 METHODS -=over 4 +=head2 $req->action + +[DEPRECATED] Returns the name of the requested action. -=item $req->action -Returns the requested action as a L object. +Use C<< $c->action >> instead (which returns a +L object). -=item $req->address +=head2 $req->address Returns the IP address of the client. -=item $req->arguments +=head2 $req->arguments Returns a reference to an array containing the arguments. @@ -93,57 +210,37 @@ Returns a reference to an array containing the arguments. For example, if your action was - package MyApp::C::Foo; - - sub moose : Local { - ... - } + package MyApp::C::Foo; + + sub moose : Local { + ... + } and the URI for the request was C, the string C would be the first and only argument. -=item $req->args +Arguments get automatically URI-unescaped for you. + +=head2 $req->args Shortcut for arguments. -=item $req->base +=head2 $req->base -Contains the URI base. This will always have a trailing slash. +Contains the URI base. This will always have a trailing slash. Note that the +URI scheme (eg., http vs. https) must be determined through heuristics; +depending on your server configuration, it may be incorrect. See $req->secure +for more info. If your application was queried with the URI C then C is C. -=cut - -sub base { - my ( $self, $base ) = @_; - - return $self->{base} unless $base; - - $self->{base} = $base; - - # set the value in path for backwards-compat - if ( $self->uri ) { - $self->path; - } - - return $self->{base}; -} - -=item $req->body +=head2 $req->body Returns the message body of the request, unless Content-Type is C or C. -=cut - -sub body { - my ( $self, $body ) = @_; - $self->{_context}->prepare_body; - return $self->{_body}->body; -} - -=item $req->body_parameters +=head2 $req->body_parameters Returns a reference to a hash containing body (POST) parameters. Values can be either a scalar or an arrayref containing scalars. @@ -152,33 +249,24 @@ be either a scalar or an arrayref containing scalars. print $c->request->body_parameters->{field}->[0]; These are the parameters from the POST part of the request, if any. - -=item $req->body_params -Shortcut for body_parameters. - -=cut +=head2 $req->body_params -sub body_parameters { - my ( $self, $params ) = @_; - $self->{_context}->prepare_body; - $self->{body_parameters} = $params if $params; - return $self->{body_parameters}; -} +Shortcut for body_parameters. -=item $req->content_encoding +=head2 $req->content_encoding Shortcut for $req->headers->content_encoding. -=item $req->content_length +=head2 $req->content_length Shortcut for $req->headers->content_length. -=item $req->content_type +=head2 $req->content_type Shortcut for $req->headers->content_type. -=item $req->cookie +=head2 $req->cookie A convenient method to access $req->cookies. @@ -206,7 +294,7 @@ sub cookie { } } -=item $req->cookies +=head2 $req->cookies Returns a reference to a hash containing the cookies. @@ -215,51 +303,44 @@ Returns a reference to a hash containing the cookies. The cookies in the hash are indexed by name, and the values are L objects. -=item $req->header +=head2 $req->header Shortcut for $req->headers->header. -=item $req->headers +=head2 $req->headers Returns an L object containing the headers for the current request. print $c->request->headers->header('X-Catalyst'); -=item $req->hostname +=head2 $req->hostname Returns the hostname of the client. - -=cut -sub hostname { - my $self = shift; +=head2 $req->input - if ( @_ == 0 && not $self->{hostname} ) { - $self->{hostname} = - gethostbyaddr( inet_aton( $self->address ), AF_INET ); - } - - if ( @_ == 1 ) { - $self->{hostname} = shift; - } +Alias for $req->body. - return $self->{hostname}; -} +=head2 $req->query_keywords -=item $req->input +Contains the keywords portion of a query string, when no '=' signs are +present. -Alias for $req->body. + http://localhost/path?some+keywords + + $c->request->query_keywords will contain 'some keywords' -=item $req->match +=head2 $req->match This contains the matching part of a Regex action. Otherwise -it returns the same as 'action'. +it returns the same as 'action', except for default actions, +which return an empty string. -=item $req->method +=head2 $req->method Contains the request method (C, C, C, etc). -=item $req->param +=head2 $req->param Returns GET and POST parameters with a CGI.pm-compatible param method. This is an alternative method for accessing parameters in $c->req->parameters. @@ -271,7 +352,7 @@ is an alternative method for accessing parameters in $c->req->parameters. Like L, and B earlier versions of Catalyst, passing multiple arguments to this method, like this: - $c->request->param( 'foo', 'bar', 'gorch', 'quxx' ); + $c->request->param( 'foo', 'bar', 'gorch', 'quxx' ); will set the parameter C to the multiple values C, C and C. Previously this would have added C as another value to C @@ -312,7 +393,7 @@ sub param { } } -=item $req->parameters +=head2 $req->parameters Returns a reference to a hash containing GET and POST parameters. Values can be either a scalar or an arrayref containing scalars. @@ -322,54 +403,48 @@ be either a scalar or an arrayref containing scalars. This is the combination of C and C. -=item $req->params +=head2 $req->params Shortcut for $req->parameters. -=cut - -sub parameters { - my ( $self, $params ) = @_; - $self->{_context}->prepare_body; - $self->{parameters} = $params if $params; - return $self->{parameters}; -} - -=item $req->path +=head2 $req->path Returns the path, i.e. the part of the URI after $req->base, for the current request. -=item $req->path_info +=head2 $req->path_info -Alias for path, added for compability with L. +Alias for path, added for compatibility with L. =cut sub path { - my ( $self, $params ) = @_; + my ( $self, @params ) = @_; - if ($params) { - $self->uri->path($params); + if (@params) { + $self->uri->path(@params); + $self->_clear_path; } - else { - return $self->{path} if $self->{path}; + elsif ( $self->_has_path ) { + return $self->_path; } + else { + my $path = $self->uri->path; + my $location = $self->base->path; + $path =~ s/^(\Q$location\E)?//; + $path =~ s/^\///; + $self->_path($path); - my $path = $self->uri->path; - my $location = $self->base->path; - $path =~ s/^(\Q$location\E)?//; - $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; - $path =~ s/^\///; - $self->{path} = $path; - - return $path; + return $path; + } } -=item $req->protocol +=head2 $req->protocol Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request. -=item $req->query_parameters +=head2 $req->query_parameters + +=head2 $req->query_params Returns a reference to a hash containing query string (GET) parameters. Values can be either a scalar or an arrayref containing scalars. @@ -377,7 +452,7 @@ be either a scalar or an arrayref containing scalars. print $c->request->query_parameters->{field}; print $c->request->query_parameters->{field}->[0]; -=item $req->read( [$maxlength] ) +=head2 $req->read( [$maxlength] ) Reads a chunk of data from the request body. This method is intended to be used in a while loop, reading $maxlength bytes on every call. $maxlength @@ -385,25 +460,32 @@ defaults to the size of the request if not specified. You have to set MyApp->config->{parse_on_demand} to use this directly. -=cut +=head2 $req->referer -sub read { shift->{_context}->read(@_); } +Shortcut for $req->headers->referer. Returns the referring page. -=item $req->referer +=head2 $req->secure -Shortcut for $req->headers->referer. Returns the referring page. +Returns true or false, indicating whether the connection is secure +(https). Note that the URI scheme (eg., http vs. https) must be determined +through heuristics, and therefore the reliablity of $req->secure will depend +on your server configuration. If you are serving secure pages on the standard +SSL port (443) and/or setting the HTTPS environment variable, $req->secure +should be valid. -=item $req->secure +=head2 $req->captures -Returns true or false, indicating whether the connection is secure (https). +Returns a reference to an array containing captured args from chained +actions or regex captures. -=item $req->snippets + my @captures = @{ $c->request->captures }; -Returns a reference to an array containing regex snippets. +=head2 $req->snippets - my @snippets = @{ $c->request->snippets }; +C used to be called snippets. This is still available for backwards +compatibility, but is considered deprecated. -=item $req->upload +=head2 $req->upload A convenient method to access $req->uploads. @@ -461,50 +543,80 @@ sub upload { } } -=item $req->uploads +=head2 $req->uploads Returns a reference to a hash containing uploads. Values can be either a -hashref or a arrayref containing L objects. +L object, or an arrayref of +L objects. my $upload = $c->request->uploads->{field}; my $upload = $c->request->uploads->{field}->[0]; +=head2 $req->uri + +Returns a URI object for the current request. Stringifies to the URI text. + +=head2 $req->uri_with( { key => 'value' } ); + +Returns a rewritten URI object for the current request. Key/value pairs +passed in will override existing parameters. You can remove an existing +parameter by passing in an undef value. Unmodified pairs will be +preserved. + =cut -sub uploads { - my ( $self, $uploads ) = @_; - $self->{_context}->prepare_body; - $self->{uploads} = $uploads if $uploads; - return $self->{uploads}; +sub uri_with { + my( $self, $args ) = @_; + + carp( 'No arguments passed to uri_with()' ) unless $args; + + foreach my $value ( values %$args ) { + next unless defined $value; + for ( ref $value eq 'ARRAY' ? @$value : $value ) { + $_ = "$_"; + utf8::encode( $_ ) if utf8::is_utf8($_); + } + }; + + my $uri = $self->uri->clone; + my %query = ( %{ $uri->query_form_hash }, %$args ); + + $uri->query_form( { + # remove undef values + map { defined $query{ $_ } ? ( $_ => $query{ $_ } ) : () } keys %query + } ); + return $uri; } -=item $req->uri +=head2 $req->user -Returns a URI object for the current request. Stringifies to the URI text. +Returns the currently logged in user. B, do not call, +this will be removed in version 5.81. -=item $req->user +=head2 $req->remote_user -Returns the currently logged in user. Deprecated. The method recommended for -newer plugins is $c->user. +Returns the value of the C environment variable. -=item $req->user_agent +=head2 $req->user_agent Shortcut to $req->headers->user_agent. Returns the user agent (browser) version string. -=back +=head2 meta -=head1 AUTHORS +Provided by Moose -Sebastian Riedel, C +=head1 AUTHORS -Marcus Ramberg, C +Catalyst Contributors, see Catalyst.pm =head1 COPYRIGHT -This program is free software, you can redistribute it and/or modify +This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1;