File Coverage

lib/CPANPLUS/Selfupdate.pm
Criterion Covered Total %
statement 116 121 95.8
branch 27 40 67.5
condition 6 6 100.0
subroutine 24 24 100.0
pod 9 9 100.0
total 182 200 91.0


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