<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package CPANPLUS::Selfupdate;

use strict;
use Params::Check               qw[check];
use IPC::Cmd                    qw[can_run];
use CPANPLUS::Error             qw[error msg];
use Module::Load::Conditional   qw[check_install];
use Locale::Maketext::Simple    Class =&gt; 'CPANPLUS', Style =&gt; 'gettext';

use CPANPLUS::Internals::Constants;

$Params::Check::VERBOSE = 1;

=head1 NAME

CPANPLUS::Selfupdate

=head1 SYNOPSIS

    $su     = $cb-&gt;selfupdate_object;
    
    @feats  = $su-&gt;list_features;
    @feats  = $su-&gt;list_enabled_features;
    
    @mods   = map { $su-&gt;modules_for_feature( $_ ) } @feats;
    @mods   = $su-&gt;list_core_dependencies;
    @mods   = $su-&gt;list_core_modules;
    
    for ( @mods ) {
        print $_-&gt;name " should be version " . $_-&gt;version_required;
        print "Installed version is not uptodate!" 
            unless $_-&gt;is_installed_version_sufficient;
    }
    
    $ok     = $su-&gt;selfupdate( update =&gt; 'all', latest =&gt; 0 );

=cut

### a config has describing our deps etc
{

    my $Modules = {
        dependencies =&gt; {
            'File::Fetch'               =&gt; '0.15_02', # lynx &amp; 404 handling
            'File::Spec'                =&gt; '0.82',
            'IPC::Cmd'                  =&gt; '0.36', # 5.6.2 compat: 2-arg open
            'Locale::Maketext::Simple'  =&gt; '0.01',
            'Log::Message'              =&gt; '0.01',
            'Module::Load'              =&gt; '0.10',
            'Module::Load::Conditional' =&gt; '0.38', # returns dir for loaded
                                                   # modules
            'version'                   =&gt; '0.73', # needed for M::L::C
                                                   # addresses #24630 and 
                                                   # #24675
                                                   # Address ~0 overflow issue
            'Params::Check'             =&gt; '0.22',
            'Package::Constants'        =&gt; '0.01',
            'Term::UI'                  =&gt; '0.18', # option parsing
            'Test::Harness'             =&gt; '2.62', # due to bug #19505
                                                   # only 2.58 and 2.60 are bad
            'Test::More'                =&gt; '0.47', # to run our tests
            'Archive::Extract'          =&gt; '0.16', # ./Dir bug fix
            'Archive::Tar'              =&gt; '1.23',
            'IO::Zlib'                  =&gt; '1.04', # needed for Archive::Tar
            'Object::Accessor'          =&gt; '0.34', # mk_aliases support
            'Module::CoreList'          =&gt; '2.22', # deprecated core modules
            'Module::Pluggable'         =&gt; '2.4',
            'Module::Loaded'            =&gt; '0.01',
            'Parse::CPAN::Meta'         =&gt; '1.4200', # config_requires support
            'ExtUtils::Install'         =&gt; '1.42', # uninstall outside @INC
            ( check_install( module =&gt; 'CPANPLUS::Dist::Build' ) 
              ? ( 'CPANPLUS::Dist::Build' =&gt; '0.24' ) : () ),
        },
    
        features =&gt; {
            # config_key_name =&gt; [
            #     sub { } to list module key/value pairs
            #     sub { } to check if feature is enabled
            # ]
            prefer_makefile =&gt; [
                sub {
                    my $cb = shift;
                    $cb-&gt;configure_object-&gt;get_conf('prefer_makefile') 
                        ? { }
                        : { 'CPANPLUS::Dist::Build' =&gt; '0.24'  };
                },
                sub { return 1 },   # always enabled
            ],            
            cpantest        =&gt; [
                { 'Test::Reporter'  =&gt; '1.34',
                  'Parse::CPAN::Meta' =&gt; '1.4200'
                },
                sub { 
                    my $cb = shift;
                    return $cb-&gt;configure_object-&gt;get_conf('cpantest');
                },
            ],                
            dist_type =&gt; [
                sub { 
                    my $cb      = shift;
                    my $dist    = $cb-&gt;configure_object-&gt;get_conf('dist_type');
                    return { $dist =&gt; '0.0' } if $dist;
                    return;
                },            
                sub { 
                    my $cb = shift;
                    return $cb-&gt;configure_object-&gt;get_conf('dist_type');
                },
            ],

            md5 =&gt; [
                {
                    'Digest::SHA'   =&gt; '0.0',
                },            
                sub { 
                    my $cb = shift;
                    return $cb-&gt;configure_object-&gt;get_conf('md5');
                },
            ],
            shell =&gt; [
                sub { 
                    my $cb      = shift;
                    my $dist    = $cb-&gt;configure_object-&gt;get_conf('shell');
                    
                    ### we bundle these shells, so don't bother having a dep
                    ### on them... If we don't do this, CPAN.pm actually detects
                    ### a recursive dependency and breaks (see #26077).
                    ### This is not an issue for CPANPLUS itself, it handles
                    ### it smartly.
                    return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC;
                    return { $dist =&gt; '0.0' } if $dist;
                    return;
                },            
                sub { return 1 },
            ],                
            signature =&gt; [
                sub {
                    my $cb      = shift;
                    return {
                        'Module::Signature' =&gt; '0.06',
                    } if can_run('gpg');
                    ### leave this out -- Crypt::OpenPGP is fairly
                    ### painful to install, and broken on some platforms
                    ### so we'll just always fall back to gpg. It may
                    ### issue a warning or 2, but that's about it.
                    ### this change due to this ticket: #26914
                    # and $cb-&gt;configure_object-&gt;get_conf('prefer_bin');

                    return { 
                        'Crypt::OpenPGP'    =&gt; '0.0', 
                        'Module::Signature' =&gt; '0.06',
                    };
                },            
                sub {
                    my $cb = shift;
                    return $cb-&gt;configure_object-&gt;get_conf('signature');
                },
            ],
            storable =&gt; [
                { 'Storable' =&gt; '0.0' },         
                sub { 
                    my $cb = shift;
                    return $cb-&gt;configure_object-&gt;get_conf('storable');
                },
            ],
            sqlite_backend =&gt; [
                {   'DBIx::Simple' =&gt; '0.0',
                    'DBD::SQLite'  =&gt; '0.0',
                },
                sub {
                    my $cb   = shift;
                    my $conf = $cb-&gt;configure_object;
                    return $conf-&gt;get_conf('source_engine') 
                        eq 'CPANPLUS::Internals::Source::SQLite'
                },                        
            ],                    
        },
        core =&gt; {
            'CPANPLUS' =&gt; '0.0',
        },
    };

    sub _get_config { return $Modules }
}

