module.pm

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

    while ( my($type, $index) = each %map ) {
        my $name    = 'package_' . $type;
        
        no strict 'refs';
        *$name = sub {
            my $self = shift;
            my @res  = $self->parent->_split_package_string(     
                            package => $self->package 
                       );
     
            ### return the corresponding index from the result
            return $res[$index] if @res;
            return;
        };
    }        

    sub package_is_perl_core {
        my $self = shift;

        ### check if the package looks like a perl core package
        return 1 if $self->package_name eq PERL_CORE;

        my $core = $self->module_is_supplied_with_perl_core;
        ### ok, so it's found in the core, BUT it could be dual-lifed
        if ($core) {
            ### if the package is newer than installed, then it's dual-lifed
            return if $self->version > $self->installed_version;

            ### if the package is newer or equal to the corelist, 
            ### then it's dual-lifed
            return if $self->version >= $core;

            ### otherwise, it's older than corelist, thus unsuitable.
            return 1;
        }

        ### not in corelist, not a perl core package.
        return;
    }

    sub module_is_supplied_with_perl_core {
        my $self = shift;
        my $ver  = shift || $];

        ### check Module::CoreList to see if it's a core package
        require Module::CoreList;
        my $core = $Module::CoreList::version{ $ver }->{ $self->module };

        return $core;
    }

    ### make sure Bundle-Foo also gets flagged as bundle
    sub is_bundle {
        return shift->module =~ /^bundle(?:-|::)/i ? 1 : 0;
    }

    sub is_third_party {
        my $self = shift;
        
        return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
        
        return Module::ThirdParty::is_3rd_party( $self->name );
    }

    sub third_party_information {
        my $self = shift;

        return unless $self->is_third_party; 

        return Module::ThirdParty::module_information( $self->name );
    }
}

=pod

=head2 $clone = $self->clone

Clones the current module object for tinkering with.
It will have a clean C<CPANPLUS::Module::Status> object, as well as
a fake C<CPANPLUS::Module::Author> object.

=cut

sub clone {
    my $self = shift;

    ### clone the object ###
    my %data;
    for my $acc ( grep !/status/, __PACKAGE__->accessors() ) {
        $data{$acc} = $self->$acc();
    }

    my $obj = CPANPLUS::Module::Fake->new( %data );

    return $obj;
}

=pod

=head2 $where = $self->fetch

Fetches the module from a CPAN mirror.
Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
options you can pass.

=cut

sub fetch {
    my $self = shift;
    my $cb   = $self->parent;

    ### custom args
    my %args            = ( module => $self );

    ### if a custom fetch location got specified before, add that here
    $args{fetch_from}   = $self->status->_fetch_from 
                            if $self->status->_fetch_from;

    my $where = $cb->_fetch( @_, %args ) or return;

    ### do an md5 check ###
    if( !$self->status->_fetch_from and 
        $cb->configure_object->get_conf('md5') and
        $self->package ne CHECKSUMS
    ) {
        unless( $self->_validate_checksum ) {
            error( loc( "Checksum error for '%1' -- will not trust package",
                        $self->package) );
            return;
        }
    }

    return $where;
}

=pod

=head2 $path = $self->extract

Extracts the fetched module.
Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
the options you can pass.

=cut

sub extract {
    my $self = shift;
    my $cb   = $self->parent;

    unless( $self->status->fetch ) {
        error( loc( "You have not fetched '%1' yet -- cannot extract",
                    $self->module) );
        return;
    }

    return $cb->_extract( @_, module => $self );
}

=head2 $type = $self->get_installer_type([prefer_makefile => BOOL])

Gets the installer type for this module. This may either be C<build> or
C<makemaker>. If C<Module::Build> is unavailable or no installer type
is available, it will fall back to C<makemaker>. If both are available,
it will pick the one indicated by your config, or by the
C<prefer_makefile> option you can pass to this function.

Returns the installer type on success, and false on error.

=cut

sub get_installer_type {
    my $self = shift;
    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my $prefer_makefile;
    my $tmpl = {
        prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
                             store => \$prefer_makefile, allow => BOOLEANS },
    };

    check( $tmpl, \%hash ) or return;

    my $extract = $self->status->extract();
    unless( $extract ) {
        error(loc("Cannot determine installer type of unextracted module '%1'",
                  $self->module));
        return;
    }


    ### check if it's a makemaker or a module::build type dist ###
    my $found_build     = -e BUILD_PL->( $extract );
    my $found_makefile  = -e MAKEFILE_PL->( $extract );

    my $type;
    $type = INSTALLER_BUILD if !$prefer_makefile &&  $found_build;
    $type = INSTALLER_BUILD if  $found_build     && !$found_makefile;
    $type = INSTALLER_MM    if  $prefer_makefile &&  $found_makefile;
    $type = INSTALLER_MM    if  $found_makefile  && !$found_build;

    ### ok, so it's a 'build' installer, but you don't /have/ module build
    if( $type eq INSTALLER_BUILD and ( 
            not grep { $_ eq INSTALLER_BUILD } CPANPLUS::Dist->dist_types )
    ) {
        error( loc( "This module requires '%1' and '%2' to be installed, ".
                    "but you don't have it! Will fall back to ".
                    "'%3', but might not be able to install!",
                     'Module::Build', INSTALLER_BUILD, INSTALLER_MM ) );
        $type = INSTALLER_MM;

    ### ok, actually we found neither ###
    } elsif ( !$type ) {
        error( loc( "Unable to find '%1' or '%2' for '%3'; ".
                    "Will default to '%4' but might be unable ".
                    "to install!", BUILD_PL->(), MAKEFILE_PL->(),
                    $self->module, INSTALLER_MM ) );
        $type = INSTALLER_MM;
    }

    return $self->status->installer_type( $type ) if $type;
    return;
}

