File Coverage

blib/lib/Furl/Response.pm

Criterion	Covered	Total	%
statement	26	94	27.6
branch	3	28	10.7
condition	0	8	0.0
subroutine	8	32	25.0
pod	20	26	76.9
total	57	188	30.3

package Furl::Response;
use strict;
use warnings;
use utf8;
use Furl::Headers;

sub new {
    my ($class, $minor_version, $code, $message, $headers, $content) = @_;
    bless {
        minor_version => $minor_version,
        code    => $code,
        message => $message,
        headers => Furl::Headers->new($headers),
        content => $content,
    }, $class;
}

# DO NOT CALL this method DIRECTLY.
sub set_request_info {
    my ($self, $request_src, $captured_req_headers, $captured_req_content) = @_;
    $self->{request_src} = $request_src;
    if (defined $captured_req_headers) {
        $self->{captured_req_headers} = $captured_req_headers;
        $self->{captured_req_content} = $captured_req_content;
    } else {
        $self->{captured_req_headers} = undef;
        $self->{captured_req_content} = undef;
    }
    return;
}

sub captured_req_headers {
    my $self = shift;
    unless (exists $self->{captured_req_headers}) {
        Carp::croak("You can't call cpatured_req_headers method without 'capture_request' options for Furl#new");
    }
    return $self->{captured_req_headers};
}

sub captured_req_content {
    my $self = shift;
    unless (exists $self->{captured_req_content}) {
        Carp::croak("You can't call cpatured_req_content method without 'capture_request' options for Furl#new");
    }
    return $self->{captured_req_content};
}

# accessors
sub code    { shift->{code} }
sub message { shift->{message} }
sub headers { shift->{headers} }
sub content { shift->{content} }
sub request {
    my $self = shift;
    if (!exists $self->{request}) {
        if (!exists $self->{request_src}) {
            Carp::croak("This request object does not have a request information");
        }

        # my ($method, $uri, $headers, $content) = @_;
        $self->{request} = Furl::Request->new(
            $self->{request_src}->{method},
            $self->{request_src}->{url},
            $self->{request_src}->{headers},
            $self->{request_src}->{content},
        );
    }
    return $self->{request};
}

# alias
sub status { shift->code() }
sub body   { shift->content() }

# shorthand
sub content_length   { shift->headers->content_length() }
sub content_type     { shift->headers->content_type() }
sub content_encoding { shift->headers->content_encoding() }
sub header           { shift->headers->header(@_) }

sub protocol { "HTTP/1." . $_[0]->{minor_version} }

sub decoded_content {
    my $self = shift;
    my $cloned = $self->headers->clone;

    # 'HTTP::Message::decoded_content' tries to decompress content
    # if response header contains 'Content-Encoding' field.
    # However 'Furl' decompresses content by itself, 'Content-Encoding' field
    # whose value is supported encoding type should be removed from response header.
    my @removed = grep { ! m{\b(?:gzip|x-gzip|deflate)\b} } $cloned->header('content-encoding');
    $cloned->header('content-encoding', \@removed);

    $self->_as_http_response_internal([ $cloned->flatten ])->decoded_content(@_);
}

sub as_http_response {
    my ($self) = @_;
    return $self->_as_http_response_internal([ $self->headers->flatten ])
}

sub _as_http_response_internal {
    my ($self, $flatten_headers) = @_;

    require HTTP::Response;
    my $res = HTTP::Response->new( $self->code, $self->message,
        $flatten_headers,
        $self->content );
    $res->protocol($self->protocol);

    if ($self->{request_src} || $self->{request}) {
        if (my $req = $self->request) {
            $res->request($req->as_http_request);
        }
    }

    return $res;
}

sub to_psgi {
    my ($self) = @_;
    return [
        $self->code,
        [$self->headers->flatten],
        [$self->content]
    ];
}

sub as_string {
    my ($self) = @_;
    return join("",
        $self->status_line . "\015\012",
        $self->headers->as_string,
        "\015\012",
        $self->content,
    );
}

sub as_hashref {
    my $self = shift;

    return +{
        code    => $self->code,
        message => $self->message,
        protocol => $self->protocol,
        headers => [$self->headers->flatten],
        content => $self->content,
    };
}

sub is_success { substr( $_[0]->code, 0, 1 ) eq '2' }
sub status_line { $_[0]->code . ' ' . $_[0]->message }

sub charset {
    my $self = shift;

    return $self->{__charset} if exists $self->{__charset};
    if ($self->can('content_charset')){
        # To suppress:
        # Parsing of undecoded UTF-8 will give garbage when decoding entities
        local $SIG{__WARN__} = sub {};
        my $charset = $self->content_charset;
        $self->{__charset} = $charset;
        return $charset;
    }

    my $content_type = $self->headers->header('Content-Type');
    return unless $content_type;
    $content_type =~ /charset=([A-Za-z0-9_\-]+)/io;
    $self->{__charset} = $1 || undef;

    # Detect charset from HTML
    unless (defined($self->{__charset}) && $self->content_type =~ m{text/html}) {
        # I guess, this is not so perfect regexp. patches welcome.
        #
        #
        $self->content =~ m!/]+)['"]\s*/?>!smi;
        $self->{__charset} = $1;
    }

    $self->{__charset};
}

sub encoder {
    require Encode;
    my $self = shift;
    return $self->{__encoder} if exists $self->{__encoder};
    my $charset = $self->charset or return;
    my $enc = Encode::find_encoding($charset);
    $self->{__encoder} = $enc;
}

sub encoding {
    my $enc = shift->encoder or return;
    $enc->name;
}

1;
__END__