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
   5 use warnings;
   6 use strict;
   7
   8 our $VERSION = '0.900'; # VERSION
   9
  10 use parent 'HTTP::AnyUA::Backend';
  11
  12 use HTTP::AnyUA::Util;
  13 use Scalar::Util;
  14
  15
  16 sub request {
  17     my $self = shift;
  18     my ($method, $url, $args) = @_;
  19
  20     my $ua = $self->ua;
  21
  22     # reset
  23     $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(), 0);
  24     $ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(), 0);
  25     $ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(), undef);
  26     $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(), undef);
  27     $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), 0);
  28
  29     if ($method eq 'GET') {
  30         $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(), 1);
  31     }
  32     elsif ($method eq 'HEAD') {
  33         $ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(), 1);
  34     }
  35
  36     if (my $content = $args->{content}) {
  37         if (ref($content) eq 'CODE') {
  38             my $content_length;
  39             for my $header (keys %{$args->{headers} || {}}) {
  40                 if (lc($header) eq 'content-length') {
  41                     $content_length = $args->{headers}{$header};
  42                     last;
  43                 }
  44             }
  45
  46             if ($content_length) {
  47                 my $chunk;
  48                 $ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(), sub {
  49                     my $ua      = shift;
  50                     my $maxlen  = shift;
  51
  52                     if (!$chunk) {
  53                         $chunk = $content->();
  54                         return 0 if !$chunk;
  55                     }
  56
  57                     my $part = substr($chunk, 0, $maxlen, '');
  58                     return \$part;
  59                 });
  60                 $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), $content_length);
  61             }
  62             else {
  63                 # if we don't know the length we have to just read it all in
  64                 $content = HTTP::AnyUA::Util::coderef_content_to_string($content);
  65             }
  66         }
  67         if (ref($content) ne 'CODE') {
  68             $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(), $content);
  69             $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), length $content);
  70         }
  71     }
  72
  73     $ua->setopt(Net::Curl::Easy::CURLOPT_URL(), $url);
  74     $ua->setopt(Net::Curl::Easy::CURLOPT_CUSTOMREQUEST(), $method);
  75
  76     # munge headers
  77     my @headers;
  78     for my $header (keys %{$args->{headers} || {}}) {
  79         my $value  = $args->{headers}{$header};
  80         my @values = ref($value) eq 'ARRAY' ? @$value : $value;
  81         for my $v (@values) {
  82             push @headers, "${header}: $v";
  83         }
  84     }
  85     $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPHEADER(), \@headers) if @headers;
  86
  87     my @hdrdata;
  88
  89     $ua->setopt(Net::Curl::Easy::CURLOPT_HEADERFUNCTION(), sub {
  90         my $ua      = shift;
  91         my $data    = shift;
  92         my $size    = length $data;
  93
  94         my %headers = _parse_header($data);
  95
  96         if ($headers{Status}) {
  97             push @hdrdata, {};
  98         }
  99
 100         my $resp_headers = $hdrdata[-1];
 101
 102         for my $key (keys %headers) {
 103             if (!$resp_headers->{$key}) {
 104                 $resp_headers->{$key} =  $headers{$key};
 105             }
 106             else {
 107                 if (ref($resp_headers->{$key}) ne 'ARRAY') {
 108                     $resp_headers->{$key} = [$resp_headers->{$key}];
 109                 }
 110                 push @{$resp_headers->{$key}}, $headers{$key};
 111             }
 112         }
 113
 114         return $size;
 115     });
 116
 117     my $resp_body = '';
 118
 119     my $data_cb = $args->{data_callback};
 120     my $copy = $self;
 121     Scalar::Util::weaken($copy);
 122     $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEFUNCTION(), sub {
 123         my $ua      = shift;
 124         my $data    = shift;
 125         my $fh      = shift;
 126         my $size    = length $data;
 127
 128         if ($data_cb) {
 129             my $resp = $copy->_munge_response(undef, undef, [@hdrdata], $data_cb);
 130             $data_cb->($data, $resp);
 131         }
 132         else {
 133             print $fh $data;
 134         }
 135
 136         return $size;
 137     });
 138     open(my $fileb, '>', \$resp_body);
 139     $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEDATA(), $fileb);
 140
 141     eval { $ua->perform };
 142     my $ret = $@;
 143
 144     return $self->_munge_response($ret, $resp_body, [@hdrdata], $data_cb);
 145 }
 146
 147
 148 sub _munge_response {
 149     my $self    = shift;
 150     my $error   = shift;
 151     my $body    = shift;
 152     my $hdrdata = shift;
 153     my $data_cb = shift;
 154
 155     my %headers = %{pop @$hdrdata || {}};
 156
 157     my $code    = delete $headers{Status} || $self->ua->getinfo(Net::Curl::Easy::CURLINFO_RESPONSE_CODE()) || 599;
 158     my $reason  = delete $headers{Reason};
 159     my $url     = $self->ua->getinfo(Net::Curl::Easy::CURLINFO_EFFECTIVE_URL());
 160
 161     my $resp = {
 162         success => 200 <= $code && $code <= 299,
 163         url     => $url,
 164         status  => $code,
 165         reason  => $reason,
 166         headers => \%headers,
 167     };
 168
 169     my $version = delete $headers{HTTPVersion} || _http_version($self->ua->getinfo(Net::Curl::Easy::CURLINFO_HTTP_VERSION()));
 170     $resp->{protocol} = "HTTP/$version" if $version;
 171
 172     # We have the headers for the redirect chain in $hdrdata, but we don't have the contents, and we
 173     # would also need to reconstruct the URLs.
 174
 175     if ($error) {
 176         my $err = $self->ua->strerror($error);
 177         return HTTP::AnyUA::Util::internal_exception($err, $resp);
 178     }
 179
 180     $resp->{content} = $body if $body && !$data_cb;
 181
 182     return $resp;
 183 }
 184
 185 # get the HTTP version according to the user agent object
 186 sub _http_version {
 187     my $version = shift;
 188     return $version == Net::Curl::Easy::CURL_HTTP_VERSION_1_0() ? '1.0' :
 189            $version == Net::Curl::Easy::CURL_HTTP_VERSION_1_1() ? '1.1' :
 190            $version == Net::Curl::Easy::CURL_HTTP_VERSION_2_0() ? '2.0' : '';
 191 }
 192
 193 # parse a header line (or status line) and return as key-value pairs
 194 sub _parse_header {
 195     my $data = shift;
 196
 197     $data =~ s/[\x0A\x0D]*$//;
 198
 199     if ($data =~ m!^HTTP/([0-9.]+) [\x09\x20]+ (\d{3}) [\x09\x20]+ ([^\x0A\x0D]*)!x) {
 200         return (
 201             HTTPVersion => $1,
 202             Status      => $2,
 203             Reason      => $3,
 204         );
 205     }
 206
 207     my ($key, $val) = split(/:\s*/, $data, 2);
 208     return if !$key;
 209     return (lc($key) => $val);
 210 }
 211
 212 # no Net::Curl::Easy;
 213
 214 1;
 215
 216 __END__
 217
 218 =pod
 219
 220 =encoding UTF-8
 221
 222 =head1 NAME
 223
 224 HTTP::AnyUA::Backend::Net::Curl::Easy - A unified programming interface for Net::Curl::Easy
 225
 226 =head1 VERSION
 227
 228 version 0.900
 229
 230 =head1 DESCRIPTION
 231
 232 This module adds support for the HTTP client L<Net::Curl::Easy> to be used with the unified
 233 programming interface provided by L<HTTP::AnyUA>.
 234
 235 =head1 CAVEATS
 236
 237 =over 4
 238
 239 =item *
 240
 241 The C<redirects> field in the response is currently unsupported.
 242
 243 =back
 244
 245 =head1 SEE ALSO
 246
 247 =over 4
 248
 249 =item *
 250
 251 L<HTTP::AnyUA::Backend>
 252
 253 =back
 254
 255 =head1 BUGS
 256
 257 Please report any bugs or feature requests on the bugtracker website
 258 L<https://github.com/chazmcgarvey/HTTP-AnyUA/issues>
 259
 260 When submitting a bug or request, please include a test-file or a
 261 patch to an existing test-file that illustrates the bug or desired
 262 feature.
 263
 264 =head1 AUTHOR
 265
 266 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 267
 268 =head1 COPYRIGHT AND LICENSE
 269
 270 This software is copyright (c) 2017 by Charles McGarvey.
 271
 272 This is free software; you can redistribute it and/or modify it under
 273 the same terms as the Perl 5 programming language system itself.
 274
 275 =cut