view release on metacpan or  search on metacpan

lib/Apache/AuthCookie/Params/CGI.pm  view on Meta::CPAN

sub params {
    my $self = shift;

    $self->{_params} ||= Hash::MultiValue->new(
        map $_->flatten, $self->query_params, $self->body_params
    );
}


sub query_params {
    my $self = shift;

    $self->{_query_params} ||= $self->_compute_pnote('request.query-params', sub {
        my $query = $self->request->args || '';

        $self->_decode( Hash::MultiValue->new(parse_urlencoded($query)) );
    });
}


sub body_params {
    my $self = shift;

    $self->{_body_params} ||= $self->_compute_pnote('request.body-params', sub {
        $self->_decode( Hash::MultiValue->from_mixed($self->_http_body->param) );
    });
}


sub content_length {
    my $self = shift;

    $self->{_content_length} ||=
        $self->request->headers_in->get('Content-Length') || 0;
}


sub content_type {
    my $self = shift;

    $self->{_content_type} ||=
        $self->request->headers_in->get('Content-Type') || '';
}

sub _http_body {
    my $self = shift;

    $self->{_http_body} ||= $self->_compute_pnote('request.body', sub {
        $self->_read_body;
    });
}

sub _read_body {
    my $self = shift;

    my $length = $self->content_length;

    my $body = HTTP::Body->new($self->content_type, $length);

    # HTTP::Body creates temp files for uploads. we need to tell it to clean up
    # those files when the body goes out of scope.
    $body->cleanup(1);

    my $r = $self->request;

    my $spin = 0;

    while ($length) {
        $r->read(my $buffer, ($length < 8192) ? $length : 8192);

        my $bytes_read = length $buffer;

        $length -= $bytes_read;
        $body->add($buffer);

        # guard against a signal interrupting read()
        if ($bytes_read == 0 && $spin++ > 2000) {
            Carp::croak "Bad Content-Length: maybe client disconnect? ($length bytes remaining)";
        }
    }

    return $body;
}

# utility method to fetch a pnote, or set it to a computed value if it has not
# already been set.
sub _compute_pnote {
    my ($self, $key, $code) = @_;

    my $r = $self->request;

    unless (defined $r->pnotes($key)) {
        $r->pnotes($key, $code->());
    }

    return $r->pnotes($key);
}

sub _decode {
    my ($self, $hash) = @_;

    my $r = $self->request;
    my $auth_name = $r->auth_name;

    if (my $encoding = $r->dir_config("${auth_name}Encoding")) {
        my $decoded = Hash::MultiValue->new;

        $hash->each(sub {
            my @dec = map { Encode::decode($encoding, $_) } @_;

            $decoded->add(@dec);
        });

        return $decoded;
    }
    else {
        return $hash;
    }
}