=head1 METHODS

=head2 $self = CPANPLUS::Selfupdate-&gt;new( $backend_object );

Sets up a new selfupdate object. Called automatically when
a new backend object is created.

=cut

sub new {
    my $class = shift;
    my $cb    = shift or return;
    return bless sub { $cb }, $class;
}    


{   ### cache to find the relevant modules
    my $cache = {
        core 
            =&gt; sub { my $self = shift;
                     core =&gt; [ $self-&gt;list_core_modules ]   },
 
        dependencies        
            =&gt; sub { my $self = shift;
                     dependencies =&gt; [ $self-&gt;list_core_dependencies ] },

        enabled_features    
            =&gt; sub { my $self = shift;
                     map { $_ =&gt; [ $self-&gt;modules_for_feature( $_ ) ] }
                        $self-&gt;list_enabled_features 
                   },
        features
            =&gt; sub { my $self = shift;
                     map { $_ =&gt; [ $self-&gt;modules_for_feature( $_ ) ] }
                        $self-&gt;list_features   
                   },
            ### make sure to do 'core' first, in case
            ### we are out of date ourselves
        all =&gt; [ qw|core dependencies enabled_features| ],
    };
    
    
=head2 @cat = $self-&gt;list_categories

Returns a list of categories that the C&lt;selfupdate&gt; method accepts.

See C&lt;selfupdate&gt; for details.

=cut

    sub list_categories { return sort keys %$cache }

=head2 %list = $self-&gt;list_modules_to_update( update =&gt; "core|dependencies|enabled_features|features|all", [latest =&gt; BOOL] )

List which modules C&lt;selfupdate&gt; would upgrade. You can update either 
the core (CPANPLUS itself), the core dependencies, all features you have
currently turned on, or all features available, or everything.

The C&lt;latest&gt; option determines whether it should update to the latest
version on CPAN, or if the minimal required version for CPANPLUS is
good enough.
    
Returns a hash of feature names and lists of module objects to be
upgraded based on the category you provided. For example:

    %list = $self-&gt;list_modules_to_update( update =&gt; 'core' );

Would return:

    ( core =&gt; [ $module_object_for_cpanplus ] );

=cut    
    
    sub list_modules_to_update {
        my $self = shift;
        my $cb   = $self-&gt;();
        my $conf = $cb-&gt;configure_object;
        my %hash = @_;
        
        my($type, $latest);
        my $tmpl = {
            update =&gt; { required =&gt; 1, store =&gt; \$type,
                         allow   =&gt; [ keys %$cache ], },
            latest =&gt; { default  =&gt; 0, store =&gt; \$latest, allow =&gt; BOOLEANS },                     
        };    
    
        {   local $Params::Check::ALLOW_UNKNOWN = 1;
            check( $tmpl, \%hash ) or return;
        }
    
        my $ref     = $cache-&gt;{$type};

        ### a list of ( feature1 =&gt; \@mods, feature2 =&gt; \@mods, etc )        
        my %list    = UNIVERSAL::isa( $ref, 'ARRAY' )
                            ? map { $cache-&gt;{$_}-&gt;( $self ) } @$ref
                            : $ref-&gt;( $self );

        ### filter based on whether we need the latest ones or not
        for my $aref ( values %list ) {              
              $aref = [ $latest 
                        ? grep { !$_-&gt;is_uptodate } @$aref
                        : grep { !$_-&gt;is_installed_version_sufficient } @$aref
                      ];
        }
        
        return %list;
    }

=head2 $bool = $self-&gt;selfupdate( update =&gt; "core|dependencies|enabled_features|features|all", [latest =&gt; BOOL, force =&gt; BOOL] )

Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself),
the core dependencies, all features you have currently turned on, or
all features available, or everything.

