X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FRequest.pm;h=643a2984463039f1802b8b56d6ec8bbfc6b27169;hb=139b894c380e870c0b25ea20749cc6f689d93fa0;hp=dfec6d09380b57157305c7b9c96d75ad2530f5fe;hpb=e5ecd5bc38bac3e2fcfaf643ea2a4c6ab46d7e57;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm index dfec6d0..643a298 100644 --- a/lib/Catalyst/Request.pm +++ b/lib/Catalyst/Request.pm @@ -6,57 +6,56 @@ use utf8; use URI::http; use URI::https; use URI::QueryParam; +use HTTP::Headers; use Moose; -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'); +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'); -has user => (is => 'rw'); -has headers => ( +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 { {} }, + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, ); -before body_parameters => sub { - my ($self) = @_; - $self->_context->prepare_body(); -}; - has uploads => ( - is => 'rw', - required => 1, - lazy => 1, - default => sub { {} }, + is => 'rw', + required => 1, + default => sub { {} }, ); -before uploads => sub { - my ($self) = @_; - $self->_context->prepare_body; -}; - has parameters => ( is => 'rw', required => 1, @@ -64,38 +63,56 @@ has parameters => ( default => sub { {} }, ); -before parameters => sub { - my ($self, $params) = @_; - $self->_context->prepare_body(); - if ( $params && !ref $params ) { - $self->_context->log->warn( - "Attempt to retrieve '$params' with req->params(), " . - "you probably meant to call req->param('$params')" ); - $params = undef; - } +# TODO: +# - Can we lose the before modifiers which just call prepare_body ? +# they are wasteful, slow us down and feel cluttery. + +# 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 { + is => 'rw', + required => 1, + lazy => 1, + default => sub { my $self = shift; - if( $self->uri ){ - return $self->path; - } + return $self->path if $self->has_uri; }, ); -has body => ( - is => 'rw' +has _body => ( + is => 'rw', clearer => '_clear_body', predicate => '_has_body', ); - -before body => sub { - my ($self) = @_; +# 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', @@ -103,11 +120,15 @@ has hostname => ( lazy => 1, default => sub { my ($self) = @_; - gethostbyaddr( inet_aton( $self->address ), AF_INET ) + gethostbyaddr( inet_aton( $self->address ), AF_INET ) || 'localhost' }, ); -no Moose; +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(@_) } @@ -198,13 +219,18 @@ For example, if your action was and the URI for the request was C, the string C would be the first and only argument. +Arguments get automatically URI-unescaped for you. + =head2 $req->args Shortcut for arguments. =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. @@ -333,6 +359,21 @@ C. Previously this would have added C as another value to C (creating it if it didn't exist before), and C as another value for C. +B this is considered a legacy interface and care should be taken when +using it. C<< scalar $c->req->param( 'foo' ) >> will return only the first +C param even if multiple are present; C<< $c->req->param( 'foo' ) >> will +return a list of as many are present, which can have unexpected consequences +when writing code of the form: + + $foo->bar( + a => 'b', + baz => $c->req->param( 'baz' ), + ); + +If multiple C parameters are provided this code might corrupt data or +cause a hash initialization error. For a more straightforward interface see +C<< $c->req->parameters >>. + =cut sub param { @@ -387,7 +428,7 @@ Returns the path, i.e. the part of the URI after $req->base, for the current req =head2 $req->path_info -Alias for path, added for compability with L. +Alias for path, added for compatibility with L. =cut @@ -396,17 +437,17 @@ sub path { if (@params) { $self->uri->path(@params); - undef $self->{path}; + $self->_clear_path; } - elsif ( defined( my $path = $self->{path} ) ) { - return $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; + $self->_path($path); return $path; } @@ -432,11 +473,7 @@ 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 defaults to the size of the request if not specified. -You have to set MyApp->config->{parse_on_demand} to use this directly. - -=cut - -sub read { shift->_context->read(@_); } +You have to set MyApp->config(parse_on_demand => 1) to use this directly. =head2 $req->referer @@ -444,17 +481,23 @@ Shortcut for $req->headers->referer. Returns the referring page. =head2 $req->secure -Returns true or false, indicating whether the connection is secure (https). +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. =head2 $req->captures -Returns a reference to an array containing regex captures. +Returns a reference to an array containing captured args from chained +actions or regex captures. my @captures = @{ $c->request->captures }; =head2 $req->snippets -C used to be called snippets. This is still available for backwoards +C used to be called snippets. This is still available for backwards compatibility, but is considered deprecated. =head2 $req->upload @@ -528,20 +571,37 @@ L objects. Returns a URI object for the current request. Stringifies to the URI text. -=head2 $req->uri_with( { key => 'value' } ); +=head2 $req->mangle_params( { key => 'value' }, $appendmode); -Returns a rewritten URI object for the current request. Key/value pairs -passed in will override existing parameters. Unmodified pairs will be -preserved. +Returns a hashref of parameters stemming from the current request's params, +plus the ones supplied. Keys for which no current param exists will be +added, keys with undefined values will be removed and keys with existing +params will be replaced. Note that you can supply a true value as the final +argument to change behavior with regards to existing parameters, appending +values rather than replacing them. + +A quick example: + + # URI query params foo=1 + my $hashref = $req->mangle_params({ foo => 2 }); + # Result is query params of foo=2 + +versus append mode: + + # URI query params foo=1 + my $hashref = $req->mangle_params({ foo => 2 }, 1); + # Result is query params of foo=1&foo=2 + +This is the code behind C. =cut -sub uri_with { - my( $self, $args ) = @_; +sub mangle_params { + my ($self, $args, $append) = @_; - carp( 'No arguments passed to uri_with()' ) unless $args; + carp('No arguments passed to mangle_params()') unless $args; - for my $value ( values %$args ) { + foreach my $value ( values %$args ) { next unless defined $value; for ( ref $value eq 'ARRAY' ? @$value : $value ) { $_ = "$_"; @@ -549,19 +609,77 @@ sub uri_with { } }; + my %params = %{ $self->uri->query_form_hash }; + foreach my $key (keys %{ $args }) { + my $val = $args->{$key}; + if(defined($val)) { + + if($append && exists($params{$key})) { + + # This little bit of heaven handles appending a new value onto + # an existing one regardless if the existing value is an array + # or not, and regardless if the new value is an array or not + $params{$key} = [ + ref($params{$key}) eq 'ARRAY' ? @{ $params{$key} } : $params{$key}, + ref($val) eq 'ARRAY' ? @{ $val } : $val + ]; + + } else { + $params{$key} = $val; + } + } else { + + # If the param wasn't defined then we delete it. + delete($params{$key}); + } + } + + + return \%params; +} + +=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. + +You may also pass an optional second parameter that puts C into +append mode: + + $req->uri_with( { key => 'value' }, { mode => 'append' } ); + +See C for an explanation of this behavior. + +=cut + +sub uri_with { + my( $self, $args, $behavior) = @_; + + carp( 'No arguments passed to uri_with()' ) unless $args; + + my $append = 0; + if((ref($behavior) eq 'HASH') && defined($behavior->{mode}) && ($behavior->{mode} eq 'append')) { + $append = 1; + } + + my $params = $self->mangle_params($args, $append); + my $uri = $self->uri->clone; + $uri->query_form($params); - $uri->query_form( { - %{ $uri->query_form_hash }, - %$args - } ); return $uri; } =head2 $req->user -Returns the currently logged in user. Deprecated. The method recommended for -newer plugins is $c->user. +Returns the currently logged in user. B, do not call, +this will be removed in version 5.81. + +=head2 $req->remote_user + +Returns the value of the C environment variable. =head2 $req->user_agent @@ -574,13 +692,11 @@ Provided by Moose =head1 AUTHORS -Sebastian Riedel, C - -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