view release on metacpan or  search on metacpan

lib/Dancer2/Core/Request.pm  view on Meta::CPAN

    $_[0]->env->{'HTTP_X_FORWARDED_PROTO'}    ||
    $_[0]->env->{'HTTP_X_FORWARDED_PROTOCOL'} ||
    $_[0]->env->{'HTTP_FORWARDED_PROTO'}
}

sub scheme {
    my ($self) = @_;
    my $scheme = $self->is_behind_proxy
               ? $self->forwarded_protocol
               : '';

    return $scheme || $self->env->{'psgi.url_scheme'};
}

sub serializer { $_[0]->{'serializer'} }

sub data { $_[0]->{'data'} ||= $_[0]->deserialize() }

sub deserialize {
    my $self = shift;

    # don't attempt to deserialize if the form is 'multipart/form-data'
    if (
        $self->content_type 
        && $self->content_type =~ /^multipart\/form-data/i 
        ) {
        return;
    }


    my $serializer = $self->serializer
        or return;

    # The latest draft of the RFC does not forbid DELETE to have content,
    # rather the behaviour is undefined. Take the most lenient route and
    # deserialize any content on delete as well.
    return
      unless grep { $self->method eq $_ } qw/ PUT POST PATCH DELETE /;

    # try to deserialize
    my $body = $self->body;

    $body && length $body > 0
        or return;

    # Catch serializer fails - which is tricky as Role::Serializer
    # wraps the deserializaion in an eval and returns undef.
    # We want to generate a 500 error on serialization fail (Ref #794)
    # to achieve that, override the log callback so we can catch a signal
    # that it failed. This is messy (messes with serializer internals), but
    # "works".
    my $serializer_fail;
    my $serializer_log_cb = $serializer->log_cb;
    local $serializer->{log_cb} = sub {
        $serializer_fail = $_[1];
        $serializer_log_cb->(@_);
    };
    # work-around to resolve a chicken-and-egg issue when instantiating a
    # request object; the serializer needs that request object to deserialize
    # the body params.
    Scalar::Util::weaken( my $request = $self );
    $self->serializer->has_request || $self->serializer->set_request($request);
    my $data = $serializer->deserialize($body);
    die $serializer_fail if $serializer_fail;

    # Set _body_params directly rather than using the setter. Deserializiation
    # returns characters and skipping the decode op in the setter ensures
    # that numerical data "stays" numerical; decoding an SV that is an IV
    # converts that to a PVIV. Some serializers are picky (JSON)..
    $self->{_body_params} = $data;

    # Set body parameters (decoded HMV)
    $self->{'body_parameters'} =
        Hash::MultiValue->from_mixed( is_hashref($data) ? %$data : () );

    return $data;
}

sub uri        { $_[0]->request_uri }

sub is_head    { $_[0]->method eq 'HEAD' }
sub is_post    { $_[0]->method eq 'POST' }
sub is_get     { $_[0]->method eq 'GET' }
sub is_put     { $_[0]->method eq 'PUT' }
sub is_delete  { $_[0]->method eq 'DELETE' }
sub is_patch   { $_[0]->method eq 'PATCH' }
sub is_options { $_[0]->method eq 'OPTIONS' }

# public interface compat with CGI.pm objects
sub request_method { $_[0]->method }
sub input_handle { $_[0]->env->{'psgi.input'} }

sub to_string {
    my ($self) = @_;
    return "[#" . $self->id . "] " . $self->method . " " . $self->path;
}

sub base {
    my $self = shift;
    my $uri  = $self->_common_uri;

    return $uri->canonical;
}

sub _common_uri {
    my $self = shift;

    my $path   = $self->env->{SCRIPT_NAME};
    my $port   = $self->env->{SERVER_PORT};
    my $server = $self->env->{SERVER_NAME};
    my $host   = $self->host;
    my $scheme = $self->scheme;

    my $uri = URI->new;
    $uri->scheme($scheme);
    $uri->authority( $host || "$server:$port" );
    $uri->path( $path      || '/' );

    return $uri;
}