File Coverage

blib/lib/LWP/Protocol/Net/Curl.pm

Criterion	Covered	Total	%
statement	28	30	93.3
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	38	40	95.0

package LWP::Protocol::Net::Curl;
# ABSTRACT: the power of libcurl in the palm of your hands!


use strict;
use utf8;
use warnings qw(all);

use base qw(LWP::Protocol);

use Carp qw(carp);
use Config;
use Fcntl;
use HTTP::Date;
use LWP::UserAgent;
use Net::Curl::Easy qw(:constants);
use Net::Curl::Multi qw(:constants);
use Net::Curl::Share qw(:constants);
use Scalar::Util qw(looks_like_number);
use URI;

our $VERSION = '0.022'; # VERSION

my %curlopt;
my $share;
unless (defined $Config{usethreads}) {
    $share = Net::Curl::Share->new({ started => time });
    $share->setopt(CURLSHOPT_SHARE ,=> CURL_LOCK_DATA_COOKIE);
    $share->setopt(CURLSHOPT_SHARE ,=> CURL_LOCK_DATA_DNS);

    ## no critic (RequireCheckingReturnValueOfEval)
    eval { $share->setopt(CURLSHOPT_SHARE ,=> CURL_LOCK_DATA_SSL_SESSION) };
}

## no critic (ProhibitPackageVars)
my %protocols = map { ($_) x 2 } @{Net::Curl::version_info()->{protocols}};
our @implements =
    sort grep { defined }
        @protocols
        {qw{ftp ftps gopher http https sftp scp}};
our %implements = map { $_ => 1 } @implements;

our $use_select = Net::Curl::Multi->can(q(wait)) ? 0 : 1;


# Resolve libcurl constants by string
sub _curlopt {
    my ($key, $no_carp) = @_;
    return 0 + $key if looks_like_number($key);

    $key =~ s/^Net::Curl::Easy:://ix;
    $key =~ y/-/_/;
    $key =~ s/\W//gx;
    $key = uc $key;
    $key = qq(CURLOPT_${key}) if $key !~ /^CURL(?:M|SH)?OPT_/x;

    my $const = eval {
        ## no critic (ProhibitNoStrict ProhibitNoWarnings)
        no strict qw(refs);
        no warnings qw(once);
        return *$key->();
    };
    carp qq(Invalid libcurl constant: $key)
        if $@
        and not defined $no_carp;

    return $const;
}

# Sugar for a common setopt() pattern
sub _setopt_ifdef {
    my ($curl, $key, $value, $no_carp) = @_;

    my $curlopt_key = _curlopt($key, $no_carp);
    $curl->setopt($curlopt_key => $value)
        if defined $curlopt_key
        and defined $value;

    return;
}

# Pre-configure the module
sub import {
    my ($class, @args) = @_;

    my $takeover = 1;
    if (@args) {
        my %args = @args;
        while (my ($key, $value) = each %args) {
            if ($key eq q(takeover)) {
                $takeover = $value;
            } else {
                my $const = _curlopt($key);
                $curlopt{$const} = $value
                    if defined $const;
            }
        }
    }

    if ($takeover) {
        LWP::Protocol::implementor($_ => $class)
            for @implements;
    }

    return;
}

# Properly setup libcurl to handle each method in a compatible way
sub _handle_method {
    my ($ua, $easy, $request) = @_;

    my $method = uc $request->method;
    my %dispatch = (
        GET => sub {
            $easy->setopt(CURLOPT_HTTPGET   ,=> 1);
        }, POST => sub {
            $easy->setopt(CURLOPT_POST      ,=> 1);
            $easy->setopt(CURLOPT_POSTFIELDS,=> $request->content);
            $easy->setopt(CURLOPT_POSTFIELDSIZE,=> length $request->content);
        }, HEAD => sub {
            $easy->setopt(CURLOPT_NOBODY    ,=> 1);
        }, DELETE => sub {
            $easy->setopt(CURLOPT_CUSTOMREQUEST ,=> $method);
        }, PUT => sub {
            $easy->setopt(CURLOPT_UPLOAD    ,=> 1);
            my $buf = $request->content;
            my $off = 0;
            $easy->setopt(CURLOPT_INFILESIZE,=> length $buf);
            $easy->setopt(CURLOPT_READFUNCTION ,=> sub {
                my (undef, $maxlen) = @_;
                my $chunk = substr $buf, $off, $maxlen;
                $off += length $chunk;
                return \$chunk;
            });
        },
    );

    my $method_ref = $dispatch{$method};
    if (defined $method_ref) {
        $method_ref->();
    } else {
        ## no critic (RequireCarping)
        die HTTP::Response->new(
            &HTTP::Status::RC_BAD_REQUEST,
            qq(Bad method '$method')
        );
    }

    # handle redirects internally (except POST, greatly fsck'd up by IIS servers)
    if ($method ne q(POST) and grep { $method eq uc } @{$ua->requests_redirectable}) {
        $easy->setopt(CURLOPT_AUTOREFERER   ,=> 1);
        $easy->setopt(CURLOPT_FOLLOWLOCATION,=> 1);
        $easy->setopt(CURLOPT_MAXREDIRS     ,=> $ua->max_redirect);
    } else {
        $easy->setopt(CURLOPT_FOLLOWLOCATION,=> 0);
    }

    return $method;
}

# Compatibilize request headers
sub _fix_headers {
    my ($ua, $easy, $key, $value) = @_;

    return 0 unless defined $value;

    # stolen from LWP::Protocol::http
    $key =~ s/^://x;
    $value =~ s/\n/ /gx;

    my $encoding = 0;
    if ($key =~ /^accept-encoding$/ix) {
        my @encoding =
            map { /^(?:x-)?(deflate|gzip|identity)$/ix ? lc $1 : () }
            split /\s*,\s*/x, $value;

        if (@encoding) {
            ++$encoding;
            $easy->setopt(CURLOPT_ENCODING  ,=> join(q(,) => @encoding));
        }
    } elsif ($key =~ /^user-agent$/ix) {
        # While we try our best to look like LWP on the client-side,
        # it's *definitely* different on the server-site!
        # I guess it would be nice to introduce ourselves in a polite way.
        $value =~ s/\b(\Q@{[ $ua->_agent ]}\E)\b/qq($1 ) . Net::Curl::version()/egx;
        $easy->setopt(CURLOPT_USERAGENT     ,=> $value);
    } elsif ($key =~ /^x[-_](curlopt[-\w]+)$/ix) {
        _setopt_ifdef($easy, $1 => $value);
    } else {
        $easy->pushopt(CURLOPT_HTTPHEADER   ,=> [qq[$key: $value]]);
    }

    return $encoding;
}

# Wrap libcurl perform() in a (potentially) non-blocking way
sub _perform_loop {
    my ($multi) = @_;

    my $running = 0;
    do {
        my $timeout = $multi->timeout;

        if ($running and $timeout > 9) {
            if ($use_select) {
                my ($r, $w, $e) = $multi->fdset;
                select($r, $w, $e, $timeout / 1000);
            } else {
                $multi->wait($timeout);
            }
        }

        $running = $multi->perform;
        while (my (undef, $easy, $result) = $multi->info_read) {
            $multi->remove_handle($easy);
            if ($result == CURLE_TOO_MANY_REDIRECTS) {
                # will return the last request
            } elsif ($result) {
                ## no critic (RequireCarping)
                die HTTP::Response->new(
                    &HTTP::Status::RC_BAD_REQUEST,
                    qq($result),
                );
            }
        }
    } while ($running);

    return $running;
}

## no critic (ProhibitManyArgs)
sub request {
    my ($self, $request, $proxy, $arg, $size, $timeout) = @_;

    my $ua = $self->{ua};
    unless (q(Net::Curl::Multi) eq ref $ua->{curl_multi}) {
        $ua->{curl_multi} = Net::Curl::Multi->new({ def_headers => $ua->{def_headers} });

        # avoid "callback function is not set" warning
        _setopt_ifdef(
            $ua->{curl_multi},
            q(CURLMOPT_SOCKETFUNCTION) => sub { return 0 },
            1,
        );
    }

    my $data = '';
    my $header = '';
    my $writedata;

    my $easy = Net::Curl::Easy->new({ request => $request });
    $ua->{curl_multi}->add_handle($easy);

    my $previous = undef;
    my $response = HTTP::Response->new(&HTTP::Status::RC_OK);
    $response->request($request);

    $easy->setopt(CURLOPT_HEADERFUNCTION ,=> sub {
        my ($_easy, $line) = @_;
        $header .= $line;

        # I hope only HTTP sends "empty line" as delimiters
        if ($line =~ /^\s*$/sx) {
            $response = HTTP::Response->parse($header);
            my $msg = $response->message;
            $msg = '' unless defined $msg;
            $msg =~ s/^\s+|\s+$//gsx;
            $response->message($msg);

            $response->request($request->clone);
            my $effective_url = URI->new('' . $_easy->getinfo(CURLINFO_EFFECTIVE_URL));
            $response->request->uri($effective_url);
            $response->previous($previous) if defined $previous;
            $previous = $response;

            $header = '';
        }

        return length $line;
    });

    if (q(CODE) eq ref $arg) {
        $easy->setopt(CURLOPT_WRITEFUNCTION ,=> sub {
            my (undef, $chunk) = @_;
            $arg->($chunk, $response, $self);
            return length $chunk;
        });
        $writedata = undef;
    } elsif (defined $arg) {
        # will die() later
        sysopen $writedata, $arg, O_CREAT | O_NONBLOCK | O_WRONLY;
        binmode $writedata;
    } else {
        $writedata = \$data;
    }

    my $encoding = 0;
    while (my ($key, $value) = each %curlopt) {
        ++$encoding if $key == CURLOPT_ENCODING;
        $easy->setopt($key, $value);
    }

    # SSL stuff, may not be compiled
    if ($request->uri->scheme =~ /s$/ix) {
        _setopt_ifdef($easy, CAINFO         => $ua->{ssl_opts}{SSL_ca_file});
        _setopt_ifdef($easy, CAPATH         => $ua->{ssl_opts}{SSL_ca_path});
        _setopt_ifdef($easy, CURLOPT_SSLCERT=> $ua->{ssl_opts}{SSL_cert_file});
        _setopt_ifdef($easy, CURLOPT_SSLKEY => $ua->{ssl_opts}{SSL_key_file});

        # fixes a security flaw denied by libcurl v7.28.1
        _setopt_ifdef($easy, SSL_VERIFYHOST => (!!$ua->{ssl_opts}{verify_hostname}) << 1);
        _setopt_ifdef($easy, SSL_VERIFYPEER => 0) unless $ua->{ssl_opts}{verify_hostname};
    }

    $easy->setopt(CURLOPT_FILETIME          ,=> 1);
    $easy->setopt(CURLOPT_URL               ,=> $request->uri);
    _setopt_ifdef($easy, CURLOPT_BUFFERSIZE ,=> $size);
    _setopt_ifdef($easy, CURLOPT_INTERFACE  ,=> $ua->{local_address});
    _setopt_ifdef($easy, CURLOPT_MAXFILESIZE,=> $ua->max_size);
    _setopt_ifdef($easy, q(CURLOPT_NOPROXY)  => join(q(,) => @{$ua->{no_proxy}}), 1);
    _setopt_ifdef($easy, CURLOPT_PROXY      ,=> $proxy);
    _setopt_ifdef($easy, CURLOPT_SHARE      ,=> $share);
    _setopt_ifdef($easy, CURLOPT_TIMEOUT    ,=> $timeout);
    _setopt_ifdef($easy, CURLOPT_WRITEDATA  ,=> $writedata);

    if ($ua->{show_progress}) {
        $easy->setopt(CURLOPT_NOPROGRESS    ,=> 0);
        _setopt_ifdef(
            $easy,
            q(CURLOPT_PROGRESSFUNCTION)     => sub {
                my (undef, $dltotal, $dlnow) = @_;
                $ua->progress($dltotal ? $dlnow / $dltotal : q(tick));
                return 0;
            },
            1,
        );
    }

    _handle_method($ua, $easy, $request);

    $request->headers->scan(sub { $encoding += _fix_headers($ua, $easy, @_) });

    _perform_loop($ua->{curl_multi});

    $response->code($easy->getinfo(CURLINFO_RESPONSE_CODE) || 200);

    my $time = $easy->getinfo(CURLINFO_FILETIME);
    $response->headers->header(last_modified => time2str($time))
        if $time > 0;

    # handle decoded_content() & direct file write
    if (q(GLOB) eq ref $writedata) {
        close $writedata;
        # avoid truncate by collect()
        $arg = undef;
    } elsif ($encoding) {
        $response->headers->header(content_encoding => q(identity));
    }

    return $self->collect_once($arg, $response, $data);
}


1;

__END__