File Coverage

blib/lib/CPAN/Uploader.pm

Criterion	Covered	Total	%
statement	24	112	21.4
branch	0	68	0.0
condition	0	38	0.0
subroutine	8	17	47.0
pod	5	7	71.4
total	37	242	15.2

use strict;
use warnings;
package CPAN::Uploader 0.103017;
# ABSTRACT: upload things to the CPAN

#pod =head1 ORIGIN
#pod
#pod This code is mostly derived from C by Brad Fitzpatrick, which
#pod in turn was based on C by Neil Bowers.  I (I) didn't want to
#pod have to use a C call to run either of those, so I refactored the code
#pod into this module.
#pod
#pod =cut

use Carp ();
use File::Basename ();
use File::Spec;
use HTTP::Request::Common qw(POST);
use HTTP::Status;
use LWP::UserAgent;

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

#pod =method upload_file
#pod
#pod   CPAN::Uploader->upload_file($file, \%arg);
#pod
#pod   $uploader->upload_file($file);
#pod
#pod Valid arguments are:
#pod
#pod   user        - (required) your CPAN / PAUSE id
#pod   password    - (required) your CPAN / PAUSE password
#pod   subdir      - the directory (under your home directory) to upload to
#pod   http_proxy  - uri of the http proxy to use
#pod   upload_uri  - uri of the upload handler; usually the default (PAUSE) is right
#pod   debug       - if set to true, spew lots more debugging output
#pod   retries     - number of retries to perform on upload failure (5xx response)
#pod   retry_delay - number of seconds to wait between retries
#pod
#pod This method attempts to actually upload the named file to the CPAN.  It will
#pod raise an exception on error. c can also be set through the ENV
#pod variable c.
#pod
#pod =cut

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

  Carp::confess(q{don't supply %arg when calling upload_file on an object})
    if $arg and ref $self;

  Carp::confess(q{attempted to upload a non-file}) unless -f $file;

  # class call with no args is no good
  Carp::confess(q{need to supply %arg when calling upload_file from the class})
    if not (ref $self) and not $arg;

  $self = $self->new($arg) if $arg;

  if ($arg->{dry_run}) {
    require Data::Dumper;
    $self->log("By request, cowardly refusing to do anything at all.");
    $self->log(
      "The following arguments would have been used to upload: \n"
      . '$self: ' . Data::Dumper::Dumper($self)
      . '$file: ' . Data::Dumper::Dumper($file)
    );
  } else {
    my $retries = $self->{retries} || 0;
    my $tries = ($retries > 0) ? $retries + 1 : 1;

    TRY: for my $try (1 .. $tries) {
      last TRY if eval { $self->_upload($file); 1 };
      die $@ unless $@ !~ /request failed with error code 5/;

      if ($try <= $tries) {
        $self->log("Upload failed ($@)");
        if ($tries and ($try < $tries)) {
          my $next_try = $try + 1;
          $self->log("Will make attempt #$next_try ...");
        }
        sleep $self->{retry_delay} if $self->{retry_delay};
      }
      if ($try >= $tries) {
        die "Failed to upload and reached maximum retry count!\n";
      }
    }
  }
}

sub _ua_string {
  my ($self) = @_;
  my $class   = ref $self || $self;
  my $version = defined $class->VERSION ? $class->VERSION : 'dev';

  return "$class/$version";
}

sub uri { shift->{upload_uri} || $UPLOAD_URI }
sub target { shift->{target} || 'PAUSE' }

sub _upload {
  my $self = shift;
  my $file = shift;

  $self->log("registering upload with " . $self->target . " web server");

  my $agent = LWP::UserAgent->new;
  $agent->agent( $self->_ua_string );

  $agent->env_proxy;
  $agent->proxy(http => $self->{http_proxy}) if $self->{http_proxy};

  my $uri = $self->{upload_uri} || $UPLOAD_URI;

  my $type = 'form-data';
  my %content = (
    HIDDENNAME                        => $self->{user},
    ($self->{subdir} ? (pause99_add_uri_subdirtext        => $self->{subdir}) : ()),
  );

  if ($file =~ m{^https?://}) {
    $type = 'application/x-www-form-urlencoded';
    %content = (
      %content,
      pause99_add_uri_httpupload        => '',
      pause99_add_uri_uri               => $file,
      SUBMIT_pause99_add_uri_uri        => " Upload this URL ",
    );
  } else {
    %content = (
      %content,
      CAN_MULTIPART                     => 1,
      pause99_add_uri_upload            => File::Basename::basename($file),
      pause99_add_uri_httpupload        => [ $file ],
      pause99_add_uri_uri               => '',
      SUBMIT_pause99_add_uri_httpupload => " Upload this file from my disk ",
    );
  }

  my $request = POST(
    $uri,
    Content_Type => $type,
    Content      => \%content,
  );

  $request->authorization_basic($self->{user}, $self->{password});

  my $DEBUG_METHOD = $ENV{CPAN_UPLOADER_DISPLAY_HTTP_BODY}
                   ? 'as_string'
                   : 'headers_as_string';

  $self->log_debug(
    "----- REQUEST BEGIN -----\n" .
    $request->$DEBUG_METHOD . "\n" .
    "----- REQUEST END -------\n"
  );

  # Make the request to the PAUSE web server
  $self->log("POSTing upload for $file to $uri");
  my $response = $agent->request($request);

  # So, how'd we do?
  if (not defined $response) {
    die "Request completely failed - we got undef back: $!";
  }

  if ($response->is_error) {
    if ($response->code == RC_NOT_FOUND) {
      die "PAUSE's CGI for handling messages seems to have moved!\n",
        "(HTTP response code of 404 from the ", $self->target, " web server)\n",
        "It used to be: ", $uri, "\n",
        "Please inform the maintainer of $self.\n";
    } else {
      die "request failed with error code ", $response->code,
        "\n  Message: ", $response->message, "\n";
    }
  } else {
    $self->log_debug($_) for (
      "Looks OK!",
      "----- RESPONSE BEGIN -----\n" .
      $response->$DEBUG_METHOD . "\n" .
      "----- RESPONSE END -------\n"
    );

    $self->log($self->target . " add message sent ok [" . $response->code . "]");
  }
}


#pod =method new
#pod
#pod   my $uploader = CPAN::Uploader->new(\%arg);
#pod
#pod This method returns a new uploader.  You probably don't need to worry about
#pod this method.
#pod
#pod Valid arguments are the same as those to C.
#pod
#pod =cut

sub new {
  my ($class, $arg) = @_;

  $arg->{$_} or Carp::croak("missing $_ argument") for qw(user password);
  bless $arg => $class;
}

#pod =method read_config_file
#pod
#pod   my $config = CPAN::Uploader->read_config_file( $filename );
#pod
#pod This reads the config file and returns a hashref of its contents that can be
#pod used as configuration for CPAN::Uploader.
#pod
#pod If no filename is given, it looks for F<.pause> in the user's home directory
#pod (from the env var C, or the current directory if C isn't set).
#pod
#pod See L for the config format.
#pod
#pod =cut

sub read_config_file {
  my ($class, $filename) = @_;

  unless (defined $filename) {
    my $home = $^O eq 'MSWin32' && "$]" < 5.016
      ? $ENV{HOME} || $ENV{USERPROFILE}
      : (<~>)[0];
    $filename = File::Spec->catfile($home, '.pause');

    return {} unless -e $filename and -r _;
  }

  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;
      if (/BEGIN PGP MESSAGE/ ) {
        Carp::croak "$filename seems to be encrypted. "
          . "Maybe you need to install Config::Identity?"
      }

      next unless $_ and $_ !~ /^\s*#/;

      my ($k, $v) = /^\s*(\w+)\s+(.+)$/;
      Carp::croak "multiple entries for $k" if $conf{$k};
      $conf{$k} = $v;
    }
  }

  # minimum validation of arguments
  Carp::croak "Configured user has trailing whitespace"
    if defined $conf{user} && $conf{user} =~ /\s$/;
  Carp::croak "Configured user contains whitespace"
    if defined $conf{user} && $conf{user} =~ /\s/;

  return \%conf;
}

#pod =method log
#pod
#pod   $uploader->log($message);
#pod
#pod This method logs the given string.  The default behavior is to print it to the
#pod screen.  The message should not end in a newline, as one will be added as
#pod needed.
#pod
#pod =cut

sub log {
  shift;
  print "$_[0]\n"
}

#pod =method log_debug
#pod
#pod This method behaves like C>, but only logs the message if the
#pod CPAN::Uploader is in debug mode.
#pod
#pod =cut

sub log_debug {
  my $self = shift;
  return unless $self->{debug};
  $self->log($_[0]);
}

1;

__END__