File Coverage

blib/lib/CPAN/Upload/Tiny.pm

Criterion	Covered	Total	%
statement	38	73	52.0
branch	7	28	25.0
condition	2	14	14.2
subroutine	9	14	64.2
pod	4	6	66.6
total	60	135	44.4

package CPAN::Upload::Tiny;
$CPAN::Upload::Tiny::VERSION = '0.010';
use strict;
use warnings;

use Carp ();
use File::Basename ();
use MIME::Base64 ();
use HTTP::Tiny;
use HTTP::Tiny::Multipart;
use Term::ReadKey 'ReadMode';

my $UPLOAD_URI = $ENV{CPAN_UPLOADER_UPLOAD_URI} || 'https://pause.perl.org/pause/authenquery?ACTION=add_uri';

sub new {
	my ($class, $user, $password) = @_;
	Carp::croak('No user set')     if not defined $user;
	Carp::croak('No password set') if not defined $password;
	return bless {
		user     => $user,
		password => $password,
	}, $class;
}

sub new_from_config {
	my ($class, $filename) = @_;
	return $class->new(read_config_file($filename));
}

sub prompt {
	my ($mess, $mode) = @_;

	local $| = 1;
	local $\;
	print "$mess? ";

	ReadMode($mode);
	my $ans =  // '';
	ReadMode(0);
	print "\n" if $mode > 1;
	chomp $ans;
	return $ans;
}

sub new_from_config_or_stdin {
	my ($class, $filename) = @_;
	my ($user, $pass) = read_config_file($filename);
	$user ||= prompt("What is your PAUSE ID"      , 'normal');
	$pass ||= prompt("What is your PAUSE password", 'noecho');
	return $class->new($user, $pass);
}

sub upload_file {
	my ($self, $filename) = @_;

	open my $fh, '<:raw', $filename or die "Could not open $filename: $!";
	my $content = do { local $/; <$fh> };

	my $tiny = HTTP::Tiny->new(verify_SSL => 1);

	my $auth = 'Basic ' . MIME::Base64::encode("$self->{user}:$self->{password}", '');

	my $result = $tiny->post_multipart($UPLOAD_URI, {
		HIDDENNAME                        => $self->{user},
		CAN_MULTIPART                     => 1,
		pause99_add_uri_httpupload        => {
			filename     => File::Basename::basename($filename),
			content      => $content,
			content_type => 'application/gzip',
		},
		pause99_add_uri_uri               => '',
		SUBMIT_pause99_add_uri_httpupload => ' Upload this file from my disk ',
	}, { headers => { Authorization => $auth } });

	if (!$result->{success}) {
		my $key = $result->{status} == 599 ? 'content' : 'reason';
		die "Upload failed: $result->{$key}\n";
	}

	return;
}

sub read_config_file {
	my $filename = shift || glob('~/.pause');
	return unless -r $filename;

	my %conf;
	if ( eval { require Config::Identity } ) {
		%conf = Config::Identity->load($filename);
		$conf{user} = delete $conf{username} unless $conf{user};
	}
	else { # Process .pause manually
		open my $pauserc, '<', $filename or die "can't open $filename for reading: $!";

		while (<$pauserc>) {
			chomp;
			Carp::croak "$filename seems to be encrypted. Maybe you need to install Config::Identity?" if /BEGIN PGP MESSAGE/;

			next if not length or $_ =~ /^\s*#/;

			if (my ($k, $v) = / ^ \s* (user|password) \s+ (.+?) \s* $ /x) {
				Carp::croak "Multiple entries for $k" if $conf{$k};
				$conf{$k} = $v;
			}
		}
	}

	return @conf{'user', 'password'};
}

1;

#ABSTRACT: A tiny CPAN uploader

__END__