Dogcows Code - chaz/p5-HTTP-AnyUA/blob - lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm

   1 package HTTP::AnyUA::Backend::Net::Curl::Easy;
   2 # ABSTRACT: A unified programming interface for Net::Curl::Easy
   3
   4 =head1 DESCRIPTION
   5
   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>.
   8
   9 =head1 CAVEATS
  10
  11 =for :list
  12 * The C<redirects> field in the response is currently unsupported.
  13
  14 =head1 SEE ALSO
  15
  16 =for :list
  17 * L<HTTP::AnyUA::Backend>
  18
  19 =cut
  20
  21 use warnings;
  22 use strict;
  23
  24 our $VERSION = '9999.999'; # VERSION
  25
  26 use parent 'HTTP::AnyUA::Backend';
  27
  28 use HTTP::AnyUA::Util;
  29 use Scalar::Util;
  30
  31
  32 sub request {
  33     my $self = shift;
  34     my ($method, $url, $args) = @_;
  35
  36     my $ua = $self->ua;
  37
  38     # reset
  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);
  44
  45     if ($method eq 'GET') {
  46         $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(), 1);
  47     }
  48     elsif ($method eq 'HEAD') {
  49         $ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(), 1);
  50     }
  51
  52     if (my $content = $args->{content}) {
  53         if (ref($content) eq 'CODE') {
  54             my $content_length;
  55             for my $header (keys %{$args->{headers} || {}}) {
  56                 if (lc($header) eq 'content-length') {
  57                     $content_length = $args->{headers}{$header};
  58                     last;
  59                 }
  60             }
  61
  62             if ($content_length) {
  63                 my $chunk;
  64                 $ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(), sub {
  65                     my $ua      = shift;
  66                     my $maxlen  = shift;
  67
  68                     if (!$chunk) {
  69                         $chunk = $content->();
  70                         return 0 if !$chunk;
  71                     }
  72
  73                     my $part = substr($chunk, 0, $maxlen, '');
  74                     return \$part;
  75                 });
  76                 $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), $content_length);
  77             }
  78             else {
  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);
  81             }
  82         }
  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);
  86         }
  87     }
  88
  89     $ua->setopt(Net::Curl::Easy::CURLOPT_URL(), $url);
  90     $ua->setopt(Net::Curl::Easy::CURLOPT_CUSTOMREQUEST(), $method);
  91
  92     # munge headers
  93     my @headers;
  94     for my $header (keys %{$args->{headers} || {}}) {
  95         my $value  = $args->{headers}{$header};
  96         my @values = ref($value) eq 'ARRAY' ? @$value : $value;
  97         for my $v (@values) {
  98             push @headers, "${header}: $v";
  99         }
 100     }
 101     $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPHEADER(), \@headers) if @headers;
 102
 103     my @hdrdata;
 104
 105     $ua->setopt(Net::Curl::Easy::CURLOPT_HEADERFUNCTION(), sub {
 106         my $ua      = shift;
 107         my $data    = shift;
 108         my $size    = length $data;
 109
 110         my %headers = _parse_header($data);
 111
 112         if ($headers{Status}) {
 113             push @hdrdata, {};
 114         }
 115
 116         my $resp_headers = $hdrdata[-1];
 117
 118         for my $key (keys %headers) {
 119             if (!$resp_headers->{$key}) {
 120                 $resp_headers->{$key} =  $headers{$key};
 121             }
 122             else {
 123                 if (ref($resp_headers->{$key}) ne 'ARRAY') {
 124                     $resp_headers->{$key} = [$resp_headers->{$key}];
 125                 }
 126                 push @{$resp_headers->{$key}}, $headers{$key};
 127             }
 128         }
 129
 130         return $size;
 131     });
 132
 133     my $resp_body = '';
 134
 135     my $data_cb = $args->{data_callback};
 136     my $copy = $self;
 137     Scalar::Util::weaken($copy);
 138     $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEFUNCTION(), sub {
 139         my $ua      = shift;
 140         my $data    = shift;
 141         my $fh      = shift;
 142         my $size    = length $data;
 143
 144         if ($data_cb) {
 145             my $resp = $copy->_munge_response(undef, undef, [@hdrdata], $data_cb);
 146             $data_cb->($data, $resp);
 147         }
 148         else {
 149             print $fh $data;
 150         }
 151
 152         return $size;
 153     });
 154     open(my $fileb, '>', \$resp_body);
 155     $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEDATA(), $fileb);
 156
 157     eval { $ua->perform };
 158     my $ret = $@;
 159
 160     return $self->_munge_response($ret, $resp_body, [@hdrdata], $data_cb);
 161 }
 162
 163
 164 sub _munge_response {
 165     my $self    = shift;
 166     my $error   = shift;
 167     my $body    = shift;
 168     my $hdrdata = shift;
 169     my $data_cb = shift;
 170
 171     my %headers = %{pop @$hdrdata || {}};
 172
 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());
 176
 177     my $resp = {
 178         success => 200 <= $code && $code <= 299,
 179         url     => $url,
 180         status  => $code,
 181         reason  => $reason,
 182         headers => \%headers,
 183     };
 184
 185     my $version = delete $headers{HTTPVersion} || _http_version($self->ua->getinfo(Net::Curl::Easy::CURLINFO_HTTP_VERSION()));
 186     $resp->{protocol} = "HTTP/$version" if $version;
 187
 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.
 190
 191     if ($error) {
 192         my $err = $self->ua->strerror($error);
 193         return HTTP::AnyUA::Util::internal_exception($err, $resp);
 194     }
 195
 196     $resp->{content} = $body if $body && !$data_cb;
 197
 198     return $resp;
 199 }
 200
 201 # get the HTTP version according to the user agent object
 202 sub _http_version {
 203     my $version = shift;
 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' : '';
 207 }
 208
 209 # parse a header line (or status line) and return as key-value pairs
 210 sub _parse_header {
 211     my $data = shift;
 212
 213     $data =~ s/[\x0A\x0D]*$//;
 214
 215     if ($data =~ m!^HTTP/([0-9.]+) [\x09\x20]+ (\d{3}) [\x09\x20]+ ([^\x0A\x0D]*)!x) {
 216         return (
 217             HTTPVersion => $1,
 218             Status      => $2,
 219             Reason      => $3,
 220         );
 221     }
 222
 223     my ($key, $val) = split(/:\s*/, $data, 2);
 224     return if !$key;
 225     return (lc($key) => $val);
 226 }
 227
 228 # no Net::Curl::Easy;
 229
 230 1;