1 package HTTP
::AnyUA
::Backend
::Net
::Curl
::Easy
;
2 # ABSTRACT: A unified programming interface for Net::Curl::Easy
6 This module adds support for the HTTP client L<Net::Curl::Easy> to be used with the unified
7 programming interface provided by L<HTTP::AnyUA>.
12 * The C<redirects> field in the response is currently unsupported.
17 * L<HTTP::AnyUA::Backend>
24 our $VERSION = '9999.999'; # VERSION
26 use parent
'HTTP::AnyUA::Backend';
28 use HTTP
::AnyUA
::Util
;
34 my ($method, $url, $args) = @_;
39 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_HTTPGET
(), 0);
40 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_NOBODY
(), 0);
41 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_READFUNCTION
(), undef);
42 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_POSTFIELDS
(), undef);
43 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_POSTFIELDSIZE
(), 0);
45 if ($method eq 'GET') {
46 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_HTTPGET
(), 1);
48 elsif ($method eq 'HEAD') {
49 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_NOBODY
(), 1);
52 if (my $content = $args->{content
}) {
53 if (ref($content) eq 'CODE') {
55 for my $header (keys %{$args->{headers
} || {}}) {
56 if (lc($header) eq 'content-length') {
57 $content_length = $args->{headers
}{$header};
62 if ($content_length) {
64 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_READFUNCTION
(), sub {
69 $chunk = $content->();
73 my $part = substr($chunk, 0, $maxlen, '');
76 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_POSTFIELDSIZE
(), $content_length);
79 # if we don't know the length we have to just read it all in
80 $content = HTTP
::AnyUA
::Util
::coderef_content_to_string
($content);
83 if (ref($content) ne 'CODE') {
84 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_POSTFIELDS
(), $content);
85 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_POSTFIELDSIZE
(), length $content);
89 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_URL
(), $url);
90 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_CUSTOMREQUEST
(), $method);
94 for my $header (keys %{$args->{headers
} || {}}) {
95 my $value = $args->{headers
}{$header};
96 my @values = ref($value) eq 'ARRAY' ? @$value : $value;
98 push @headers, "${header}: $v";
101 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_HTTPHEADER
(), \
@headers) if @headers;
105 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_HEADERFUNCTION
(), sub {
108 my $size = length $data;
110 my %headers = _parse_header
($data);
112 if ($headers{Status
}) {
116 my $resp_headers = $hdrdata[-1];
118 for my $key (keys %headers) {
119 if (!$resp_headers->{$key}) {
120 $resp_headers->{$key} = $headers{$key};
123 if (ref($resp_headers->{$key}) ne 'ARRAY') {
124 $resp_headers->{$key} = [$resp_headers->{$key}];
126 push @{$resp_headers->{$key}}, $headers{$key};
135 my $data_cb = $args->{data_callback
};
137 Scalar
::Util
::weaken
($copy);
138 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_WRITEFUNCTION
(), sub {
142 my $size = length $data;
145 my $resp = $copy->_munge_response(undef, undef, [@hdrdata], $data_cb);
146 $data_cb->($data, $resp);
154 open(my $fileb, '>', \
$resp_body);
155 $ua->setopt(Net
::Curl
::Easy
::CURLOPT_WRITEDATA
(), $fileb);
157 eval { $ua->perform };
160 return $self->_munge_response($ret, $resp_body, [@hdrdata], $data_cb);
164 sub _munge_response
{
171 my %headers = %{pop @$hdrdata || {}};
173 my $code = delete $headers{Status
} || $self->ua->getinfo(Net
::Curl
::Easy
::CURLINFO_RESPONSE_CODE
()) || 599;
174 my $reason = delete $headers{Reason
};
175 my $url = $self->ua->getinfo(Net
::Curl
::Easy
::CURLINFO_EFFECTIVE_URL
());
178 success
=> 200 <= $code && $code <= 299,
182 headers
=> \
%headers,
185 my $version = delete $headers{HTTPVersion
} || _http_version
($self->ua->getinfo(Net
::Curl
::Easy
::CURLINFO_HTTP_VERSION
()));
186 $resp->{protocol
} = "HTTP/$version" if $version;
188 # We have the headers for the redirect chain in $hdrdata, but we don't have the contents, and we
189 # would also need to reconstruct the URLs.
192 my $err = $self->ua->strerror($error);
193 return HTTP
::AnyUA
::Util
::internal_exception
($err, $resp);
196 $resp->{content
} = $body if $body && !$data_cb;
201 # get the HTTP version according to the user agent object
204 return $version == Net
::Curl
::Easy
::CURL_HTTP_VERSION_1_0
() ? '1.0' :
205 $version == Net
::Curl
::Easy
::CURL_HTTP_VERSION_1_1
() ? '1.1' :
206 $version == Net
::Curl
::Easy
::CURL_HTTP_VERSION_2_0
() ? '2.0' : '';
209 # parse a header line (or status line) and return as key-value pairs
213 $data =~ s/[\x0A\x0D]*$//;
215 if ($data =~ m!^HTTP/([0-9.]+) [\x09\x20]+ (\d{3}) [\x09\x20]+ ([^\x0A\x0D]*)!x) {
223 my ($key, $val) = split(/:\s*/, $data, 2);
225 return (lc($key) => $val);
228 # no Net::Curl::Easy;