dist.pm

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

package CPANPLUS::Dist;

use strict;


use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load check_install];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
use Object::Accessor;

local $Params::Check::VERBOSE = 1;

my @methods = qw[status parent];
for my $key ( @methods ) {
    no strict 'refs';
    *{__PACKAGE__."::$key"} = sub {
        my $self = shift;
        $self->{$key} = $_[0] if @_;
        return $self->{$key};
    }
}

=pod

=head1 NAME

CPANPLUS::Dist

=head1 SYNOPSIS

    my $dist = CPANPLUS::Dist->new(
                                format  => 'build',
                                module  => $modobj,
                            );

=head1 DESCRIPTION

C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM>
and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*>
plugins should look at C<CPANPLUS::Dist::Base>.

=head1 ACCESSORS

=over 4

=item parent()

Returns the C<CPANPLUS::Module> object that parented this object.

=item status()

Returns the C<Object::Accessor> object that keeps the status for
this module.

=back

=head1 STATUS ACCESSORS

All accessors can be accessed as follows:
    $deb->status->ACCESSOR

=over 4

=item created()

Boolean indicating whether the dist was created successfully.
Explicitly set to C<0> when failed, so a value of C<undef> may be
interpreted as C<not yet attempted>.

=item installed()

Boolean indicating whether the dist was installed successfully.
Explicitly set to C<0> when failed, so a value of C<undef> may be
interpreted as C<not yet attempted>.

=item uninstalled()

Boolean indicating whether the dist was uninstalled successfully.
Explicitly set to C<0> when failed, so a value of C<undef> may be
interpreted as C<not yet attempted>.

=item dist()

The location of the final distribution. This may be a file or
directory, depending on how your distribution plug in of choice
works. This will be set upon a successful create.

=cut

=back

=head2 $dist = CPANPLUS::Dist->new( module => MODOBJ, [format => DIST_TYPE] );

Create a new C<CPANPLUS::Dist> object based on the provided C<MODOBJ>.
The optional argument C<format> is used to indicate what type of dist
you would like to create (like C<makemaker> for a C<CPANPLUS::Dist::MM>
object, C<build> for a C<CPANPLUS::Dist::Build> object, and so on ).
If not provided, will default to the setting as specified by your
config C<dist_type>.

Returns a C<CPANPLUS::Dist> object on success and false on failure.

=cut

sub new {
    my $self = shift;
    my %hash = @_;

    local $Params::Check::ALLOW_UNKNOWN = 1;

    ### first verify we got a module object ###
    my $mod;
    my $tmpl = {
        module  => { required => 1, allow => IS_MODOBJ, store => \$mod },
    };
    check( $tmpl, \%hash ) or return;

    ### get the conf object ###
    my $conf = $mod->parent->configure_object();

    ### figure out what type of dist object to create ###
    my $format;
    my $tmpl2 = {
        format  => {    default => $conf->get_conf('dist_type'),
                        allow   => [ __PACKAGE__->dist_types ],
                        store   => \$format  },
    };
    check( $tmpl2, \%hash ) or return;


    unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) {
        error(loc("'%1' not found -- you need '%2' version '%3' or higher ".
                    "to detect plugins", $format, 'Module::Pluggable','2.4'));
        return;
    }

    ### bless the object in the child class ###
    my $obj = bless { parent => $mod }, $format;

    ### check if the format is available in this environment ###
    if( $conf->_get_build('sanity_check') and not $obj->format_available ) {
        error( loc( "Format '%1' is not available",$format) );
        return;
    }

    ### create a status object ###
    {   my $acc = Object::Accessor->new;
        $obj->status($acc);

        ### add minimum supported accessors
        $acc->mk_accessors( qw[prepared created installed uninstalled 
                               distdir dist] );
    }

    ### now initialize it or admit failure
    unless( $obj->init ) {
        error(loc("Dist initialization of '%1' failed for '%2'",
                    $format, $mod->module));
        return;
    }

    ### return the object
    return $obj;
}

=head2 @dists = CPANPLUS::Dist->dist_types;

Returns a list of the CPANPLUS::Dist::* classes available

=cut

### returns a list of dist_types we support
### will get overridden by Module::Pluggable if loaded
### XXX add support for 'plugin' dir in config as well
{   my $Loaded;
    my @Dists   = (INSTALLER_MM);
    my @Ignore  = ();

    ### backdoor method to add more dist types
    sub _add_dist_types     { my $self = shift; push @Dists,  @_ };
    
    ### backdoor method to exclude dist types
    sub _ignore_dist_types  { my $self = shift; push @Ignore, @_ };

    ### locally add the plugins dir to @INC, so we can find extra plugins
    #local @INC = @INC, File::Spec->catdir(
    #                        $conf->get_conf('base'),
    #                        $conf->_get_build('plugins') );

    ### load any possible plugins
    sub dist_types {

        if ( !$Loaded++ and check_install(  module  => 'Module::Pluggable',
                                            version => '2.4')
        ) {
            require Module::Pluggable;

            my $only_re = __PACKAGE__ . '::\w+$';

            Module::Pluggable->import(
                            sub_name    => '_dist_types',
                            search_path => __PACKAGE__,
                            only        => qr/$only_re/,
                            except      => [ INSTALLER_MM, 
                                             INSTALLER_SAMPLE,
                                             INSTALLER_BASE,
                                        ]
                        );
            my %ignore = map { $_ => $_ } @Ignore;                        
                        
            push @Dists, grep { not $ignore{$_}  } __PACKAGE__->_dist_types;
        }

        return @Dists;
    }
}

=head2 prereq_satisfied( modobj => $modobj, version => $version_spec )

Returns true if this prereq is satisfied.  Returns false if it's not.
Also issues an error if it seems "unsatisfiable," i.e. if it can't be
found on CPAN or the latest CPAN version doesn't satisfy it.

=cut

sub prereq_satisfied {
    my $dist = shift;
    my $cb   = $dist->parent->parent;
    my %hash = @_;
  
    my($mod,$ver);
    my $tmpl = {
        version => { required => 1, store => \$ver },
        modobj  => { required => 1, store => \$mod, allow => IS_MODOBJ },
    };
    
    check( $tmpl, \%hash ) or return;
  
    return 1 if $mod->is_uptodate( version => $ver );
  
    if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) {

        error(loc(  
                "This distribution depends on %1, but the latest version".
                " of %2 on CPAN (%3) doesn't satisfy the specific version".
                " dependency (%4). You may have to resolve this dependency ".
                "manually.", 
                $mod->module, $mod->module, $mod->version, $ver ));
  
    }

    return;