=pod

=head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);

Create a distribution object, ready to be installed.
Distribution type defaults to your config settings

The optional C<args> hashref is passed on to the specific distribution
types' C<create> method after being dereferenced.

Returns a distribution object on success, false on failure.

See C<CPANPLUS::Dist> for details.

=cut

sub dist {
    my $self = shift;
    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    ### have you determined your installer type yet? if not, do it here,
    ### we need the info
    $self->get_installer_type unless $self->status->installer_type;


    my($type,$args,$target);
    my $tmpl = {
        format  => { default => $conf->get_conf('dist_type') ||
                                $self->status->installer_type,
                     store   => \$type },
        target  => { default => TARGET_CREATE, store => \$target },                     
        args    => { default => {}, store => \$args },
    };

    check( $tmpl, \%hash ) or return;

    my $dist = CPANPLUS::Dist->new( 
                                format => $type,
                                module => $self
                            ) or return;

    my $dist_cpan = $type eq $self->status->installer_type
                        ? $dist
                        : CPANPLUS::Dist->new(
                                format  => $self->status->installer_type,
                                module  => $self,
                            );           

    ### store the dists
    $self->status->dist_cpan(   $dist_cpan );
    $self->status->dist(        $dist );
    
    DIST: {
        ### first prepare the dist
        $dist->prepare( %$args ) or return;
        $self->status->prepared(1);

        ### you just wanted us to prepare?
        last DIST if $target eq TARGET_PREPARE;

        $dist->create( %$args ) or return;
        $self->status->created(1);
    }

    return $dist;
}

=pod

=head2 $bool = $mod->prepare( )
 
Convenience method around C<install()> that prepares a module 
without actually building it. This is equivalent to invoking C<install>
with C<target> set to C<prepare>

Returns true on success, false on failure.

=cut

sub prepare { 
    my $self = shift;
    return $self->install( @_, target => TARGET_PREPARE );
}

=head2 $bool = $mod->create( )

Convenience method around C<install()> that creates a module. 
This is equivalent to invoking C<install> with C<target> set to 
C<create>

Returns true on success, false on failure.

=cut

sub create { 
    my $self = shift;
    return $self->install( @_, target => TARGET_CREATE );
}

=head2 $bool = $mod->test( )

Convenience wrapper around C<install()> that tests a module, without
installing it.
It's the equivalent to invoking C<install()> with C<target> set to
C<create> and C<skiptest> set to C<0>.

Returns true on success, false on failure.

=cut

sub test {
    my $self = shift;
    return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
}

=pod

=head2 $bool = $self->install([ target => 'prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);

Installs the current module. This includes fetching it and extracting
it, if this hasn't been done yet, as well as creating a distribution
object for it.

This means you can pass it more arguments than described above, which
will be passed on to the relevant methods as they are called.

See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
C<CPANPLUS::Dist> for details.

Returns true on success, false on failure.

=cut

sub install {
    my $self = shift;
    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my $args; my $target; my $format;
    {   ### so we can use the rest of the args to the create calls etc ###
        local $Params::Check::NO_DUPLICATES = 1;
        local $Params::Check::ALLOW_UNKNOWN = 1;

        ### targets 'dist' and 'test' are now completely ignored ###
        my $tmpl = {
                        ### match this allow list with Dist->_resolve_prereqs
            target     => { default => TARGET_INSTALL, store => \$target,
                            allow   => [TARGET_PREPARE, TARGET_CREATE,
                                        TARGET_INSTALL] },
            force      => { default => $conf->get_conf('force'), },
            verbose    => { default => $conf->get_conf('verbose'), },
            format     => { default => $conf->get_conf('dist_type'),
                                store => \$format },
        };

        $args = check( $tmpl, \%hash ) or return;
    }


    ### if this target isn't 'install', we will need to at least 'create' 
    ### every prereq, so it can build
    ### XXX prereq_target of 'prepare' will do weird things here, and is
    ### not supported.
    $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;

    ### check if it's already upto date ###
    if( $target eq TARGET_INSTALL and !$args->{'force'} and
        !$self->package_is_perl_core() and         # separate rules apply
        ( $self->status->installed() or $self->is_uptodate ) and
        !INSTALL_VIA_PACKAGE_MANAGER->($format)
    ) {
        msg(loc("Module '%1' already up to date, won't install without force",
                $self->module), $args->{'verbose'} );
        return $self->status->installed(1);
    }