view release on metacpan or  search on metacpan

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

    my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
    my $uri   = $scheme . '://' . $host . '/' . $path . $query;

    $ctx->request->uri( (bless \$uri, $uri_class)->canonical );

    # set the base URI
    # base must end in a slash
    $base_path .= '/' unless $base_path =~ m{/$};

    my $base_uri = $scheme . '://' . $host . $base_path;

    $ctx->request->base( bless \$base_uri, $uri_class );

    return;
}

=head2 $self->prepare_request($c)

=head2 $self->prepare_query_parameters($c)

process the query string and extract query parameters.

=cut

sub prepare_query_parameters {
    my ($self, $c) = @_;
    my $env = $c->request->env;
    my $do_not_decode_query = $c->config->{do_not_decode_query};

    my $old_encoding;
    if(my $new = $c->config->{default_query_encoding}) {
      $old_encoding = $c->encoding;
      $c->encoding($new);
    }

    my $check = $c->config->{do_not_check_query_encoding} ? undef :$c->_encode_check;
    my $decoder = sub {
      my $str = shift;
      return $str if $do_not_decode_query;
      return $c->_handle_param_unicode_decoding($str, $check);
    };

    my $query_string = exists $env->{QUERY_STRING}
        ? $env->{QUERY_STRING}
        : '';

    $query_string =~ s/\A[&;]+//;

    my @unsplit_pairs = split /[&;]+/, $query_string;
    my $p = Hash::MultiValue->new();

    my $is_first_pair = 1;
    for my $pair (@unsplit_pairs) {
        my ($name, $value)
          = map { defined $_ ? $decoder->($self->unescape_uri($_)) : $_ }
            ( split /=/, $pair, 2 )[0,1]; # slice forces two elements

        if ($is_first_pair) {
            # If the first pair has no equal sign, then it means the isindex
            # flag is set.
            $c->request->query_keywords($name) unless defined $value;

            $is_first_pair = 0;
        }

        $p->add( $name => $value );
    }


    $c->encoding($old_encoding) if $old_encoding;
    $c->request->query_parameters( $c->request->_use_hash_multivalue ? $p : $p->mixed );
}

=head2 $self->prepare_read($c)

Prepare to read by initializing the Content-Length from headers.

=cut

sub prepare_read {
    my ( $self, $c ) = @_;

    # Initialize the amount of data we think we need to read
    $c->request->_read_length;
}

=head2 $self->prepare_request(@arguments)

Populate the context object from the request object.

=cut

sub prepare_request {
    my ($self, $ctx, %args) = @_;
    $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv');
    $ctx->request->_set_env($args{env});
    $self->_set_env($args{env}); # Nasty back compat!
    $ctx->response->_set_response_cb($args{response_cb});
}

=head2 $self->prepare_uploads($c)

=cut

sub prepare_uploads {
    my ( $self, $c ) = @_;

    my $request = $c->request;
    return unless $request->_body;

    my $enc = $c->encoding;
    my $uploads = $request->_body->upload;
    my $parameters = $request->parameters;
    foreach my $name (keys %$uploads) {
        my $files = $uploads->{$name};
        $name = $c->_handle_unicode_decoding($name) if $enc;
        my @uploads;
        for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
            my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
            my $filename = $upload->{filename};
            $filename = $c->_handle_unicode_decoding($filename) if $enc;