selfupdate.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package CPANPLUS::Selfupdate;

use strict;
use Params::Check               qw[check];
use IPC::Cmd                    qw[can_run];
use CPANPLUS::Error             qw[error msg];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

use CPANPLUS::Internals::Constants;

$Params::Check::VERBOSE = 1;

=head1 NAME

CPANPLUS::Selfupdate

=head1 SYNOPSIS

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

=cut

### a config has describing our deps etc
{

    my $Modules = {
        dependencies => {
            'File::Fetch'               => '0.13_04', # win32 & VMS file://
            'File::Spec'                => '0.82',
            'IPC::Cmd'                  => '0.36', # 5.6.2 compat: 2-arg open
            'Locale::Maketext::Simple'  => '0.01',
            'Log::Message'              => '0.01',
            'Module::Load'              => '0.10',
            'Module::Load::Conditional' => '0.18', # Better parsing: #23995,
                                                   # uses version.pm for <=>
            'version'                   => '0.73', # needed for M::L::C
                                                   # addresses #24630 and 
                                                   # #24675
                                                   # Address ~0 overflow issue
            'Params::Check'             => '0.22',
            'Package::Constants'        => '0.01',
            'Term::UI'                  => '0.18', # option parsing
            'Test::Harness'             => '2.62', # due to bug #19505
                                                   # only 2.58 and 2.60 are bad
            'Test::More'                => '0.47', # to run our tests
            'Archive::Extract'          => '0.16', # ./Dir bug fix
            'Archive::Tar'              => '1.23',
            'IO::Zlib'                  => '1.04', # needed for Archive::Tar
            'Object::Accessor'          => '0.32', # overloaded stringification
            'Module::CoreList'          => '2.09',
            'Module::Pluggable'         => '2.4',
            'Module::Loaded'            => '0.01',
        },
    
        features => {
            # config_key_name => [
            #     sub { } to list module key/value pairs
            #     sub { } to check if feature is enabled
            # ]
            prefer_makefile => [
                sub {
                    my $cb = shift;
                    $cb->configure_object->get_conf('prefer_makefile') 
                        ? { }
                        : { 'CPANPLUS::Dist::Build' => '0.04'  };
                },
                sub { return 1 },   # always enabled
            ],            
            cpantest        => [
                {
                    'YAML::Tiny'     => '0.0',
                    'Test::Reporter' => '1.34',
                },
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('cpantest');
                },
            ],                
            dist_type => [
                sub { 
                    my $cb      = shift;
                    my $dist    = $cb->configure_object->get_conf('dist_type');
                    return { $dist => '0.0' } if $dist;
                    return;
                },            
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('dist_type');
                },
            ],

            md5 => [
                {
                    'Digest::MD5'   => '0.0',
                },            
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('md5');
                },
            ],
            shell => [
                sub { 
                    my $cb      = shift;
                    my $dist    = $cb->configure_object->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 => '0.0' } if $dist;
                    return;
                },            
                sub { return 1 },
            ],                
            signature => [
                sub {
                    my $cb      = shift;
                    return {
                        'Module::Signature' => '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->configure_object->get_conf('prefer_bin');

                    return { 
                        'Crypt::OpenPGP'    => '0.0', 
                        'Module::Signature' => '0.06',
                    };
                },            
                sub {
                    my $cb = shift;
                    return $cb->configure_object->get_conf('signature');
                },
            ],
            storable => [
                { 'Storable' => '0.0' },         
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('storable');
                },
            ],
        },
        core => {
            'CPANPLUS' => '0.0',
        },
    };

    sub _get_config { return $Modules }
}

=head1 METHODS

=head2 $self = CPANPLUS::Selfupdate->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 
            => sub { my $self = shift;
                     core => [ $self->list_core_modules ]   },
 
        dependencies        
            => sub { my $self = shift;
                     dependencies => [ $self->list_core_dependencies ] },

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

Returns a list of categories that the C<selfupdate> method accepts.

See C<selfupdate> for details.

=cut

    sub list_categories { return sort keys %$cache }

=head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] )
    
List which modules C<selfupdate> 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<latest> 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->list_modules_to_update( update => 'core' );
    
Would return:

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

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

        ### filter based on whether we need the latest ones or not