File Coverage

lib/Module/Provision/TraitFor/CPANDistributions.pm
Criterion Covered Total %
statement 34 73 46.5
branch 1 10 10.0
condition 0 12 0.0
subroutine 12 16 75.0
pod 4 4 100.0
total 51 115 44.3


line stmt bran cond sub pod time code
1             package Module::Provision::TraitFor::CPANDistributions;
2              
3 1     1   413 use namespace::autoclean;
  1         1  
  1         4  
4              
5 1     1   52 use Class::Usul::Constants qw( EXCEPTION_CLASS FALSE NUL OK TRUE );
  1         1  
  1         5  
6 1         55 use Class::Usul::Crypt::Util qw( decrypt_from_config encrypt_for_config
7 1     1   890 is_encrypted );
  1         7791  
8 1     1   5 use Class::Usul::Functions qw( ensure_class_loaded throw );
  1         1  
  1         3  
9 1     1   404 use Class::Usul::Types qw( NonEmptySimpleStr );
  1         1  
  1         5  
10 1     1   367 use English qw( -no_match_vars );
  1         1  
  1         4  
11 1     1   700 use HTTP::Request::Common qw( POST );
  1         15579  
  1         49  
12 1     1   383 use HTTP::Status;
  1         2505  
  1         193  
13 1     1   5 use Scalar::Util qw( blessed );
  1         1  
  1         41  
14 1     1   4 use Unexpected::Functions qw( PathNotFound Unspecified );
  1         1  
  1         7  
15 1     1   272 use Moo::Role;
  1         1  
  1         6  
