view release on metacpan or  search on metacpan

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

        $path =~ s{^/+}{};
        $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
        $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
    }
    else {
        my $req_uri = $env->{REQUEST_URI};
        $req_uri =~ s/\?.*$//;
        $path = $req_uri;
        $path =~ s{^/+}{};
    }

    # Using URI directly is way too slow, so we construct the URLs manually
    my $uri_class = "URI::$scheme";

    # HTTP_HOST will include the port even if it's 80/443
    $host =~ s/:(?:80|443)$//;

    if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
        $host .= ":$port";
    }

    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;

            my $u = Catalyst::Request::Upload->new
              (
               size => $upload->{size},
               type => scalar $headers->content_type,
               charset => scalar $headers->content_type_charset,
               headers => $headers,
               tempname => $upload->{tempname},
               filename => $filename,
              );
            push @uploads, $u;
        }
        $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];

        # support access to the filename as a normal param
        my @filenames = map { $_->{filename} } @uploads;
        # append, if there's already params with this name
        if (exists $parameters->{$name}) {
            if (ref $parameters->{$name} eq 'ARRAY') {
                push @{ $parameters->{$name} }, @filenames;
            }
            else {
                $parameters->{$name} = [ $parameters->{$name}, @filenames ];
            }
        }
        else {
            $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
        }
    }
}

=head2 $self->write($c, $buffer)

Writes the buffer to the client.

=cut

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

    $c->response->write($buffer);
}

=head2 $self->unencoded_write($c, $buffer)

Writes the buffer to the client without encoding. Necessary for
already encoded buffers. Used when a $c->write has been done
followed by $c->res->body.

=cut

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

    $c->response->unencoded_write($buffer);
}

=head2 $self->read($c, [$maxlength])

Reads from the input stream by calling C<< $self->read_chunk >>.