File Coverage

blib/lib/MojoX/CPAN/Uploader.pm

Criterion	Covered	Total	%
statement	15	41	36.5
branch	0	16	0.0
condition			n/a
subroutine	5	8	62.5
pod	2	2	100.0
total	22	67	32.8

package MojoX::CPAN::Uploader;

use warnings;
use strict;

use Carp;
use File::Basename;

use Mojo::Base '-base';

require Mojo::UserAgent;
require IO::Socket::SSL;

has client => sub { Mojo::UserAgent->new };
has [qw/user pass/];
has url => sub { Mojo::URL->new('https://pause.perl.org/pause/authenquery') };
has defaults => sub {
    {   CAN_MULTIPART => 1,
        SUBMIT_pause99_add_uri_httpupload =>
          " Upload this file from my disk ",
        pause99_add_uri_uri => "",
    };
};

our $VERSION = '0.032';

sub auth {
    my $self = shift;

    croak("Basic authorization user name can't contain ':'")
      if $_[0] =~ /:/;

    $self->user(shift);
    $self->pass(shift);
}

sub upload {
    my ($self, $file, $subdir) = splice @_, 0, 3;
    my $url = $self->url->clone->userinfo($self->user . ':' . $self->pass);

    croak "Auth info required!" unless $self->user;

    my $tx = $self->client->post_form(
        $url,
        {   %{$self->defaults},
            HIDDENNAME                 => $self->user,
            pause99_add_uri_upload     => basename($file),
            pause99_add_uri_httpupload => {file => $file},
            ($subdir ? (pause99_add_uri_subdirtext => $subdir) : ()),
        },
        @_
    );

    return 1 if $tx->res->code == 200;

    if ($tx->res->code == 406) {
        my $reason = $tx->res->dom->at('blockquote.actionresponse');
        my $title  = $reason->at('h3');
        $title = $title ? $title->all_text : 'unknown';
        my @p;
        my $table = 0;
        $reason->find('p')->each(
            sub {
                return $table = 1 if $_[0]->at('table');
                my $t = shift->all_text;
                $t =~ s/^\s+|\s$//g;
                $t =~ s/[\n\r]/ /g;
                $t =~ s/\s{2,}/ /g;
                push @p, $t;
            }
        );

        return Mojo::Exception->new(
            "Error '$title' " . $tx->res->code . "\n" . join("\n", @p, ''));

    }
    elsif ($tx->res->code == 401) {
        return Mojo::Exception->new(
            "Wrong login/password for Perl Author '" . $self->user . "'");
    }

    return Mojo::Exception->new("Unknown error: " . $tx->res->code);
}

1;
__END__