backend.pm

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

=over 4

=item Text::Bastardize

=item Text-Bastardize

=item Text-Bastardize-1.06

=item AYRNIEU/Text-Bastardize

=item AYRNIEU/Text-Bastardize-1.06

=item AYRNIEU/Text-Bastardize-1.06.tar.gz

=item http://example.com/Text-Bastardize-1.06.tar.gz

=item file:///tmp/Text-Bastardize-1.06.tar.gz

=back

These items would all come up with a C<CPANPLUS::Module> object for
C<Text::Bastardize>. The ones marked explicitly as being version 1.06
would give back a C<CPANPLUS::Module> object of that version.
Even if the version on CPAN is currently higher.

If C<parse_module> is unable to actually find the module you are looking
for in its module tree, but you supplied it with an author, module
and version part in a distribution name or URI, it will create a fake
C<CPANPLUS::Module> object for you, that you can use just like the
real thing.

See L<CPANPLUS::Module> for the operations you can perform on a
module object.

If even this fancy guessing doesn't enable C<parse_module> to create
a fake module object for you to use, it will warn about an error and
return false.

=cut

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

    my $mod;
    my $tmpl = {
        module  => { required => 1, store => \$mod },
    };

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

    return $mod if IS_MODOBJ->( module => $mod );

    ### ok, so it's not a module object, but a ref nonetheless?
    ### what are you smoking?
    if( ref $mod ) {
        error(loc("Can not parse module string from reference '%1'", $mod ));
        return;
    }
    
    ### check only for allowed characters in a module name
    unless( $mod =~ /[^\w:]/ ) {

        ### perhaps we can find it in the module tree?
        my $maybe = $self->module_tree($mod);
        return $maybe if IS_MODOBJ->( module => $maybe );
    }

    ### ok, so it looks like a distribution then?
    my @parts   = split '/', $mod;
    my $dist    = pop @parts;

    ### ah, it's a URL
    if( $mod =~ m|\w+://.+| ) {
        my $modobj = CPANPLUS::Module::Fake->new(
                        module  => $dist,
                        version => 0,
                        package => $dist,
                        path    => File::Spec::Unix->catdir(
                                        $conf->_get_mirror('base'),
                                        UNKNOWN_DL_LOCATION ),
                        author  => CPANPLUS::Module::Author::Fake->new
                    );
        
        ### set the fetch_from accessor so we know to by pass the
        ### usual mirrors
        $modobj->status->_fetch_from( $mod );
        
        ### better guess for the version
        $modobj->version( $modobj->package_version ) 
            if defined $modobj->package_version;
        
        ### better guess at module name, if possible
        if ( my $pkgname = $modobj->package_name ) {
            $pkgname =~ s/-/::/g;
        
            ### no sense replacing it unless we changed something
            $modobj->module( $pkgname ) 
                if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
        }                
        
        return $modobj;      
    }
    
    ### perhaps we can find it's a third party module?
    {   my $modobj = CPANPLUS::Module::Fake->new(
                        module  => $mod,
                        version => 0,
                        package => $dist,
                        path    => File::Spec::Unix->catdir(
                                        $conf->_get_mirror('base'),
                                        UNKNOWN_DL_LOCATION ),
                        author  => CPANPLUS::Module::Author::Fake->new
                    );
        if( $modobj->is_third_party ) {
            my $info = $modobj->third_party_information;
            
            $modobj->author->author( $info->{author}     );
            $modobj->author->email(  $info->{author_url} );
            $modobj->description(    $info->{url} );

            return $modobj;
        }
    }

    unless( $dist ) {
        error( loc("%1 is not a proper distribution name!", $mod) );
        return;
    }
    
    ### there's wonky uris out there, like this:
    ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
    ### compensate for that
    my $author;
    ### you probably have an A/AB/ABC/....../Dist.tgz type uri
    if( (defined $parts[0] and length $parts[0] == 1) and 
        (defined $parts[1] and length $parts[1] == 2) and
        $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
    ) {   
        splice @parts, 0, 2;    # remove the first 2 entries from the list
        $author = shift @parts; # this is the actual author name then    

    ### we''ll assume a ABC/..../Dist.tgz
    } else {
        $author = shift @parts || '';
    }
    
    my($pkg, $version, $ext) = 
        $self->_split_package_string( package => $dist );
    
    ### translate a distribution into a module name ###
    my $guess = $pkg; 
    $guess =~ s/-/::/g if $guess; 

    my $maybe = $self->module_tree( $guess );
    if( IS_MODOBJ->( module => $maybe ) ) {

        ### maybe you asked for a package instead
        if ( $maybe->package eq $mod ) {
            return $maybe;

        ### perhaps an outdated version instead?
        } elsif ( $version ) {
            my $auth_obj; my $path;

            ### did you give us an author part? ###
            if( $author ) {
                $auth_obj   = CPANPLUS::Module::Author::Fake->new(
                                    _id     => $maybe->_id,
                                    cpanid  => uc $author,
                                    author  => uc $author,
                                );
                $path       = File::Spec::Unix->catdir(
                                    $conf->_get_mirror('base'),
                                    substr(uc $author, 0, 1),
                                    substr(uc $author, 0, 2),
                                    uc $author,
                                    @parts,     #possible sub dirs
                                );
            } else {
                $auth_obj   = $maybe->author;
                $path       = $maybe->path;
            }        
        
            if( $maybe->package_name eq $pkg ) {
    
                my $modobj = CPANPLUS::Module::Fake->new(
                    module  => $maybe->module,
                    version => $version,
                    package => $pkg . '-' . $version . '.' .
                                    $maybe->package_extension,
                    path    => $path,
                    author  => $auth_obj,
                    _id     => $maybe->_id
                );
                return $modobj;

            ### you asked for a specific version?
            ### assume our $maybe is the one you wanted,
            ### and fix up the version.. 
            } else {
    
                my $modobj = $maybe->clone;
                $modobj->version( $version );
                $modobj->package( 
                        $maybe->package_name .'-'. 
                        $version .'.'. 
                        $maybe->package_extension 
                );
                
                ### you wanted a specific author, but it's not the one
                ### from the module tree? we'll fix it up
                if( $author and $author ne $modobj->author->cpanid ) {
                    $modobj->author( $auth_obj );
                    $modobj->path( $path );
                }
                
                return $modobj;
            }
        
        ### you didn't care about a version, so just return the object then
        } elsif ( !$version ) {
            return $maybe;
        }

    ### ok, so we can't find it, and it's not an outdated dist either
    ### perhaps we can fake one based on the author name and so on
    } elsif ( $author and $version ) {

        ### be extra friendly and pad the .tar.gz suffix where needed
        ### it's just a guess of course, but most dists are .tar.gz
        $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;

        ### XXX duplication from above for generating author obj + path...
        my $modobj = CPANPLUS::Module::Fake->new(
            module  => $guess,
            version => $version,
            package => $dist,
            author  => CPANPLUS::Module::Author::Fake->new(
                            author  => uc $author,
                            cpanid  => uc $author,
                            _id     => $self->_id,
                        ),
            path    => File::Spec::Unix->catdir(
                            $conf->_get_mirror('base'),
                            substr(uc $author, 0, 1),
                            substr(uc $author, 0, 2),
                            uc $author,
                            @parts,         #possible subdirs
                        ),
            _id     => $self->_id,
        );

        return $modobj;

    ### face it, we have /no/ idea what he or she wants...
    ### let's start putting the blame somewhere
    } else {

        unless( $author ) {
            error( loc( "'%1' does not contain an author part", $mod ) );
        }

        error( loc( "Cannot find '%1' in the module tree", $mod ) );
    }

    return;
}

