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


line stmt bran cond sub pod time code
1             package Furl::Response;
2 10     10   63 use strict;
  10         22  
  10         284  
3 10     10   61 use warnings;
  10         18  
  10         232  
4 10     10   44 use utf8;
  10         18  
  10         43  
5 10     10   209 use Furl::Headers;
  10         18  
  10         14371  
6              
7             sub new {
8 1     1 0 3 my ($class, $minor_version, $code, $message, $headers, $content) = @_;
9 1         10 bless {
10             minor_version => $minor_version,
11             code => $code,
12             message => $message,
13             headers => Furl::Headers->new($headers),
14             content => $content,
15             }, $class;
16             }
17              
18             # DO NOT CALL this method DIRECTLY.
19             sub set_request_info {
20 1     1 0 4 my ($self, $request_src, $captured_req_headers, $captured_req_content) = @_;
21 1         7 $self->{request_src} = $request_src;
22 1 50       4 if (defined $captured_req_headers) {
23 0         0 $self->{captured_req_headers} = $captured_req_headers;
24 0         0 $self->{captured_req_content} = $captured_req_content;
25             } else {
26 1         2 $self->{captured_req_headers} = undef;
27 1         4 $self->{captured_req_content} = undef;
28             }
29 1         2 return;
30             }
31              
32             sub captured_req_headers {
33 1     1 1 5 my $self = shift;
34 1 50       4 unless (exists $self->{captured_req_headers}) {
35 0         0 Carp::croak("You can't call cpatured_req_headers method without 'capture_request' options for Furl#new");
36             }
37 1         6 return $self->{captured_req_headers};
38             }
39              
40             sub captured_req_content {
41 1     1 1 3 my $self = shift;
42 1 50       6 unless (exists $self->{captured_req_content}) {
43 0         0 Carp::croak("You can't call cpatured_req_content method without 'capture_request' options for Furl#new");
44             }
45 1         4 return $self->{captured_req_content};
46             }
47              
48             # accessors
49 0     0 1   sub code { shift->{code} }
50 0     0 1   sub message { shift->{message} }
51 0     0 1   sub headers { shift->{headers} }
52 0     0 1   sub content { shift->{content} }
53             sub request {
54 0     0 1   my $self = shift;
55 0 0         if (!exists $self->{request}) {
56 0 0         if (!exists $self->{request_src}) {
57 0           Carp::croak("This request object does not have a request information");
58             }
59              
60             # my ($method, $uri, $headers, $content) = @_;
61             $self->{request} = Furl::Request->new(
62             $self->{request_src}->{method},
63             $self->{request_src}->{url},
64             $self->{request_src}->{headers},
65             $self->{request_src}->{content},
66 0           );
67             }
68 0           return $self->{request};
69             }
70              
71             # alias
72 0     0 1   sub status { shift->code() }
73 0     0 1   sub body { shift->content() }
74              
75             # shorthand
76 0     0 1   sub content_length { shift->headers->content_length() }
77 0     0 1   sub content_type { shift->headers->content_type() }
78 0     0 1   sub content_encoding { shift->headers->content_encoding() }
79 0     0 1   sub header { shift->headers->header(@_) }
80              
81 0     0 1   sub protocol { "HTTP/1." . $_[0]->{minor_version} }
82              
83             sub decoded_content {
84 0     0 1   my $self = shift;
85 0           my $cloned = $self->headers->clone;
86              
87             # 'HTTP::Message::decoded_content' tries to decompress content
88             # if response header contains 'Content-Encoding' field.
89             # However 'Furl' decompresses content by itself, 'Content-Encoding' field
90             # whose value is supported encoding type should be removed from response header.
91 0           my @removed = grep { ! m{\b(?:gzip|x-gzip|deflate)\b} } $cloned->header('content-encoding');
  0            
92 0           $cloned->header('content-encoding', \@removed);
93              
94 0           $self->_as_http_response_internal([ $cloned->flatten ])->decoded_content(@_);
95             }
96              
97             sub as_http_response {
98 0     0 1   my ($self) = @_;
99 0           return $self->_as_http_response_internal([ $self->headers->flatten ])
100             }
101              
102             sub _as_http_response_internal {
103 0     0     my ($self, $flatten_headers) = @_;
104              
105 0           require HTTP::Response;
106 0           my $res = HTTP::Response->new( $self->code, $self->message,
107             $flatten_headers,
108             $self->content );
109 0           $res->protocol($self->protocol);
110              
111 0 0 0       if ($self->{request_src} || $self->{request}) {
112 0 0         if (my $req = $self->request) {
113 0           $res->request($req->as_http_request);
114             }
115             }
116              
117 0           return $res;
118             }
119              
120             sub to_psgi {
121 0     0 1   my ($self) = @_;
122             return [
123 0           $self->code,
124             [$self->headers->flatten],
125             [$self->content]
126             ];
127             }
128              
129             sub as_string {
130 0     0 0   my ($self) = @_;
131 0           return join("",
132             $self->status_line . "\015\012",
133             $self->headers->as_string,
134             "\015\012",
135             $self->content,
136             );
137             }
138              
139             sub as_hashref {
140 0     0 1   my $self = shift;
141              
142             return +{
143 0           code => $self->code,
144             message => $self->message,
145             protocol => $self->protocol,
146             headers => [$self->headers->flatten],
147             content => $self->content,
148             };
149             }
150              
151 0     0 1   sub is_success { substr( $_[0]->code, 0, 1 ) eq '2' }
152 0     0 1   sub status_line { $_[0]->code . ' ' . $_[0]->message }
153              
154             sub charset {
155 0     0 0   my $self = shift;
156              
157 0 0         return $self->{__charset} if exists $self->{__charset};
158 0 0         if ($self->can('content_charset')){
159             # To suppress:
160             # Parsing of undecoded UTF-8 will give garbage when decoding entities
161 0     0     local $SIG{__WARN__} = sub {};
162 0           my $charset = $self->content_charset;
163 0           $self->{__charset} = $charset;
164 0           return $charset;
165             }
166              
167 0           my $content_type = $self->headers->header('Content-Type');
168 0 0         return unless $content_type;
169 0           $content_type =~ /charset=([A-Za-z0-9_\-]+)/io;
170 0   0       $self->{__charset} = $1 || undef;
171              
172             # Detect charset from HTML
173 0 0 0       unless (defined($self->{__charset}) && $self->content_type =~ m{text/html}) {
174             # I guess, this is not so perfect regexp. patches welcome.
175             #
176             #
177 0           $self->content =~ m!/]+)['"]\s*/?>!smi;
178 0           $self->{__charset} = $1;
179             }
180              
181 0           $self->{__charset};
182             }
183              
184             sub encoder {
185 0     0 0   require Encode;
186 0           my $self = shift;
187 0 0         return $self->{__encoder} if exists $self->{__encoder};
188 0 0         my $charset = $self->charset or return;
189 0           my $enc = Encode::find_encoding($charset);
190 0           $self->{__encoder} = $enc;
191             }
192              
193             sub encoding {
194 0 0   0 0   my $enc = shift->encoder or return;
195 0           $enc->name;
196             }
197              
198             1;
199             __END__