libfurl-perl 3.05-1 / usr / share / perl5 / Furl / Response.pm

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.
        #
        # <meta http-equiv="Content-Type" content="text/html; charset=EUC-JP"/>
        $self->content =~ m!<meta\s+http-equiv\s*=["']Content-Type["']\s+content\s*=\s*["']text/html;\s*charset=([^'">/]+)['"]\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__

=encoding utf-8

=for stopwords charsets

=head1 NAME

Furl::Response - Response object for Furl

=head1 SYNOPSIS

    my $res = Furl::Response->new($minor_version, $code, $message, $headers, $content);
    print $res->status, "\n";

=head1 DESCRIPTION

This is a HTTP response object in Furl.

=head1 CONSTRUCTOR

    my $res = Furl::Response->new($minor_version, $code, $msg, \%headers, $content);

=head1 INSTANCE METHODS

=over 4

=item $res->code

=item $res->status

Returns HTTP status code.

=item $res->message

Returns HTTP status message.

=item $res->headers

Returns instance of L<Furl::Headers>

=item $res->content

=item $res->body

Returns response body in scalar.

=item $res->decoded_content

This will return the content after any C<< Content-Encoding >> and charsets have been decoded. See L<< HTTP::Message >> for details

=item $res->request

Returns instance of L<Furl::Request> related this response.

=item $res->content_length

=item $res->content_type

=item $res->content_encoding

=item $res->header

Shorthand to access L<Furl::Headers>.

=item $res->protocol

    $res->protocol(); # => "HTTP/1.1"

Returns HTTP protocol in string.

=item $res->as_http_response

Make instance of L<HTTP::Response> from L<Furl::Response>.

=item $res->to_psgi()

Convert object to L<PSGI> response. It's very useful to make proxy.

=item $res->as_hashref()

Convert response object to HashRef.

Format is following:

    code: Int
    message: Str
    protocol: Str
    headers: ArrayRef[Str]
    content: Str

=item $res->is_success

Returns true if status code is 2xx.

=item $res->status_line

    $res->status_line() # => "200 OK"

Returns status line.

=item my $headers = $res->captured_req_headers() : Str

Captured request headers in raw string.

This method is only for debugging.

You can use this method if you are using C<< capture_request >> parameter is true.

=item my $content = $res->captured_req_content() : Str

Captured request content in raw string.

This method is only for debugging.

You can use this method if you are using C<< capture_request >> parameter is true.

=back