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=e937fb193cf09894657850ea0a2dc51e14283289;hp=671dd51e4368360260818c7a7add45624329ef27;hb=3b1178b01f1d71618f6a52357ec91ab40e2fc5e3;hpb=b94f8e72c1c8e8348efc0eb96660dd977a838ea7 diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm index 671dd51..e937fb1 100644 --- a/lib/Catalyst/Request.pm +++ b/lib/Catalyst/Request.pm @@ -1,6 +1,6 @@ package Catalyst::Request; -use IO::Socket qw[AF_INET inet_aton]; +use Socket qw( getaddrinfo getnameinfo AI_NUMERICHOST NI_NAMEREQD NIx_NOSERV ); use Carp; use utf8; use URI::http; @@ -10,7 +10,9 @@ use HTTP::Headers; use Stream::Buffered; use Hash::MultiValue; use Scalar::Util; +use HTTP::Body; use Catalyst::Exception; +use Catalyst::Request::PartData; use Moose; use namespace::clean -except => 'meta'; @@ -121,7 +123,7 @@ sub _build_body_data { # Not sure if these returns should not be exceptions... my $content_type = $self->content_type || return; - return unless ($self->method eq 'POST' || $self->method eq 'PUT'); + return unless ($self->method eq 'POST' || $self->method eq 'PUT' || $self->method eq 'PATCH'); my ($match) = grep { $content_type =~/$_/i } keys(%{$self->data_handlers}); @@ -130,14 +132,17 @@ sub _build_body_data { my $fh = $self->body; local $_ = $fh; return $self->data_handlers->{$match}->($fh, $self); - } else { - Catalyst::Exception->throw("$content_type is does not have an available data handler"); + } else { + Catalyst::Exception->throw( + sprintf '%s does not have an available data handler. Valid data_handlers are %s.', + $content_type, join ', ', sort keys %{$self->data_handlers} + ); } } has _use_hash_multivalue => ( - is=>'ro', - required=>1, + is=>'ro', + required=>1, default=> sub {0}); # Amount of data to read from input on each pass @@ -178,6 +183,7 @@ has body_parameters => ( is => 'rw', required => 1, lazy => 1, + predicate => 'has_body_parameters', builder => 'prepare_body_parameters', ); @@ -245,7 +251,7 @@ sub prepare_body { my ( $self ) = @_; # If previously applied middleware created the HTTP::Body object, then we - # just use that one. + # just use that one. if(my $plack_body = $self->_has_env ? $self->env->{'plack.request.http.body'} : undef) { $self->_body($plack_body); @@ -277,7 +283,7 @@ sub prepare_body { # Ok if we get this far, we have to read psgi.input into the new body # object. Lets play nice with any plack app or other downstream, so # we create a buffer unless one exists. - + my $stream_buffer; if ($self->env->{'psgix.input.buffered'}) { # Be paranoid about previous psgi middleware or apps that read the @@ -290,7 +296,10 @@ sub prepare_body { # Check for definedness as you could read '0' while ( defined ( my $chunk = $self->read() ) ) { $self->prepare_body_chunk($chunk); - $stream_buffer->print($chunk) if $stream_buffer; + next unless $stream_buffer; + + $stream_buffer->print($chunk) + || die sprintf "Failed to write %d bytes to psgi.input file: $!", length( $chunk ); } # Ok, we read the body. Lets play nice for any PSGI app down the pipe @@ -316,17 +325,60 @@ sub prepare_body_chunk { } sub prepare_body_parameters { - my ( $self ) = @_; - + my ( $self, $c ) = @_; + return $self->body_parameters if $self->has_body_parameters; $self->prepare_body if ! $self->_has_body; unless($self->_body) { - return $self->_use_hash_multivalue ? Hash::MultiValue->new : {}; + my $return = $self->_use_hash_multivalue ? Hash::MultiValue->new : {}; + $self->body_parameters($return); + return $return; + } + + my $params; + my %part_data = %{$self->_body->part_data}; + if(scalar %part_data && !$c->config->{skip_complex_post_part_handling}) { + foreach my $key (keys %part_data) { + my $proto_value = $part_data{$key}; + my ($val, @extra) = (ref($proto_value)||'') eq 'ARRAY' ? @$proto_value : ($proto_value); + + $key = $c->_handle_param_unicode_decoding($key) + if ($c and $c->encoding and !$c->config->{skip_body_param_unicode_decoding}); + + if(@extra) { + $params->{$key} = [map { Catalyst::Request::PartData->build_from_part_data($c, $_) } ($val,@extra)]; + } else { + $params->{$key} = Catalyst::Request::PartData->build_from_part_data($c, $val); + } + } + } else { + $params = $self->_body->param; + + # If we have an encoding configured (like UTF-8) in general we expect a client + # to POST with the encoding we fufilled the request in. Otherwise don't do any + # encoding (good change wide chars could be in HTML entity style llike the old + # days -JNAP + + # so, now that HTTP::Body prepared the body params, we gotta 'walk' the structure + # and do any needed decoding. + + # This only does something if the encoding is set via the encoding param. Remember + # this is assuming the client is not bad and responds with what you provided. In + # general you can just use utf8 and get away with it. + # + # I need to see if $c is here since this also doubles as a builder for the object :( + + if($c and $c->encoding and !$c->config->{skip_body_param_unicode_decoding}) { + $params = $c->_handle_unicode_decoding($params); + } } - return $self->_use_hash_multivalue ? - Hash::MultiValue->from_mixed($self->_body->param) : - $self->_body->param; + my $return = $self->_use_hash_multivalue ? + Hash::MultiValue->from_mixed($params) : + $params; + + $self->body_parameters($return) unless $self->has_body_parameters; + return $return; } sub prepare_connection { @@ -387,7 +439,21 @@ has hostname => ( lazy => 1, default => sub { my ($self) = @_; - gethostbyaddr( inet_aton( $self->address ), AF_INET ) || $self->address + my ( $err, $sockaddr ) = getaddrinfo( + $self->address, + # no service + '', + { flags => AI_NUMERICHOST } + ); + return $self->address + if $err; + ( $err, my $hostname ) = getnameinfo( + $sockaddr->{addr}, + NI_NAMEREQD, + # we are only interested in the hostname, not the servicename + NIx_NOSERV + ); + return $err ? $self->address : $hostname; }, ); @@ -510,7 +576,7 @@ If the POST is malformed in some way (such as undefined or not content that matches the content-type) we raise a L with the error text as the message. -If the POSTed content type does not match an availabled data handler, this +If the POSTed content type does not match an available data handler, this will also raise an exception. =head2 $req->body_parameters @@ -523,6 +589,16 @@ be either a scalar or an arrayref containing scalars. These are the parameters from the POST part of the request, if any. +B If your POST is multipart, but contains non file upload parts (such +as an line part with an alternative encoding or content type) we do our best to +try and figure out how the value should be presented. If there's a specified character +set we will use that to decode rather than the default encoding set by the application. +However if there are complex headers and we cannot determine +the correct way to extra a meaningful value from the upload, in this case any +part like this will be represented as an instance of L. + +Patches and review of this part of the code welcomed. + =head2 $req->body_params Shortcut for body_parameters. @@ -648,17 +724,21 @@ cause a hash initialization error. For a more straightforward interface see C<< $c->req->parameters >>. B Interfaces like this, which are based on L and the C method -are now known to cause demonstrated exploits. It is highly recommended that you -avoid using this method, and migrate existing code away from it. Here's the +are known to cause demonstrated exploits. It is highly recommended that you +avoid using this method, and migrate existing code away from it. Here's a whitepaper of the exploit: L +B Further discussion on IRC indicate that the L core team from 'back then' +were well aware of this hack and this is the main reason we added the new approach to +getting parameters in the first place. + Basically this is an exploit that takes advantage of how L<\param> will do one thing in scalar context and another thing in list context. This is combined with how Perl chooses to deal with duplicate keys in a hash definition by overwriting the value of existing keys with a new value if the same key shows up again. Generally you will be -vulnerale to this exploit if you are using this method in a direct assignment in a +vulnerable to this exploit if you are using this method in a direct assignment in a hash, such as with a L create statement. For example, if you have parameters like: @@ -708,7 +788,7 @@ sub param { # If anything in @_ is undef, carp about that, and remove it from # the list; - + my @params = grep { defined($_) ? 1 : do {carp "You called ->params with an undefined value"; 0} } @_; if ( @params == 1 ) { @@ -938,7 +1018,7 @@ sub mangle_params { next unless defined $value; for ( ref $value eq 'ARRAY' ? @$value : $value ) { $_ = "$_"; - utf8::encode( $_ ) if utf8::is_utf8($_); + # utf8::encode($_); } }; @@ -1059,7 +1139,7 @@ If parameters have already been set will clear the parameters and build them aga =head2 $self->env -Access to the raw PSGI env. +Access to the raw PSGI env. =head2 meta