Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Selfupdate; |
2 | |
3 | use strict; |
4 | use Params::Check qw[check]; |
5 | use IPC::Cmd qw[can_run]; |
6 | use CPANPLUS::Error qw[error msg]; |
7 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
8 | |
9 | use CPANPLUS::Internals::Constants; |
10 | |
11 | $Params::Check::VERBOSE = 1; |
12 | |
13 | =head1 NAME |
14 | |
15 | CPANPLUS::Selfupdate |
16 | |
17 | =head1 SYNOPSIS |
18 | |
19 | $su = $cb->selfupdate_object; |
20 | |
21 | @feats = $su->list_features; |
22 | @feats = $su->list_enabled_features; |
23 | |
24 | @mods = map { $su->modules_for_feature( $_ ) } @feats; |
25 | @mods = $su->list_core_dependencies; |
26 | @mods = $su->list_core_modules; |
27 | |
28 | for ( @mods ) { |
29 | print $_->name " should be version " . $_->version_required; |
30 | print "Installed version is not uptodate!" |
31 | unless $_->is_installed_version_sufficient; |
32 | } |
33 | |
34 | $ok = $su->selfupdate( update => 'all', latest => 0 ); |
35 | |
36 | =cut |
37 | |
38 | ### a config has describing our deps etc |
39 | { |
40 | |
41 | my $Modules = { |
42 | dependencies => { |
43 | 'File::Fetch' => '0.08', # win32 ftp support |
44 | 'File::Spec' => '0.82', |
45 | 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open |
46 | 'Locale::Maketext::Simple' => '0.01', |
47 | 'Log::Message' => '0.01', |
48 | 'Module::Load' => '0.10', |
5bc5f6dc |
49 | 'Module::Load::Conditional' => '0.18', # Better parsing: #23995, |
50 | # uses version.pm for <=> |
6aaee015 |
51 | 'version' => '0.70', # needed for M::L::C |
52 | # addresses #24630 and |
53 | # #24675 |
54 | 'Params::Check' => '0.22', |
55 | 'Package::Constants' => '0.01', |
56 | 'Term::UI' => '0.05', |
57 | 'Test::Harness' => '2.62', # due to bug #19505 |
58 | # only 2.58 and 2.60 are bad |
59 | 'Test::More' => '0.47', # to run our tests |
60 | 'Archive::Extract' => '0.16', # ./Dir bug fix |
61 | 'Archive::Tar' => '1.23', |
62 | 'IO::Zlib' => '1.04', # needed for Archive::Tar |
63 | 'Object::Accessor' => '0.32', # overloaded stringification |
64 | 'Module::CoreList' => '2.09', |
65 | 'Module::Pluggable' => '2.4', |
66 | 'Module::Loaded' => '0.01', |
67 | }, |
68 | |
69 | features => { |
70 | # config_key_name => [ |
71 | # sub { } to list module key/value pairs |
72 | # sub { } to check if feature is enabled |
73 | # ] |
74 | prefer_makefile => [ |
75 | sub { |
76 | my $cb = shift; |
77 | $cb->configure_object->get_conf('prefer_makefile') |
78 | ? { } |
79 | : { 'CPANPLUS::Dist::Build' => '0.04' }; |
80 | }, |
81 | sub { return 1 }, # always enabled |
82 | ], |
83 | cpantest => [ |
84 | { |
5bc5f6dc |
85 | 'YAML::Tiny' => '0.0', |
86 | 'File::Fetch' => '0.08', |
87 | 'Test::Reporter' => '1.34', |
6aaee015 |
88 | }, |
89 | sub { |
90 | my $cb = shift; |
91 | return $cb->configure_object->get_conf('cpantest'); |
92 | }, |
93 | ], |
94 | dist_type => [ |
95 | sub { |
96 | my $cb = shift; |
97 | my $dist = $cb->configure_object->get_conf('dist_type'); |
98 | return { $dist => '0.0' } if $dist; |
99 | return; |
100 | }, |
101 | sub { |
102 | my $cb = shift; |
103 | return $cb->configure_object->get_conf('dist_type'); |
104 | }, |
105 | ], |
106 | |
107 | md5 => [ |
108 | { |
109 | 'Digest::MD5' => '0.0', |
110 | }, |
111 | sub { |
112 | my $cb = shift; |
113 | return $cb->configure_object->get_conf('md5'); |
114 | }, |
115 | ], |
116 | shell => [ |
117 | sub { |
118 | my $cb = shift; |
119 | my $dist = $cb->configure_object->get_conf('shell'); |
494f1016 |
120 | |
121 | ### we bundle these shells, so don't bother having a dep |
122 | ### on them... If we don't do this, CPAN.pm actually detects |
123 | ### a recursive dependency and breaks (see #26077). |
124 | ### This is not an issue for CPANPLUS itself, it handles |
125 | ### it smartly. |
126 | return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC; |
6aaee015 |
127 | return { $dist => '0.0' } if $dist; |
128 | return; |
129 | }, |
130 | sub { return 1 }, |
131 | ], |
132 | signature => [ |
133 | sub { |
134 | my $cb = shift; |
502c7995 |
135 | return { |
136 | 'Module::Signature' => '0.06', |
137 | } if can_run('gpg'); |
138 | ### leave this out -- Crypt::OpenPGP is fairly |
139 | ### painful to install, and broken on some platforms |
140 | ### so we'll just always fall back to gpg. It may |
141 | ### issue a warning or 2, but that's about it. |
142 | ### this change due to this ticket: #26914 |
143 | # and $cb->configure_object->get_conf('prefer_bin'); |
144 | |
145 | return { |
146 | 'Crypt::OpenPGP' => '0.0', |
147 | 'Module::Signature' => '0.06', |
148 | }; |
6aaee015 |
149 | }, |
e3b7d412 |
150 | sub { |
6aaee015 |
151 | my $cb = shift; |
152 | return $cb->configure_object->get_conf('signature'); |
153 | }, |
154 | ], |
155 | storable => [ |
156 | { 'Storable' => '0.0' }, |
157 | sub { |
158 | my $cb = shift; |
159 | return $cb->configure_object->get_conf('storable'); |
160 | }, |
161 | ], |
162 | }, |
163 | core => { |
164 | 'CPANPLUS' => '0.0', |
165 | }, |
166 | }; |
167 | |
168 | sub _get_config { return $Modules } |
169 | } |
170 | |
171 | =head1 METHODS |
172 | |
173 | =head2 $self = CPANPLUS::Selfupdate->new( $backend_object ); |
174 | |
175 | Sets up a new selfupdate object. Called automatically when |
176 | a new backend object is created. |
177 | |
178 | =cut |
179 | |
180 | sub new { |
181 | my $class = shift; |
182 | my $cb = shift or return; |
183 | return bless sub { $cb }, $class; |
184 | } |
185 | |
186 | |
622d31ac |
187 | { ### cache to find the relevant modules |
188 | my $cache = { |
189 | core |
190 | => sub { my $self = shift; |
191 | core => [ $self->list_core_modules ] }, |
192 | |
193 | dependencies |
194 | => sub { my $self = shift; |
195 | dependencies => [ $self->list_core_dependencies ] }, |
196 | |
197 | enabled_features |
198 | => sub { my $self = shift; |
199 | map { $_ => [ $self->modules_for_feature( $_ ) ] } |
200 | $self->list_enabled_features |
201 | }, |
202 | features |
203 | => sub { my $self = shift; |
204 | map { $_ => [ $self->modules_for_feature( $_ ) ] } |
205 | $self->list_features |
206 | }, |
207 | ### make sure to do 'core' first, in case |
208 | ### we are out of date ourselves |
209 | all => [ qw|core dependencies enabled_features| ], |
210 | }; |
211 | |
212 | |
213 | =head2 @cat = $self->list_categories |
214 | |
215 | Returns a list of categories that the C<selfupdate> method accepts. |
216 | |
217 | See C<selfupdate> for details. |
218 | |
219 | =cut |
220 | |
221 | sub list_categories { return sort keys %$cache } |
222 | |
223 | =head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] ) |
224 | |
225 | List which modules C<selfupdate> would upgrade. You can update either |
226 | the core (CPANPLUS itself), the core dependencies, all features you have |
227 | currently turned on, or all features available, or everything. |
228 | |
229 | The C<latest> option determines whether it should update to the latest |
230 | version on CPAN, or if the minimal required version for CPANPLUS is |
231 | good enough. |
232 | |
233 | Returns a hash of feature names and lists of module objects to be |
234 | upgraded based on the category you provided. For example: |
235 | |
236 | %list = $self->list_modules_to_update( update => 'core' ); |
237 | |
238 | Would return: |
239 | |
240 | ( core => [ $module_object_for_cpanplus ] ); |
241 | |
242 | =cut |
243 | |
244 | sub list_modules_to_update { |
245 | my $self = shift; |
246 | my $cb = $self->(); |
247 | my $conf = $cb->configure_object; |
248 | my %hash = @_; |
249 | |
250 | my($type, $latest); |
251 | my $tmpl = { |
252 | update => { required => 1, store => \$type, |
253 | allow => [ keys %$cache ], }, |
254 | latest => { default => 0, store => \$latest, allow => BOOLEANS }, |
255 | }; |
256 | |
257 | { local $Params::Check::ALLOW_UNKNOWN = 1; |
258 | check( $tmpl, \%hash ) or return; |
259 | } |
260 | |
261 | my $ref = $cache->{$type}; |
6aaee015 |
262 | |
622d31ac |
263 | ### a list of ( feature1 => \@mods, feature2 => \@mods, etc ) |
264 | my %list = UNIVERSAL::isa( $ref, 'ARRAY' ) |
265 | ? map { $cache->{$_}->( $self ) } @$ref |
266 | : $ref->( $self ); |
267 | |
268 | ### filter based on whether we need the latest ones or not |
269 | for my $aref ( values %list ) { |
270 | $aref = [ $latest |
271 | ? grep { !$_->is_uptodate } @$aref |
272 | : grep { !$_->is_installed_version_sufficient } @$aref |
273 | ]; |
274 | } |
275 | |
276 | return %list; |
277 | } |
278 | |
279 | =head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", [latest => BOOL, force => BOOL] ) |
6aaee015 |
280 | |
281 | Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself), |
282 | the core dependencies, all features you have currently turned on, or |
283 | all features available, or everything. |
284 | |
285 | The C<latest> option determines whether it should update to the latest |
286 | version on CPAN, or if the minimal required version for CPANPLUS is |
287 | good enough. |
288 | |
289 | Returns true on success, false on error. |
290 | |
291 | =cut |
292 | |
622d31ac |
293 | sub selfupdate { |
294 | my $self = shift; |
295 | my $cb = $self->(); |
296 | my $conf = $cb->configure_object; |
297 | my %hash = @_; |
6aaee015 |
298 | |
622d31ac |
299 | my $force; |
300 | my $tmpl = { |
301 | force => { default => $conf->get_conf('force'), store => \$force }, |
302 | }; |
6aaee015 |
303 | |
622d31ac |
304 | { local $Params::Check::ALLOW_UNKNOWN = 1; |
305 | check( $tmpl, \%hash ) or return; |
6aaee015 |
306 | } |
6aaee015 |
307 | |
622d31ac |
308 | my %list = $self->list_modules_to_update( %hash ) or return; |
309 | |
310 | ### just the modules please |
311 | my @mods = map { @$_ } values %list; |
312 | |
313 | my $flag; |
314 | for my $mod ( @mods ) { |
315 | unless( $mod->install( force => $force ) ) { |
316 | $flag++; |
317 | error(loc("Failed to update module '%1'", $mod->name)); |
318 | } |
319 | } |
320 | |
321 | return if $flag; |
322 | return 1; |
323 | } |
324 | |
325 | } |
6aaee015 |
326 | |
327 | =head2 @features = $self->list_features |
328 | |
329 | Returns a list of features that are supported by CPANPLUS. |
330 | |
331 | =cut |
332 | |
333 | sub list_features { |
334 | my $self = shift; |
335 | return keys %{ $self->_get_config->{'features'} }; |
336 | } |
337 | |
338 | =head2 @features = $self->list_enabled_features |
339 | |
340 | Returns a list of features that are enabled in your current |
341 | CPANPLUS installation. |
342 | |
343 | =cut |
344 | |
345 | sub list_enabled_features { |
346 | my $self = shift; |
347 | my $cb = $self->(); |
348 | |
349 | my @enabled; |
350 | for my $feat ( $self->list_features ) { |
351 | my $ref = $self->_get_config->{'features'}->{$feat}->[1]; |
352 | push @enabled, $feat if $ref->($cb); |
353 | } |
354 | |
355 | return @enabled; |
356 | } |
357 | |
358 | =head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] ) |
359 | |
360 | Returns a list of C<CPANPLUS::Selfupdate::Module> objects which |
361 | represent the modules required to support this feature. |
362 | |
363 | For a list of features, call the C<list_features> method. |
364 | |
365 | If the C<AS_HASH> argument is provided, no module objects are |
366 | returned, but a hashref where the keys are names of the modules, |
367 | and values are their minimum versions. |
368 | |
369 | =cut |
370 | |
371 | sub modules_for_feature { |
372 | my $self = shift; |
373 | my $feature = shift or return; |
374 | my $as_hash = shift || 0; |
375 | my $cb = $self->(); |
376 | |
377 | unless( exists $self->_get_config->{'features'}->{$feature} ) { |
378 | error(loc("Unknown feature '%1'", $feature)); |
379 | return; |
380 | } |
381 | |
382 | my $ref = $self->_get_config->{'features'}->{$feature}->[0]; |
383 | |
384 | ### it's either a list of modules/versions or a subroutine that |
385 | ### returns a list of modules/versions |
386 | my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb ); |
387 | |
388 | return unless $href; # nothing needed for the feature? |
389 | |
390 | return $href if $as_hash; |
391 | return $self->_hashref_to_module( $href ); |
392 | } |
393 | |
394 | |
395 | =head2 @mods = $self->list_core_dependencies( [AS_HASH] ) |
396 | |
397 | Returns a list of C<CPANPLUS::Selfupdate::Module> objects which |
398 | represent the modules that comprise the core dependencies of CPANPLUS. |
399 | |
400 | If the C<AS_HASH> argument is provided, no module objects are |
401 | returned, but a hashref where the keys are names of the modules, |
402 | and values are their minimum versions. |
403 | |
404 | =cut |
405 | |
406 | sub list_core_dependencies { |
407 | my $self = shift; |
408 | my $as_hash = shift || 0; |
409 | my $cb = $self->(); |
410 | my $href = $self->_get_config->{'dependencies'}; |
411 | |
412 | return $href if $as_hash; |
413 | return $self->_hashref_to_module( $href ); |
414 | } |
415 | |
416 | =head2 @mods = $self->list_core_modules( [AS_HASH] ) |
417 | |
418 | Returns a list of C<CPANPLUS::Selfupdate::Module> objects which |
419 | represent the modules that comprise the core of CPANPLUS. |
420 | |
421 | If the C<AS_HASH> argument is provided, no module objects are |
422 | returned, but a hashref where the keys are names of the modules, |
423 | and values are their minimum versions. |
424 | |
425 | =cut |
426 | |
427 | sub list_core_modules { |
428 | my $self = shift; |
429 | my $as_hash = shift || 0; |
430 | my $cb = $self->(); |
431 | my $href = $self->_get_config->{'core'}; |
432 | |
433 | return $href if $as_hash; |
434 | return $self->_hashref_to_module( $href ); |
435 | } |
436 | |
437 | sub _hashref_to_module { |
438 | my $self = shift; |
439 | my $cb = $self->(); |
440 | my $href = shift or return; |
441 | |
442 | return map { |
443 | CPANPLUS::Selfupdate::Module->new( |
444 | $cb->module_tree($_) => $href->{$_} |
445 | ) |
446 | } keys %$href; |
447 | } |
448 | |
449 | |
450 | =head1 CPANPLUS::Selfupdate::Module |
451 | |
452 | C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects |
453 | by providing accessors to aid in selfupdating CPANPLUS. |
454 | |
455 | These objects are returned by all methods of C<CPANPLUS::Selfupdate> |
456 | that return module objects. |
457 | |
458 | =cut |
459 | |
460 | { package CPANPLUS::Selfupdate::Module; |
461 | use base 'CPANPLUS::Module'; |
462 | |
463 | ### stores module name -> cpanplus required version |
464 | ### XXX only can deal with 1 pair! |
465 | my %Cache = (); |
466 | my $Acc = 'version_required'; |
467 | |
468 | sub new { |
469 | my $class = shift; |
470 | my $mod = shift or return; |
471 | my $ver = shift; return unless defined $ver; |
472 | |
473 | my $obj = $mod->clone; # clone the module object |
474 | bless $obj, $class; # rebless it to our class |
475 | |
476 | $obj->$Acc( $ver ); |
477 | |
478 | return $obj; |
479 | } |
480 | |
481 | =head2 $version = $mod->version_required |
482 | |
483 | Returns the version of this module required for CPANPLUS. |
484 | |
485 | =cut |
486 | |
487 | sub version_required { |
488 | my $self = shift; |
489 | $Cache{ $self->name } = shift() if @_; |
490 | return $Cache{ $self->name }; |
491 | } |
492 | |
493 | =head2 $bool = $mod->is_installed_version_sufficient |
494 | |
495 | Returns true if the installed version of this module is sufficient |
496 | for CPANPLUS, or false if it is not. |
497 | |
498 | =cut |
499 | |
500 | |
501 | sub is_installed_version_sufficient { |
502 | my $self = shift; |
503 | return $self->is_uptodate( version => $self->$Acc ); |
504 | } |
505 | |
506 | } |
507 | |
508 | 1; |
509 | |
510 | =pod |
511 | |
512 | =head1 BUG REPORTS |
513 | |
514 | Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. |
515 | |
516 | =head1 AUTHOR |
517 | |
518 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
519 | |
520 | =head1 COPYRIGHT |
521 | |
522 | The CPAN++ interface (of which this module is a part of) is copyright (c) |
523 | 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. |
524 | |
525 | This library is free software; you may redistribute and/or modify it |
526 | under the same terms as Perl itself. |
527 | |
528 | =cut |
529 | |
530 | # Local variables: |
531 | # c-indentation-style: bsd |
532 | # c-basic-offset: 4 |
533 | # indent-tabs-mode: nil |
534 | # End: |
535 | # vim: expandtab shiftwidth=4: |