The C&lt;latest&gt; option determines whether it should update to the latest
version on CPAN, or if the minimal required version for CPANPLUS is
good enough.

Returns true on success, false on error.

=cut

    sub selfupdate {
        my $self = shift;
        my $cb   = $self-&gt;();
        my $conf = $cb-&gt;configure_object;
        my %hash = @_;
    
        my $force;
        my $tmpl = {
            force  =&gt; { default =&gt; $conf-&gt;get_conf('force'), store =&gt; \$force },
        };    
    
        {   local $Params::Check::ALLOW_UNKNOWN = 1;
            check( $tmpl, \%hash ) or return;
        }
    
        my %list = $self-&gt;list_modules_to_update( %hash ) or return;

        ### just the modules please
        my @mods = map { @$_ } values %list;
        
        my $flag;
        for my $mod ( @mods ) {
            unless( $mod-&gt;install( force =&gt; $force ) ) {
                $flag++;
                error(loc("Failed to update module '%1'", $mod-&gt;name));
            }
        }
        
        return if $flag;
        return 1;
    }    

}

=head2 @features = $self-&gt;list_features

Returns a list of features that are supported by CPANPLUS.

=cut

sub list_features {
    my $self = shift;
    return keys %{ $self-&gt;_get_config-&gt;{'features'} };
}

=head2 @features = $self-&gt;list_enabled_features

Returns a list of features that are enabled in your current
CPANPLUS installation.

=cut

sub list_enabled_features {
    my $self = shift;
    my $cb   = $self-&gt;();
    
    my @enabled;
    for my $feat ( $self-&gt;list_features ) {
        my $ref = $self-&gt;_get_config-&gt;{'features'}-&gt;{$feat}-&gt;[1];
        push @enabled, $feat if $ref-&gt;($cb);
    }
    
    return @enabled;
}

=head2 @mods = $self-&gt;modules_for_feature( FEATURE [,AS_HASH] )

Returns a list of C&lt;CPANPLUS::Selfupdate::Module&gt; objects which 
represent the modules required to support this feature.

For a list of features, call the C&lt;list_features&gt; method.

If the C&lt;AS_HASH&gt; argument is provided, no module objects are
returned, but a hashref where the keys are names of the modules,
and values are their minimum versions.

=cut

