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


line stmt bran cond sub pod time code
1 1     1   72349 use strict;
  1         3  
  1         31  
2 1     1   6 use warnings;
  1         2  
  1         41  
3             package CPAN::Uploader 0.103016;
4             # ABSTRACT: upload things to the CPAN
5              
6             #pod =head1 ORIGIN
7             #pod
8             #pod This code is mostly derived from C by Brad Fitzpatrick, which
9             #pod in turn was based on C by Neil Bowers. I (I) didn't want to
10             #pod have to use a C call to run either of those, so I refactored the code
11             #pod into this module.
12             #pod
13             #pod =cut
14              
15 1     1   6 use Carp ();
  1         3  
  1         13  
16 1     1   4 use File::Basename ();
  1         2  
  1         14  
17 1     1   7 use File::Spec;
  1         1  
  1         41  
18 1     1   593 use HTTP::Request::Common qw(POST);
  1         23863  
  1         63  
19 1     1   560 use HTTP::Status;
  1         4812  
  1         257  
20 1     1   764 use LWP::UserAgent;
  1         22082  
  1         1644  
21              
22             my $UPLOAD_URI = $ENV{CPAN_UPLOADER_UPLOAD_URI}
23             || 'https://pause.perl.org/pause/authenquery?ACTION=add_uri';
24              
25             #pod =method upload_file
26             #pod
27             #pod CPAN::Uploader->upload_file($file, \%arg);
28             #pod
29             #pod $uploader->upload_file($file);
30             #pod
31             #pod Valid arguments are:
32             #pod
33             #pod user - (required) your CPAN / PAUSE id
34             #pod password - (required) your CPAN / PAUSE password
35             #pod subdir - the directory (under your home directory) to upload to
36             #pod http_proxy - uri of the http proxy to use
37             #pod upload_uri - uri of the upload handler; usually the default (PAUSE) is right
38             #pod debug - if set to true, spew lots more debugging output
39             #pod retries - number of retries to perform on upload failure (5xx response)
40             #pod retry_delay - number of seconds to wait between retries
41             #pod
42             #pod This method attempts to actually upload the named file to the CPAN. It will
43             #pod raise an exception on error. c can also be set through the ENV
44             #pod variable c.
45             #pod
46             #pod =cut
47              
48             sub upload_file {
49 0     0 1   my ($self, $file, $arg) = @_;
50              
51 0 0 0       Carp::confess(q{don't supply %arg when calling upload_file on an object})
52             if $arg and ref $self;
53              
54 0 0         Carp::confess(q{attempted to upload a non-file}) unless -f $file;
55              
56             # class call with no args is no good
57 0 0 0       Carp::confess(q{need to supply %arg when calling upload_file from the class})
58             if not (ref $self) and not $arg;
59              
60 0 0         $self = $self->new($arg) if $arg;
61              
62 0 0         if ($arg->{dry_run}) {
63 0           require Data::Dumper;
64 0           $self->log("By request, cowardly refusing to do anything at all.");
65 0           $self->log(
66             "The following arguments would have been used to upload: \n"
67             . '$self: ' . Data::Dumper::Dumper($self)
68             . '$file: ' . Data::Dumper::Dumper($file)
69             );
70             } else {
71 0   0       my $retries = $self->{retries} || 0;
72 0 0         my $tries = ($retries > 0) ? $retries + 1 : 1;
73              
74 0           TRY: for my $try (1 .. $tries) {
75 0 0         last TRY if eval { $self->_upload($file); 1 };
  0            
  0            
76 0 0         die $@ unless $@ !~ /request failed with error code 5/;
77              
78 0 0         if ($try <= $tries) {
79 0           $self->log("Upload failed ($@)");
80 0 0 0       if ($tries and ($try < $tries)) {
81 0           my $next_try = $try + 1;
82 0           $self->log("Will make attempt #$next_try ...");
83             }
84 0 0         sleep $self->{retry_delay} if $self->{retry_delay};
85             }
86 0 0         if ($try >= $tries) {
87 0           die "Failed to upload and reached maximum retry count!\n";
88             }
89             }
90             }
91             }
92              
93             sub _ua_string {
94 0     0     my ($self) = @_;
95 0   0       my $class = ref $self || $self;
96 0 0         my $version = defined $class->VERSION ? $class->VERSION : 'dev';
97              
98 0           return "$class/$version";
99             }
100              
101 0 0   0 0   sub uri { shift->{upload_uri} || $UPLOAD_URI }
102 0 0   0 0   sub target { shift->{target} || 'PAUSE' }
103              
104             sub _upload {
105 0     0     my $self = shift;
106 0           my $file = shift;
107              
108 0           $self->log("registering upload with " . $self->target . " web server");
109              
110 0           my $agent = LWP::UserAgent->new;
111 0           $agent->agent( $self->_ua_string );
112              
113 0           $agent->env_proxy;
114 0 0         $agent->proxy(http => $self->{http_proxy}) if $self->{http_proxy};
115              
116 0   0       my $uri = $self->{upload_uri} || $UPLOAD_URI;
117              
118 0           my $type = 'form-data';
119             my %content = (
120             HIDDENNAME => $self->{user},
121 0 0         ($self->{subdir} ? (pause99_add_uri_subdirtext => $self->{subdir}) : ()),
122             );
123              
124 0 0         if ($file =~ m{^https?://}) {
125 0           $type = 'application/x-www-form-urlencoded';
126 0           %content = (
127             %content,
128             pause99_add_uri_httpupload => '',
129             pause99_add_uri_uri => $file,
130             SUBMIT_pause99_add_uri_uri => " Upload this URL ",
131             );
132             } else {
133 0           %content = (
134             %content,
135             CAN_MULTIPART => 1,
136             pause99_add_uri_upload => File::Basename::basename($file),
137             pause99_add_uri_httpupload => [ $file ],
138             pause99_add_uri_uri => '',
139             SUBMIT_pause99_add_uri_httpupload => " Upload this file from my disk ",
140             );
141             }
142              
143 0           my $request = POST(
144             $uri,
145             Content_Type => $type,
146             Content => \%content,
147             );
148              
149 0           $request->authorization_basic($self->{user}, $self->{password});
150              
151             my $DEBUG_METHOD = $ENV{CPAN_UPLOADER_DISPLAY_HTTP_BODY}
152 0 0         ? 'as_string'
153             : 'headers_as_string';
154              
155 0           $self->log_debug(
156             "----- REQUEST BEGIN -----\n" .
157             $request->$DEBUG_METHOD . "\n" .
158             "----- REQUEST END -------\n"
159             );
160              
161             # Make the request to the PAUSE web server
162 0           $self->log("POSTing upload for $file to $uri");
163 0           my $response = $agent->request($request);
164              
165             # So, how'd we do?
166 0 0         if (not defined $response) {
167 0           die "Request completely failed - we got undef back: $!";
168             }
169              
170 0 0         if ($response->is_error) {
171 0 0         if ($response->code == RC_NOT_FOUND) {
172 0           die "PAUSE's CGI for handling messages seems to have moved!\n",
173             "(HTTP response code of 404 from the ", $self->target, " web server)\n",
174             "It used to be: ", $uri, "\n",
175             "Please inform the maintainer of $self.\n";
176             } else {
177 0           die "request failed with error code ", $response->code,
178             "\n Message: ", $response->message, "\n";
179             }
180             } else {
181 0           $self->log_debug($_) for (
182             "Looks OK!",
183             "----- RESPONSE BEGIN -----\n" .
184             $response->$DEBUG_METHOD . "\n" .
185             "----- RESPONSE END -------\n"
186             );
187              
188 0           $self->log($self->target . " add message sent ok [" . $response->code . "]");
189             }
190             }
191              
192              
193             #pod =method new
194             #pod
195             #pod my $uploader = CPAN::Uploader->new(\%arg);
196             #pod
197             #pod This method returns a new uploader. You probably don't need to worry about
198             #pod this method.
199             #pod
200             #pod Valid arguments are the same as those to C.
201             #pod
202             #pod =cut
203              
204             sub new {
205 0     0 1   my ($class, $arg) = @_;
206              
207 0   0       $arg->{$_} or Carp::croak("missing $_ argument") for qw(user password);
208 0           bless $arg => $class;
209             }
210              
211             #pod =method read_config_file
212             #pod
213             #pod my $config = CPAN::Uploader->read_config_file( $filename );
214             #pod
215             #pod This reads the config file and returns a hashref of its contents that can be
216             #pod used as configuration for CPAN::Uploader.
217             #pod
218             #pod If no filename is given, it looks for F<.pause> in the user's home directory
219             #pod (from the env var C, or the current directory if C isn't set).
220             #pod
221             #pod See L for the config format.
222             #pod
223             #pod =cut
224              
225             sub read_config_file {
226 0     0 1   my ($class, $filename) = @_;
227              
228 0 0         unless (defined $filename) {
229             my $home = $^O eq 'MSWin32' && "$]" < 5.016
230             ? $ENV{HOME} || $ENV{USERPROFILE}
231 0 0 0       : (<~>)[0];
      0        
232 0           $filename = File::Spec->catfile($home, '.pause');
233              
234 0 0 0       return {} unless -e $filename and -r _;
235             }
236              
237 0           my %conf;
238 0 0         if ( eval { require Config::Identity } ) {
  0            
239 0           %conf = Config::Identity->load($filename);
240 0 0         $conf{user} = delete $conf{username} unless $conf{user};
241             }
242             else { # Process .pause manually
243 0 0         open my $pauserc, '<', $filename
244             or die "can't open $filename for reading: $!";
245              
246 0           while (<$pauserc>) {
247 0           chomp;
248 0 0         if (/BEGIN PGP MESSAGE/ ) {
249 0           Carp::croak "$filename seems to be encrypted. "
250             . "Maybe you need to install Config::Identity?"
251             }
252              
253 0 0 0       next unless $_ and $_ !~ /^\s*#/;
254              
255 0           my ($k, $v) = /^\s*(\w+)\s+(.+)$/;
256 0 0         Carp::croak "multiple entries for $k" if $conf{$k};
257 0           $conf{$k} = $v;
258             }
259             }
260              
261             # minimum validation of arguments
262             Carp::croak "Configured user has trailing whitespace"
263 0 0 0       if defined $conf{user} && $conf{user} =~ /\s$/;
264             Carp::croak "Configured user contains whitespace"
265 0 0 0       if defined $conf{user} && $conf{user} =~ /\s/;
266              
267 0           return \%conf;
268             }
269              
270             #pod =method log
271             #pod
272             #pod $uploader->log($message);
273             #pod
274             #pod This method logs the given string. The default behavior is to print it to the
275             #pod screen. The message should not end in a newline, as one will be added as
276             #pod needed.
277             #pod
278             #pod =cut
279              
280             sub log {
281 0     0 1   shift;
282 0           print "$_[0]\n"
283             }
284              
285             #pod =method log_debug
286             #pod
287             #pod This method behaves like C>, but only logs the message if the
288             #pod CPAN::Uploader is in debug mode.
289             #pod
290             #pod =cut
291              
292             sub log_debug {
293 0     0 1   my $self = shift;
294 0 0         return unless $self->{debug};
295 0           $self->log($_[0]);
296             }
297              
298             1;
299              
300             __END__