use strict; use warnings; package CPAN::Uploader 0.103018; # 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 = $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 _parse_dot_pause { my ($class, $filename) = @_; my %conf; 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*#/; if (my ($k, $v) = /^\s*(\w+)\s+(.+)$/) { Carp::croak "multiple entries for $k" if $conf{$k}; $conf{$k} = $v; } else { Carp::croak qq#Line $. ($_) does not match the "key value" format.#; } } return %conf; } 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 %conf = $class->_parse_dot_pause($filename); } # 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__ =pod =encoding UTF-8 =head1 NAME CPAN::Uploader - upload things to the CPAN =head1 VERSION version 0.103018 =head1 PERL VERSION This library should run on perls released even a long time ago. It should work on any version of perl released in the last five years. Although it may work on older versions of perl, no guarantee is made that the minimum required version will not be increased. The version may be increased for any reason, and there is no promise that patches will be accepted to lower the minimum required perl. =head1 METHODS =head2 upload_file CPAN::Uploader->upload_file($file, \%arg); $uploader->upload_file($file); Valid arguments are: user - (required) your CPAN / PAUSE id password - (required) your CPAN / PAUSE password subdir - the directory (under your home directory) to upload to http_proxy - uri of the http proxy to use upload_uri - uri of the upload handler; usually the default (PAUSE) is right debug - if set to true, spew lots more debugging output retries - number of retries to perform on upload failure (5xx response) retry_delay - number of seconds to wait between retries This method attempts to actually upload the named file to the CPAN. It will raise an exception on error. c can also be set through the ENV variable c. =head2 new my $uploader = CPAN::Uploader->new(\%arg); This method returns a new uploader. You probably don't need to worry about this method. Valid arguments are the same as those to C. =head2 read_config_file my $config = CPAN::Uploader->read_config_file( $filename ); This reads the config file and returns a hashref of its contents that can be used as configuration for CPAN::Uploader. If no filename is given, it looks for F<.pause> in the user's home directory (from the env var C, or the current directory if C isn't set). See L for the config format. =head2 log $uploader->log($message); This method logs the given string. The default behavior is to print it to the screen. The message should not end in a newline, as one will be added as needed. =head2 log_debug This method behaves like C>, but only logs the message if the CPAN::Uploader is in debug mode. =head1 ORIGIN This code is mostly derived from C by Brad Fitzpatrick, which in turn was based on C by Neil Bowers. I (I) didn't want to have to use a C call to run either of those, so I refactored the code into this module. =head1 AUTHOR Ricardo SIGNES =head1 CONTRIBUTORS =for stopwords Barbie Christian Walde David Caldwell Golden fREW Schmidt Gabor Szabo Graham Knop Karen Etheridge Kent Fredric Marcus Ramberg Mark Fowler Mike Doherty perlancar Ricardo Signes Shlomi Fish Steven Haryanto (on Asus Zenbook) sungo Thibault DUPONCHELLE Torsten Raudssus Vincent Pit =over 4 =item * Barbie =item * Christian Walde =item * David Caldwell =item * David Golden =item * fREW Schmidt =item * Gabor Szabo =item * Graham Knop =item * Karen Etheridge =item * Kent Fredric =item * Marcus Ramberg =item * Mark Fowler =item * Mike Doherty =item * perlancar =item * Ricardo Signes =item * Shlomi Fish =item * Steven Haryanto (on Asus Zenbook) =item * sungo =item * Thibault DUPONCHELLE =item * Torsten Raudssus =item * Vincent Pit =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2023 by Ricardo SIGNES. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut