module.pm

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

    # if it's a non-installable core package, abort the install.
    if( $self->package_is_perl_core() ) {
        # if the installed is newer, say so.
        if( $self->installed_version > $self->version ) {
            error(loc("The core Perl %1 module '%2' (%3) is more ".
                      "recent than the latest release on CPAN (%4). ".
                      "Aborting install.",
                      $], $self->module, $self->installed_version,
                      $self->version ) );
        # if the installed matches, say so.
        } elsif( $self->installed_version == $self->version ) {
            error(loc("The core Perl %1 module '%2' (%3) can only ".
                      "be installed by Perl itself. ".
                      "Aborting install.",
                      $], $self->module, $self->installed_version ) );
        # otherwise, the installed is older; say so.
        } else {
            error(loc("The core Perl %1 module '%2' can only be ".
                      "upgraded from %3 to %4 by Perl itself (%5). ".
                      "Aborting install.",
                      $], $self->module, $self->installed_version,
                      $self->version, $self->package ) );
        }
        return;
    
    ### it might be a known 3rd party module
    } elsif ( $self->is_third_party ) {
        my $info = $self->third_party_information;
        error(loc(
            "%1 is a known third-party module.\n\n".
            "As it isn't available on the CPAN, CPANPLUS can't install " .
            "it automatically. Therefore you need to install it manually " .
            "before proceeding.\n\n".
            "%2 is part of %3, published by %4, and should be available ".
            "for download at the following address:\n\t%5",
            $self->name, $self->name, $info->{name}, $info->{author},
            $info->{url}
        ));
        
        return;
    }

    ### fetch it if need be ###
    unless( $self->status->fetch ) {
        my $params;
        for (qw[prefer_bin fetchdir]) {
            $params->{$_} = $args->{$_} if exists $args->{$_};
        }
        for (qw[force verbose]) {
            $params->{$_} = $args->{$_} if defined $args->{$_};
        }
        $self->fetch( %$params ) or return;
    }

    ### extract it if need be ###
    unless( $self->status->extract ) {
        my $params;
        for (qw[prefer_bin extractdir]) {
            $params->{$_} = $args->{$_} if exists $args->{$_};
        }
        for (qw[force verbose]) {
            $params->{$_} = $args->{$_} if defined $args->{$_};
        }
        $self->extract( %$params ) or return;
    }

    $format ||= $self->status->installer_type;

    unless( $format ) {
        error( loc( "Don't know what installer to use; " .
                    "Couldn't find either '%1' or '%2' in the extraction " .
                    "directory '%3' -- will be unable to install",
                    BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );

        $self->status->installed(0);
        return;
    }


    ### do SIGNATURE checks? ###
    if( $conf->get_conf('signature') ) {
        unless( $self->check_signature( verbose => $args->{verbose} ) ) {
            error( loc( "Signature check failed for module '%1' ".
                        "-- Not trusting this module, aborting install",
                        $self->module ) );
            $self->status->signature(0);
            
            ### send out test report on broken sig
            if( $conf->get_conf('cpantest') ) {
                $cb->_send_report( 
                    module  => $self,
                    failed  => 1,
                    buffer  => CPANPLUS::Error->stack_as_string,
                    verbose => $args->{verbose},
                    force   => $args->{force},
                ) or error(loc("Failed to send test report for '%1'",
                     $self->module ) );
            }  
            
            return;

        } else {
            ### signature OK ###
            $self->status->signature(1);
        }
    }

    ### a target of 'create' basically means not to run make test ###
    ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
    #$args->{'skiptest'} = 1 if $target eq 'create';

    ### bundle rules apply ###
    if( $self->is_bundle ) {
        ### check what we need to install ###
        my @prereqs = $self->bundle_modules();
        unless( @prereqs ) {
            error( loc( "Bundle '%1' does not specify any modules to install",
                        $self->module ) );

            ### XXX mark an error here? ###
        }
    }

    my $dist = $self->dist( format  => $format, 
                            target  => $target, 
                            args    => $args );
    unless( $dist ) {
        error( loc( "Unable to create a new distribution object for '%1' " .
                    "-- cannot continue", $self->module ) );
        return;
    }

    return 1 if $target ne TARGET_INSTALL;

    my $ok = $dist->install( %$args ) ? 1 : 0;

    $self->status->installed($ok);

    return 1 if $ok;
    return;
}

=pod @list = $self->bundle_modules()

Returns a list of module objects the Bundle specifies.

This requires you to have extracted the bundle already, using the
C<extract()> method.

Returns false on error.

=cut

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

    unless( $self->is_bundle ) {
        error( loc("'%1' is not a bundle", $self->module ) );
        return;
    }

    my $dir;
    unless( $dir = $self->status->extract ) {
        error( loc("Don't know where '%1' was extracted to", $self->module ) );
        return;
    }

    my @files;
    find( {
        wanted      => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i; },
        no_chdir    => 1,
    }, $dir );

    my $prereqs = {}; my @list; my $seen = {};
    for my $file ( @files ) {
        my $fh = FileHandle->new($file)
                    or( error(loc("Could not open '%1' for reading: %2",
                        $file,$!)), next );

        my $flag;
        while(<$fh>) {
            ### quick hack to read past the header of the file ###
            last if $flag && m|^=head|i;

            ### from perldoc cpan:
            ### =head1 CONTENTS
            ### In this pod section each line obeys the format
            ### Module_Name [Version_String] [- optional text]
            $flag = 1 if m|^=head1 CONTENTS|i;

            if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
                my $module  = $1;
                my $version = $2 || '0';

                my $obj = $cb->module_tree($module);

                unless( $obj ) {
                    error(loc("Cannot find bundled module '%1'", $module),
                          loc("-- it does not seem to exist") );
                    next;
                }

                ### make sure we list no duplicates ###
                unless( $seen->{ $obj->module }++ ) {
                    push @list, $obj;
                    $prereqs->{ $module } =
                        $cb->_version_to_number( version => $version );
                }
            }
        }
    }

    ### store the prereqs we just found ###
    $self->status->prereqs( $prereqs );

    return @list;
}

=pod

=head2 $text = $self->readme

Fetches the readme belonging to this module and stores it under
C<< $obj->status->readme >>. Returns the readme as a string on
success and returns false on failure.

=cut

sub readme {
    my $self = shift;
    my $conf = $self->parent->configure_object;    

    ### did we already dl the readme once? ###
    return $self->status->readme() if $self->status->readme();

    ### this should be core ###
    return unless can_load( modules     => { FileHandle => '0.0' },
                            verbose     => 1,
                        );

    ### get a clone of the current object, with a fresh status ###
    my $obj  = $self->clone or return;

    ### munge the package name
    my $pkg = README->( $obj );
    $obj->package($pkg);

    my $file;
    {   ### disable checksum fetches on readme downloads
        
        my $tmp = $conf->get_conf( 'md5' );
        $conf->set_conf( md5 => 0 );
        
        $file = $obj->fetch;

        $conf->set_conf( md5 => $tmp );

        return unless $file;
    }

    ### read the file into a scalar, to store in the original object ###
    my $fh = new FileHandle;
    unless( $fh->open($file) ) {
        error( loc( "Could not open file '%1': %2", $file, $! ) );
        return;
    }

    my $in;
    { local $/; $in = <$fh> };
    $fh->close;

    return $self->status->readme( $in );
}

=pod

=head2 $version = $self->installed_version()

Returns the currently installed version of this module, if any.

=head2 $where = $self->installed_file()

Returns the location of the currently installed file of this module,
if any.

=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])

Returns a boolean indicating if this module is uptodate or not.

=cut

### uptodate/installed functions
{   my $map = {             # hashkey,      alternate rv
        installed_version   => ['version',  0 ],
        installed_file      => ['file',     ''],
        is_uptodate         => ['uptodate', 0 ],
    };

    while( my($method, $aref) = each %$map ) {
        my($key,$alt_rv) = @$aref;

        no strict 'refs';
        *$method = sub {
            ### never use the @INC hooks to find installed versions of
            ### modules -- they're just there in case they're not on the
            ### perl install, but the user shouldn't trust them for *other*
            ### modules!
            ### XXX CPANPLUS::inc is now obsolete, so this should not
            ### be needed anymore
            #local @INC = CPANPLUS::inc->original_inc;

            my $self = shift;
            
            ### make sure check_install is not looking in %INC, as
            ### that may contain some of our sneakily loaded modules
            ### that aren't installed as such. -- kane
            local $Module::Load::Conditional::CHECK_INC_HASH = 0;
            my $href = check_install(
                            module  => $self->module,
                            version => $self->version,
                            @_,
                        );

            return $href->{$key} || $alt_rv;
        }
    }
}



=pod

=head2 $href = $self->details()

Returns a hashref with key/value pairs offering more information about
a particular module. For example, for C<Time::HiRes> it might look like
this:

    Author                  Jarkko Hietaniemi ([e-mail])
    Description             High resolution time, sleep, and alarm
    Development Stage       Released
    Installed File          /usr/local/perl/lib/Time/Hires.pm
    Interface Style         plain Functions, no references used
    Language Used           C and perl, a C compiler will be needed
    Package                 Time-HiRes-1.65.tar.gz
    Public License          Unknown
    Support Level           Developer
    Version Installed       1.52
    Version on CPAN         1.65

=cut

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

    my $res = {
        Author              => loc("%1 (%2)",   $self->author->author(),
                                                $self->author->email() ),
        Package             => $self->package,
        Description         => $self->description     || loc('None given'),
        'Version on CPAN'   => $self->version,
    };

    ### check if we have the module installed
    ### if so, add version have and version on cpan
    $res->{'Version Installed'} = $self->installed_version
                                    if $self->installed_version;
    $res->{'Installed File'} = $self->installed_file if $self->installed_file;

    my $i = 0;
    for my $item( split '', $self->dslip ) {
        $res->{ $cb->_dslip_defs->[$i]->[0] } =
                $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
        $i++;
    }

    return $res;
}

=head2 @list = $self->contains()

Returns a list of module objects that represent the modules also 
present in the package of this module.

For example, for C<Archive::Tar> this might return:

    Archive::Tar
    Archive::Tar::Constant
    Archive::Tar::File

=cut

sub contains {
    my $self = shift;
    my $cb   = $self->parent;
    my $pkg  = $self->package;

    my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
    
    return @mods;