view release on metacpan or  search on metacpan

lib/Catalyst/Request.pm  view on Meta::CPAN

    # 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
        # input but didn't return the buffer to the start.
        $self->env->{'psgi.input'}->seek(0, 0);
    } else {
        $stream_buffer = Stream::Buffered->new($length);
    }

    # Check for definedness as you could read '0'
    while ( defined ( my $chunk = $self->read() ) ) {
        $self->prepare_body_chunk($chunk);
        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

    if ($stream_buffer) {
        $self->env->{'psgix.input.buffered'} = 1;
        $self->env->{'psgi.input'} = $stream_buffer->rewind;
    } else {
        $self->env->{'psgi.input'}->seek(0, 0); # Reset the buffer for downstream middleware or apps
    }

    # paranoia against wrong Content-Length header
    my $remaining = $length - $self->_read_position;
    if ( $remaining > 0 ) {
        Catalyst::Exception->throw("Wrong Content-Length value: $length" );
    }
}

sub prepare_body_chunk {
    my ( $self, $chunk ) = @_;

    $self->_body->add($chunk);
}

sub prepare_body_parameters {
    my ( $self, $c ) = @_;
    return $self->body_parameters if $self->has_body_parameters;
    $self->prepare_body if ! $self->_has_body;

    unless($self->_body) {
      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);
      }
    }

    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 {
    my ($self) = @_;

    my $env = $self->env;

    $self->address( $env->{REMOTE_ADDR} );
    $self->hostname( $env->{REMOTE_HOST} )
        if exists $env->{REMOTE_HOST};
    $self->protocol( $env->{SERVER_PROTOCOL} );
    $self->remote_user( $env->{REMOTE_USER} );
    $self->method( $env->{REQUEST_METHOD} );
    $self->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
}

# XXX - FIXME - method is here now, move this crap...
around parameters => sub {
    my ($orig, $self, $params) = @_;
    if ($params) {
        if ( !ref $params ) {
            $self->_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;
  },
);

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->prepare_body unless $self->_has_body;
  croak 'body is a reader' if scalar @_;