=pod

=head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );

This method reloads the source files.

If C<update_source> is set to true, this will fetch new source files
from your CPAN mirror. Otherwise, C<reload_indices> will do its
usual cache checking and only update them if they are out of date.

By default, C<update_source> will be false.

The verbose setting defaults to what you have specified in your
config file.

Returns true on success and false on failure.

=cut

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

    my $tmpl = {
        update_source   => { default    => 0, allow => [qr/^\d$/] },
        verbose         => { default    => $conf->get_conf('verbose') },
    };

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

    ### make a call to the internal _module_tree, so it triggers cache
    ### file age
    my $uptodate = $self->_check_trees( %$args );


    return 1 if $self->_build_trees(
                                uptodate    => $uptodate,
                                use_stored  => 0,
                                verbose     => $conf->get_conf('verbose'),
                            );

    error( loc( "Error rebuilding source trees!" ) );

    return;
}

=pod

=head2 $bool = $cb->flush(CACHE_NAME)

This method allows flushing of caches.
There are several things which can be flushed:

=over 4

=item * C<methods>

The return status of methods which have been attempted, such as
different ways of fetching files.  It is recommended that automatic
flushing be used instead.

=item * C<hosts>

The return status of URIs which have been attempted, such as
different hosts of fetching files.  It is recommended that automatic
flushing be used instead.

=item * C<modules>

Information about modules such as prerequisites and whether
installation succeeded, failed, or was not attempted.

=item * C<lib>

This resets PERL5LIB, which is changed to ensure that while installing
modules they are in our @INC.

=item * C<load>

This resets the cache of modules we've attempted to load, but failed.
This enables you to load them again after a failed load, if they 
somehow have become available.

=item * C<all>

Flush all of the aforementioned caches.

=back

Returns true on success and false on failure.

=cut

sub flush {
    my $self = shift;
    my $type = shift or return;

    my $cache = {
        methods => [ qw( methods load ) ],
        hosts   => [ qw( hosts ) ],
        modules => [ qw( modules lib) ],
        lib     => [ qw( lib ) ],
        load    => [ qw( load ) ],
        all     => [ qw( hosts lib modules methods load ) ],
    };

    my $aref = $cache->{$type}
                    or (
                        error( loc("No such cache '%1'", $type) ),
                        return
                    );

    return $self->_flush( list => $aref );
}

=pod

=head2 @mods = $cb->installed()

Returns a list of module objects of all your installed modules.
If an error occurs, it will return false.

See L<CPANPLUS::Module> for the operations you can perform on a
module object.

=cut

sub installed {
    my $self = shift;
    my $aref = $self->_all_installed;

    return @$aref if $aref;
    return;
}

=pod

=head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )