File Coverage

blib/lib/Net/Curl/Simple.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Net::Curl::Simple;

use strict;
use warnings; no warnings 'redefine';
use Net::Curl 0.17;
use Net::Curl::Easy qw(/^CURLOPT_(PROXY|POSTFIELDS)/ /^CURLPROXY_/);
use Scalar::Util qw(looks_like_number);
use URI;
use URI::Escape qw(uri_escape);
use base qw(Net::Curl::Easy);

our $VERSION = '0.13';

use constant
	curl_features => Net::Curl::version_info()->{features};

use constant {
	can_ipv6 => ( curl_features & Net::Curl::CURL_VERSION_IPV6 ) != 0,
	can_ssl => ( curl_features & Net::Curl::CURL_VERSION_SSL ) != 0,
	can_libz => ( curl_features & Net::Curl::CURL_VERSION_LIBZ ) != 0,
	can_asynchdns => ( curl_features & Net::Curl::CURL_VERSION_ASYNCHDNS ) != 0,
};

use Net::Curl::Simple::Async;

my @common_options = (
	connecttimeout => 60,
	followlocation => 1,
	# just to avoid loops
	maxredirs => 50,
	# there are to many broken servers to care about it by default
	ssl_verifypeer => 0,
	# enable cookie session
	cookiefile => '',
	useragent => __PACKAGE__ . ' v' . $VERSION,
	headerfunction => \&_cb_header,
	httpheader => [
		'Accept: */*',
	],
	# sets Accept-Encoding to all values supported by libcurl
	encoding => '',
);

my %proxytype = (
	http	=> CURLPROXY_HTTP,
	socks4	=> CURLPROXY_SOCKS4,
	socks5	=> CURLPROXY_SOCKS5,
	socks	=> CURLPROXY_SOCKS5,
);
{
	# introduced later in 7.18.0 and 7.19.4
	eval {
		$proxytype{socks4a} = CURLPROXY_SOCKS4A();
		$proxytype{socks5h} = CURLPROXY_SOCKS5_HOSTNAME();
	};
	eval {
		$proxytype{http10} = CURLPROXY_HTTP_1_0();
	};
}

# options that accept either a single constant or a bitmask of constants
my %optlong2constprefix = (
	http_version	=> 'CURL_HTTP_VERSION_',
	ipresolve		=> 'CURL_IPRESOLVE_',
	netrc			=> 'CURL_NETRC_',
	postredir		=> 'CURL_REDIR_POST_',
	rtsp_request	=> 'CURL_RTSPREQ_',
	sslversion		=> 'CURL_SSLVERSION_',
	timecondition	=> 'CURL_TIMECOND_',
	httpauth		=> 'CURLAUTH_',
	proxyauth		=> 'CURLAUTH_',
	ftpsslauth		=> 'CURLFTPAUTH_',
	ftp_filemethod	=> 'CURLFTPMETHOD_',
	tlsauth_type	=> 'CURLOPT_TLSAUTH_',
	protocols		=> 'CURLPROTO_',
	redir_protocols	=> 'CURLPROTO_',
	ssh_auth_types	=> 'CURLSSH_AUTH_',
	use_ssl			=> 'CURLUSESSL_',
);

{
	my %optcache;
	my %optlongcache;

	sub setopt
	{
		my ( $easy, $opt, $val, $temp ) = @_;

		unless ( looks_like_number( $opt ) ) {
			if ( exists $optlong2constprefix{ $opt } ) {
				# convert option value to a number
				# FROM: protocols => "http, file"
				# TO: CURLOPT_PROTOCOLS => CURLPROTO_HTTP | CURLPROTO_FILE
				unless ( looks_like_number( $val ) ) {
					unless ( exists $optlongcache{ $opt }->{ $val } ) {
						my $value = 0;
						my $prefix = $optlong2constprefix{ $opt };
						foreach ( ref $val ? @$val : split /[\|, ]+/, $val ) {
							my $const = $prefix . uc $_;
							# only constants with lowercase letters:
							# CURL_SSLVERSION_TLSv1, CURL_SSLVERSION_SSLv2...
							$const =~ s/V(\d+)$/v$1/
								if $prefix eq "CURL_SSLVERSION_";
							eval "\$value |= Net::Curl::Easy::$const";
							die "unrecognized literal value: $_ for option $opt\n"
								if $@;
						}
						$optlongcache{ $opt }->{ $val } = $value;
					}
					$val = $optlongcache{ $opt }->{ $val };
				}
			}
			# convert option name to option number
			unless ( exists $optcache{ $opt } ) {
				eval "\$optcache{ \$opt } = Net::Curl::Easy::CURLOPT_\U$opt";
				die "unrecognized literal option: $opt\n"
					if $@;
			}
			$opt = $optcache{ $opt };
		}

		if ( $opt == CURLOPT_PROXY ) {
			# guess proxy type from proxy string
			my $type = ( $val =~ m#^([a-z0-9]+)://# );
			if ( defined $type and exists $proxytype{ $type } ) {
				$easy->setopt( CURLOPT_PROXYTYPE, $proxytype{ $type }, $temp );
			}
		} elsif ( $opt == CURLOPT_POSTFIELDS ) {
			# perl knows the size, but libcurl may be wrong
			$easy->setopt( CURLOPT_POSTFIELDSIZE, length $val, $temp );
		}

		my $stash = $easy->{options_temp};
		unless ( $temp ) {
			delete $stash->{ $opt };
			$stash = $easy->{options};
		}
		$stash->{ $opt } = $val;
		$easy->SUPER::setopt( $opt => $val );
	}
}

sub setopts
{
	my $easy = shift;

	while ( my ( $opt, $val ) = splice @_, 0, 2 ) {
		$easy->setopt( $opt => $val );
	}
}

sub setopts_temp
{
	my $easy = shift;

	while ( my ( $opt, $val ) = splice @_, 0, 2 ) {
		$easy->setopt( $opt => $val, 1 );
	}
}


{
	my %infocache;

	sub getinfo
	{
		my ( $easy, $info ) = @_;

		unless ( looks_like_number( $info ) ) {
			# convert option name to option number
			unless ( exists $infocache{ $info } ) {
				eval "\$infocache{ \$info } = Net::Curl::Easy::CURLINFO_\U$info";
				die "unrecognized literal info: $info\n"
					if $@;
			}
			$info = $infocache{ $info };
		}

		$easy->SUPER::getinfo( $info );
	}
}

sub getinfos
{
	my $easy = shift;
	my @out;

	foreach my $arg ( @_ ) {
		my $ret = undef;
		eval {
			$ret = $easy->getinfo( $arg );
		};
		push @out, $ret;
	}
	return @out;
}

sub _cb_header
{
	my ( $easy, $data, $uservar ) = @_;
	push @{ $easy->{headers} }, $data;
	return length $data;
}

sub new
{
	my $class = shift;

	my $easy = $class->SUPER::new(
		{
			body => '',
			headers => [],
			options => {},
			options_temp => {},
		}
	);
	# some sane defaults
	$easy->setopts(
		writeheader => \$easy->{headers},
		file => \$easy->{body},
		@common_options,
		@_,
	);

	return $easy;
}

sub _finish
{
	my ( $easy, $result ) = @_;
	$easy->{referer} = $easy->getinfo( 'effective_url' );
	$easy->{in_use} = 0;
	$easy->{code} = $result;

	my $perm = $easy->{options};
	foreach my $opt ( keys %{ $easy->{options_temp} } ) {
		my $val = $perm->{$opt};
		$easy->setopt( $opt => $val, 0 );
	}

	my $cb = $easy->{cb};
	eval { $cb->( $easy ) } if $cb;
}

sub ua
{
	return (shift)->share();
}

sub _start_perform($);
sub _perform
{
	my ( $easy, $uri, $cb ) = splice @_, 0, 3;
	if ( $easy->{in_use} ) {
		die "this handle is already in use\n";
	}
	if ( $easy->{referer} ) {
		$easy->setopt( referer => $easy->{referer} );
		$uri = URI->new( $uri )->abs( $easy->{referer} )->as_string;
	}

	$easy->setopts_temp( @_ ) if @_;
	$easy->setopt( url => $uri );

	$easy->{uri} = $uri;
	$easy->{cb} = $cb;
	$easy->{body} = '';
	$easy->{headers} = [];
	$easy->{in_use} = 1;

	Net::Curl::Simple::Async::multi->add_handle( $easy );

	# block unless we've got a callback
	$easy->join unless $cb;

	return $easy;
}

*join = sub ($)
{
	my $easy = shift;
	if ( not ref $easy ) {
		# no object, wait for first easy that finishes
		$easy = Net::Curl::Simple::Async::multi->get_one();
		return $easy;
	} else {
		return $easy unless $easy->{in_use};
		Net::Curl::Simple::Async::multi->get_one( $easy );
		return $easy;
	}
};

# results
sub code
{
	return (shift)->{code};
}

sub headers
{
	return @{ (shift)->{headers} };
}

sub content
{
	return (shift)->{body};
}

# get some uri
sub get
{
	my ( $easy, $uri ) = splice @_, 0, 2;
	my $cb = @_ & 1 ? pop : undef;

	$easy->_perform( $uri, $cb,
		@_,
		httpget => 1,
	);
}

# request head on some uri
sub head
{
	my ( $easy, $uri ) = splice @_, 0, 2;
	my $cb = @_ & 1 ? pop : undef;

	$easy->_perform( $uri, $cb,
		@_,
		nobody => 1,
	);
}

# post data to some uri
sub post
{
	my ( $easy, $uri, $post ) = splice @_, 0, 3;
	my $cb = @_ & 1 ? pop : undef;

	my @postopts;
	if ( not ref $post ) {
		@postopts = ( postfields => $post );
	} elsif ( UNIVERSAL::isa( $post, 'Net::Curl::Form' ) ) {
		@postopts = ( httppost => $post );
	} elsif ( ref $post eq 'HASH' ) {
		# handle utf8 ?
		my $postdata = join '&',
			map { uri_escape( $_ ) . '=' . uri_escape( $post->{ $_ } ) }
			sort keys %$post;
		@postopts = ( postfields => $postdata );
	} else {
		die "don't know how to convert $post into a valid post\n";
	}
	$easy->_perform( $uri, $cb,
		@_,
		post => 1,
		@postopts
	);
}

# put some data
sub put
{
	my ( $easy, $uri, $put ) = splice @_, 0, 3;
	my $cb = @_ & 1 ? pop : undef;

	my @putopts;
	if ( not ref $put ) {
		die "Cannot put file $put\n"
			unless -r $put;
		open my $fin, '<', $put;
		@putopts = (
			readfunction => sub {
				my ( $easy, $maxlen, $uservar ) = @_;
				sysread $fin, my ( $r ), $maxlen;
				return \$r;
			},
			infilesize_large => -s $put
		);
	} elsif ( ref $put eq 'SCALAR' ) {
		my $data = $$put;
		use bytes;
		@putopts = (
			readfunction => sub {
				my ( $easy, $maxlen, $uservar ) = @_;
				my $r = substr $data, 0, $maxlen, '';
				return \$r;
			},
			infilesize_large => length $data
		);
	} elsif ( ref $put eq 'CODE' ) {
		@putopts = (
			readfunction => $put,
		);
	} else {
		die "don't know how to put $put\n";
	}
	$easy->_perform( $uri, $cb,
		@_,
		upload => 1,
		@putopts
	);
}


1;

__END__