sub modules_for_feature {
    my $self    = shift;
    my $feature = shift or return;
    my $as_hash = shift || 0;
    my $cb      = $self-&gt;();
    
    unless( exists $self-&gt;_get_config-&gt;{'features'}-&gt;{$feature} ) {
        error(loc("Unknown feature '%1'", $feature));
        return;
    }
    
    my $ref = $self-&gt;_get_config-&gt;{'features'}-&gt;{$feature}-&gt;[0];
    
    ### it's either a list of modules/versions or a subroutine that
    ### returns a list of modules/versions
    my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref-&gt;( $cb );
    
    return unless $href;    # nothing needed for the feature?

    return $href if $as_hash;
    return $self-&gt;_hashref_to_module( $href );
}


=head2 @mods = $self-&gt;list_core_dependencies( [AS_HASH] )

Returns a list of C&lt;CPANPLUS::Selfupdate::Module&gt; objects which 
represent the modules that comprise the core dependencies of CPANPLUS.

If the C&lt;AS_HASH&gt; argument is provided, no module objects are
returned, but a hashref where the keys are names of the modules,
and values are their minimum versions.

=cut

sub list_core_dependencies {
    my $self    = shift;
    my $as_hash = shift || 0;
    my $cb      = $self-&gt;();
    my $href    = $self-&gt;_get_config-&gt;{'dependencies'};

    return $href if $as_hash;
    return $self-&gt;_hashref_to_module( $href );
}

=head2 @mods = $self-&gt;list_core_modules( [AS_HASH] )

Returns a list of C&lt;CPANPLUS::Selfupdate::Module&gt; objects which 
represent the modules that comprise the core of CPANPLUS.

If the C&lt;AS_HASH&gt; argument is provided, no module objects are
returned, but a hashref where the keys are names of the modules,
and values are their minimum versions.

=cut

sub list_core_modules {
    my $self    = shift;
    my $as_hash = shift || 0;
    my $cb      = $self-&gt;();
    my $href    = $self-&gt;_get_config-&gt;{'core'};

    return $href if $as_hash;
    return $self-&gt;_hashref_to_module( $href );
}

sub _hashref_to_module {
    my $self = shift;
    my $cb   = $self-&gt;();
    my $href = shift or return;
    
    return map { 
            CPANPLUS::Selfupdate::Module-&gt;new(
                $cb-&gt;module_tree($_) =&gt; $href-&gt;{$_}
            )
        } keys %$href;
}        
    

=head1 CPANPLUS::Selfupdate::Module

C&lt;CPANPLUS::Selfupdate::Module&gt; extends C&lt;CPANPLUS::Module&gt; objects
by providing accessors to aid in selfupdating CPANPLUS.

These objects are returned by all methods of C&lt;CPANPLUS::Selfupdate&gt;
that return module objects.

=cut

{   package CPANPLUS::Selfupdate::Module;
    use base 'CPANPLUS::Module';
    
    ### stores module name -&gt; cpanplus required version
    ### XXX only can deal with 1 pair!
    my %Cache = ();
    my $Acc   = 'version_required';
    
    sub new {
        my $class = shift;
        my $mod   = shift or return;
        my $ver   = shift;          return unless defined $ver;
        
        my $obj   = $mod-&gt;clone;    # clone the module object
        bless $obj, $class;         # rebless it to our class
        
        $obj-&gt;$Acc( $ver );
        
        return $obj;
    }

=head2 $version = $mod-&gt;version_required

Returns the version of this module required for CPANPLUS.

=cut
    
    sub version_required {
        my $self = shift;
        $Cache{ $self-&gt;name } = shift() if @_;
        return $Cache{ $self-&gt;name };
    }        

=head2 $bool = $mod-&gt;is_installed_version_sufficient

Returns true if the installed version of this module is sufficient
for CPANPLUS, or false if it is not.

=cut

    
    sub is_installed_version_sufficient {
        my $self = shift;
        return $self-&gt;is_uptodate( version =&gt; $self-&gt;$Acc );
    }

}    

1;

=pod

=head1 BUG REPORTS

Please report bugs or other issues to E&lt;lt&gt;bug-cpanplus@rt.cpan.org&lt;gt&gt;.

=head1 AUTHOR

This module by Jos Boumans E&lt;lt&gt;kane@cpan.orgE&lt;gt&gt;.

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is copyright (c) 
2001 - 2007, Jos Boumans E&lt;lt&gt;kane@cpan.orgE&lt;gt&gt;. All rights reserved.

This library is free software; you may redistribute and/or modify it 
under the same terms as Perl itself.

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
</pre></body></html>