16              
17             requires qw( add_leader config debug distname dist_version dumper
18             info loc log next_argv output run_cmd yorn );
19              
20             # Private attributes
21             has '_debug_http_method' => is => 'ro', isa => NonEmptySimpleStr,
22             builder => sub { $ENV{CPAN_DELETE_FILES_DISPLAY_HTTP_BODY}
23 1 50   1   46225 ? 'as_string' : 'headers_as_string' };
24              
25             # Private methods
26             my $_convert_versions_to_paths = sub {
27             my ($self, $versions, $args) = @_; my $paths = []; $args //= {};
28              
29             my $distname = $self->distname;
30             my $subdir = $args->{subdir} ? $args->{subdir}.'/' : NUL;
31              
32             for my $version (@{ $versions // [] }) {
33             for my $extn (qw(meta readme tar.gz)) {
34             push @{ $paths }, "${subdir}${distname}-${version}.${extn}";
35             }
36             }
37              
38             return $paths;
39             };
40              
41             my $_dist_path = sub {
42             my ($self, $ver) = @_; my $file;
43              
44             if ($ver) { $file = $self->distname."-${ver}.tar.gz" }
45             else {
46             $file = $self->distname.'-'.$self->dist_version.'.tar.gz';
47             -f $file or $file = $self->distname.'-v'.$self->dist_version.'.tar.gz';
48             }
49              
50             -f $file or throw PathNotFound, [ $file ];
51              
52             return $file
53             };
54              
55             my $_log_http_debug = sub {
56             my ($self, $type, $obj, $msg) = @_; $self->debug or return;
57              
58             my $method = $self->_debug_http_method;
59              
60             $self->log->debug( $_ ) for ( $msg ? $msg : (),
61             "----- ${type} BEGIN -----\n",
62             $obj->$method()."\n",
63             "----- ${type} END -------\n" );
64             return;
65             };
66              
67             my $_read_rc_file = sub {
68             my $self = shift; my $conf = $self->config; my $attr = {};
69              
70             for ($conf->my_home->catfile( '.pause' )->chomp->getlines) {
71             ($_ and $_ !~ m{ \A \s* \# }mx) or next;
72              
73             my ($k, $v) = m{ \A \s* (\w+) (?: \s+ (.+))? \z }mx;
74              
75             exists $attr->{ $k } and throw 'Multiple entries for [_1]', [ $k ];
76             $attr->{ $k } = $v // NUL;
77             }
78              
79             my $pword; exists $attr->{password}
80             and $pword = $attr->{password}
81             and is_encrypted $pword
82             and $attr->{password} = decrypt_from_config $conf, $pword;
83              
84             return $attr;
85             };
86              
87             my $_ua_string = sub {
88             my $self = shift;
89             my $class = blessed $self || $self;
90             my $ver = $class->VERSION // 'dev';
91              
92             return "${class}/${ver}";
93             };
94              
95             my $_write_rc_file = sub {
96             my ($self, $attr) = @_; my $conf = $self->config;
97              
98             my $file = $conf->my_home->catfile( '.pause' );
99              
100             $attr->{password} = encrypt_for_config $conf, $attr->{password};
101              
102             $file->println( "${_} ".$attr->{ $_ } ) for (sort keys %{ $attr });
103              
104             return;
105             };
106              
107             my $_get_delete_request = sub {
108             my ($self, $files, $args, $uri) = @_;
109              
110             my @body = ( HIDDENNAME => $args->{user},
111             SUBMIT_pause99_delete_files_delete => 'Delete', );
112              
113             for my $file (@{ $files }) {
114             push @body, 'pause99_delete_files_FILE', $file;
115             }
116              
117             my $request = POST( $uri, \@body );
118              
119             $request->authorization_basic( $args->{user}, $args->{password} );
120             $self->$_log_http_debug( 'REQUEST', $request );
121             return $request;
122             };
123              
124             my $_throw_on_error = sub {
125             my ($self, $uri, $target, $response) = @_;
126              
127             defined $response
128             or throw 'Request completely failed - we got undef back: [_1]',
129             [ $OS_ERROR ];
130              
131             if ($response->is_error) {
132             my $class = blessed $self || $self;
133              
134             $response->code == RC_NOT_FOUND and throw
135             "PAUSE's CGI for handling messages seems to have moved!\n".
136             "(HTTP response code of 404 from the [_1] web server)\n".
137             "It used to be: [_2]\nPlease inform the maintainer of [_3]\n",
138             [ $target, $uri, $class ];
139              
140             throw "Request failed error code [_1]\n Message: [_2]\n",
141             [ $response->code, $response->message ];
142             }
143              
144             $self->$_log_http_debug( 'RESPONSE', $response, 'Looks OK!' );
145             $self->info( '[_1] delete request sent ok [[_2]]',
146             { args => [ $target, $response->code ] } );
147             return;
148             };
149              
150             my $_delete_files = sub {
151             my ($self, $files, $args) = @_; my $target = $args->{target} || 'PAUSE';
152              
153             $self->info( 'Registering to delete files with the [_1] web server',
154             { args => [ $target ] } );
155              
156             ensure_class_loaded( 'LWP::UserAgent' );
157              
158             my $agent = LWP::UserAgent->new;
159              
160             $agent->agent( $self->$_ua_string ); $agent->env_proxy;
161             $args->{http_proxy} and $agent->proxy( http => $args->{http_proxy} );
162              
163             my $uri = $args->{delete_files_uri} // $self->config->delete_files_uri;
164             my $request = $self->$_get_delete_request( $files, $args, $uri );
165              
166             $self->info( 'POSTing delete files request to [_1]', { args => [ $uri ] } );
167             $self->$_throw_on_error( $uri, $target, $agent->request( $request ) );
168             return;
169             };
170              
171             # Public methods
172             sub cpan_upload : method {
173 0   0 0 1   my ($self, $ver) = @_; $ver //= $self->next_argv;
  0            
174              
175 0           my $file = $self->$_dist_path( $ver );
176 0   0       my $args = $self->$_read_rc_file; $args->{subdir} //= lc $self->distname;
  0            
177 0           my $prompt = $self->add_leader( $self->loc( 'Really upload to CPAN' ) );
178              
179             exists $args->{dry_run}
180 0 0         or $args->{dry_run} = not $self->yorn( $prompt, FALSE, TRUE, 0 );
181              
182 0           ensure_class_loaded( 'CPAN::Uploader' );
183              
184 0           CPAN::Uploader->upload_file( $file, $args );
185 0           return OK;
186             }
187              
188             sub delete_cpan_files : method {
189 0     0 1   my $self = shift;
190 0   0       my $args = $self->$_read_rc_file; $args->{subdir} //= lc $self->distname;
  0            
191 0           my $files = $self->$_convert_versions_to_paths( $self->extra_argv, $args );
192 0           my $prompt = $self->loc( 'Really delete files from CPAN' );
193 0           $prompt = $self->add_leader( $prompt );
194              
195             exists $args->{dry_run}
196 0 0         or $args->{dry_run} = not $self->yorn( $prompt, FALSE, TRUE, 0 );
197              
198 0 0         if ($args->{dry_run}) {
199 0           $self->output( 'By request, cowardly refusing to do anything at all' );
200 0           $self->output( "The following would have been used to delete files:\n" );
201 0           $self->dumper( $args );
202 0           $self->dumper( $files );
203             }
204 0           else { $self->$_delete_files( $files, $args ) }
205              
206 0           return OK;
207             }
208              
209             sub set_cpan_password : method {
210 0     0 1   my $self = shift; my $args = $self->$_read_rc_file;
  0            
211              
212 0 0         $args->{password} = $self->next_argv or throw Unspecified, [ 'password' ];
213 0           $self->$_write_rc_file( $args );
214 0           return OK;
215             }
216              
217             sub test_upload : method {
218 0   0 0 1   my ($self, $ver) = @_; $ver //= $self->next_argv;
  0            
219              
220 0           my $conf = $self->config;
221 0           my $id = $conf->remote_test_id;
222 0           my $script = $conf->remote_script;
223 0           my $file = $self->$_dist_path( $ver );
224 0           my $args = { in => 'stdin', out => 'stdout', };
225              
226 0           $self->run_cmd( [ 'scp', $file, "${id}:/tmp" ] );
227 0           $self->run_cmd( [ 'ssh', '-t', $id, "${script} ${file}" ], $args );
228              
229 0           return OK;
230             }
231              
232             1;
233              
234             __END__
235              
236             =pod
237              
238             =encoding utf8
239              
240             =head1 Name
241              
242             Module::Provision::TraitFor::CPANDistributions - Uploads/Deletes distributions to/from CPAN
243              
244             =head1 Synopsis
245              
246             use Moose;
247              
248             extends 'Module::Provision::Base';
249             with 'Module::Provision::TraitFor::CPANDistributions';
250              
251             =head1 Description
252              
253             Uploads/Deletes distributions to/from CPAN
254              
255             =head1 Configuration and Environment
256              
257             Reads PAUSE account data from F<~/.pause>
258              
259             Defines no attributes
260              
261             =head1 Subroutines/Methods
262              
263             =head2 cpan_upload - Uploads a distribution to CPAN
264              
265             $exit_code = $self->cpan_upload;
266              
267             Uses L<CPAN::Uploader> to do the heavy lifting
268              
269             =head2 delete_cpan_files - Deletes a distribution from CPAN
270              
271             $exit_code = $self->delete_cpan_files;
272              
273             You must specify the version of the distribution to delete
274              
275             =head2 test_upload - Upload and install distribution on the test server
276              
277             $exit_code = $self->test_upload;
278              
279             Upload and install distribution on the test server
280              
281             =head2 set_cpan_password - Set the PAUSE server password
282              
283             $exit_code = $self->set_cpan_password;
284              
285             Sets the password used to connect to the PAUSE server. Once used the
286             command line program C<cpan-upload> will not work since it cannot
287             decrypt the password in the configuration file F<~/.pause>
288              
289             =head1 Diagnostics
290              
291             None
292              
293             =head1 Dependencies
294              
295             =over 3
296              
297             =item L<Class::Usul>
298              
299             =item L<CPAN::Uploader>
300              
301             =item L<HTTP::Message>
302              
303             =item L<LWP::UserAgent>
304              
305             =item L<Moose::Role>
306              
307             =back
308              
309             =head1 Incompatibilities
310              
311             There are no known incompatibilities in this module
312              
313             =head1 Bugs and Limitations
314              
315             There are no known bugs in this module.
316             Please report problems to the address below.
317             Patches are welcome
318              
319             =head1 Acknowledgements
320              
321             Larry Wall - For the Perl programming language
322              
323             =head1 Author
324              
325             Peter Flanigan, C<< <pjfl@cpan.org> >>
326              
327             =head1 License and Copyright
328              
329             Copyright (c) 2016 Peter Flanigan. All rights reserved
330              
331             This program is free software; you can redistribute it and/or modify it
332             under the same terms as Perl itself. See L<perlartistic>
333              
334             This program is distributed in the hope that it will be useful,
335             but WITHOUT WARRANTY; without even the implied warranty of
336             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
337              
338             =cut
339              
340             # Local Variables:
341             # mode: perl
342             # tab-width: 3
343             # End: