source.pm

source of perl for linux application,

package CPANPLUS::Internals::Source;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Module;
use CPANPLUS::Module::Fake;
use CPANPLUS::Module::Author;
use CPANPLUS::Internals::Constants;

use File::Fetch;
use Archive::Extract;

use IPC::Cmd                    qw[can_run];
use File::Temp                  qw[tempdir];
use File::Basename              qw[dirname];
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

$Params::Check::VERBOSE = 1;

=pod

=head1 NAME

CPANPLUS::Internals::Source

=head1 SYNOPSIS

    ### lazy load author/module trees ###

    $cb->_author_tree;
    $cb->_module_tree;

=head1 DESCRIPTION

CPANPLUS::Internals::Source controls the updating of source files and
the parsing of them into usable module/author trees to be used by
C<CPANPLUS>.

Functions exist to check if source files are still C<good to use> as
well as update them, and then parse them.

The flow looks like this:

    $cb->_author_tree || $cb->_module_tree
        $cb->_check_trees
            $cb->__check_uptodate
                $cb->_update_source
            $cb->__update_custom_module_sources 
                $cb->__update_custom_module_source
        $cb->_build_trees
            $cb->__create_author_tree
                $cb->__retrieve_source
            $cb->__create_module_tree
                $cb->__retrieve_source
                $cb->__create_dslip_tree
                    $cb->__retrieve_source
            $cb->__create_custom_module_entries                    
            $cb->_save_source

    $cb->_dslip_defs

=head1 METHODS

=cut

{
    my $recurse; # flag to prevent recursive calls to *_tree functions

    ### lazy loading of module tree
    sub _module_tree {
        my $self = $_[0];

        unless ($self->{_modtree} or $recurse++ > 0) {
            my $uptodate = $self->_check_trees( @_[1..$#_] );
            $self->_build_trees(uptodate => $uptodate);
        }

        $recurse--;
        return $self->{_modtree};
    }

    ### lazy loading of author tree
    sub _author_tree {
        my $self = $_[0];

        unless ($self->{_authortree} or $recurse++ > 0) {
            my $uptodate = $self->_check_trees( @_[1..$#_] );
            $self->_build_trees(uptodate => $uptodate);
        }

        $recurse--;
        return $self->{_authortree};
    }

}

=pod

=head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )

Retrieve source files and return a boolean indicating whether or not
the source files are up to date.

Takes several arguments:

=over 4

=item update_source

A flag to force re-fetching of the source files, even
if they are still up to date.

=item path

The absolute path to the directory holding the source files.

=item verbose

A boolean flag indicating whether or not to be verbose.

=back

Will get information from the config file by default.

=cut

### retrieve source files, and returns a boolean indicating if it's up to date
sub _check_trees {
    my ($self, %hash) = @_;
    my $conf          = $self->configure_object;

    my $update_source;
    my $verbose;
    my $path;

    my $tmpl = {
        path            => { default => $conf->get_conf('base'),
                             store => \$path
                        },
        verbose         => { default => $conf->get_conf('verbose'),
                             store => \$verbose
                        },
        update_source   => { default => 0, store => \$update_source },
    };

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

    ### if the user never wants to update their source without explicitly
    ### telling us, shortcircuit here
    return 1 if $conf->get_conf('no_update') && !$update_source;

    ### a check to see if our source files are still up to date ###
    msg( loc("Checking if source files are up to date"), $verbose );

    my $uptodate = 1; # default return value

    for my $name (qw[auth dslip mod]) {
        for my $file ( $conf->_get_source( $name ) ) {
            $self->__check_uptodate(
                file            => File::Spec->catfile( $args->{path}, $file ),
                name            => $name,
                update_source   => $update_source,
                verbose         => $verbose,
            ) or $uptodate = 0;
        }
    }

    ### if we're explicitly asked to update the sources, or if the
    ### standard source files are out of date, update the custom sources
    ### as well
    $self->__update_custom_module_sources( verbose => $verbose ) 
        if $update_source or !$uptodate;

    return $uptodate;
}

=pod

=head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )

C<__check_uptodate> checks if a given source file is still up-to-date
and if not, or when C<update_source> is true, will re-fetch the source
file.

Takes the following arguments:

=over 4

=item file

The source file to check.

=item name

The internal shortcut name for the source file (used for config
lookups).

=item update_source

Flag to force updating of sourcefiles regardless.

=item verbose

Boolean to indicate whether to be verbose or not.

=back

Returns a boolean value indicating whether the current files are up
to date or not.

=cut

### this method checks whether or not the source files we are using are still up to date
sub __check_uptodate {
    my $self = shift;
    my %hash = @_;
    my $conf = $self->configure_object;


    my $tmpl = {
        file            => { required => 1 },
        name            => { required => 1 },
        update_source   => { default => 0 },
        verbose         => { default => $conf->get_conf('verbose') },
    };

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

    my $flag;
    unless ( -e $args->{'file'} && (
            ( stat $args->{'file'} )[9]
            + $conf->_get_source('update') )
            > time ) {
        $flag = 1;
    }

    if ( $flag or $args->{'update_source'} ) {

         if ( $self->_update_source( name => $args->{'name'} ) ) {
              return 0;       # return 0 so 'uptodate' will be set to 0, meaning no 
                              # use of previously stored hashrefs!
         } else {
              msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
              return 1;
         }

    } else {
        return 1;
    }
}

=pod

=head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )

This method does the actual fetching of source files.

It takes the following arguments:

=over 4

=item name

The internal shortcut name for the source file (used for config
lookups).

=item path

The full path where to write the files.

=item verbose

Boolean to indicate whether to be verbose or not.

=back

Returns a boolean to indicate success.

=cut

### this sub fetches new source files ###
sub _update_source {
    my $self = shift;
    my %hash = @_;
    my $conf = $self->configure_object;

    my $verbose;
    my $tmpl = {
        name    => { required => 1 },
        path    => { default => $conf->get_conf('base') },
        verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
    };

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


    my $path = $args->{path};
    {   ### this could use a clean up - Kane
        ### no worries about the / -> we get it from the _ftp configuration, so
        ### it's not platform dependant. -kane
        my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg;

        msg( loc("Updating source file '%1'", $file), $verbose );

        my $fake = CPANPLUS::Module::Fake->new(
                        module  => $args->{'name'},
                        path    => $dir,
                        package => $file,
                        _id     => $self->_id,
                    );

        ### can't use $fake->fetch here, since ->parent won't work --
        ### the sources haven't been saved yet
        my $rv = $self->_fetch(
                    module      => $fake,
                    fetchdir    => $path,
                    force       => 1,
                );


        unless ($rv) {
            error( loc("Couldn't fetch '%1'", $file) );
            return;
        }

        $self->_update_timestamp( file => File::Spec->catfile($path, $file) );
    }

    return 1;
}

=pod

=head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )

This method rebuilds the author- and module-trees from source.

It takes the following arguments:

=over 4

=item uptodate

Indicates whether any on disk caches are still ok to use.

=item path

The absolute path to the directory holding the source files.

=item verbose

A boolean flag indicating whether or not to be verbose.

=item use_stored

A boolean flag indicating whether or not it is ok to use previously
stored trees. Defaults to true.

=back

Returns a boolean indicating success.

=cut

### (re)build the trees ###
sub _build_trees {
    my ($self, %hash)   = @_;
    my $conf            = $self->configure_object;

    my($path,$uptodate,$use_stored);
    my $tmpl = {
        path        => { default => $conf->get_conf('base'), store => \$path },
        verbose     => { default => $conf->get_conf('verbose') },
        uptodate    => { required => 1, store => \$uptodate },
        use_stored  => { default => 1, store => \$use_stored },
    };

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

    ### retrieve the stored source files ###
    my $stored      = $self->__retrieve_source(
                            path        => $path,
                            uptodate    => $uptodate && $use_stored,
                            verbose     => $args->{'verbose'},
                        ) || {};

    ### build the trees ###
    $self->{_authortree} =  $stored->{_authortree} ||
                            $self->__create_author_tree(
                                    uptodate    => $uptodate,
                                    path        => $path,
                                    verbose     => $args->{verbose},
                                );
    $self->{_modtree}    =  $stored->{_modtree} ||
                            $self->_create_mod_tree(
                                    uptodate    => $uptodate,
                                    path        => $path,
                                    verbose     => $args->{verbose},
                                );

    ### return if we weren't able to build the trees ###
    return unless $self->{_modtree} && $self->{_authortree};

    ### update them if the other sources are also deemed out of date
    unless( $uptodate ) {
        $self->__update_custom_module_sources( verbose => $args->{verbose} ) 
            or error(loc("Could not update custom module sources"));
    }      

    ### add custom sources here
    $self->__create_custom_module_entries( verbose => $args->{verbose} )
        or error(loc("Could not create custom module entries"));

    ### write the stored files to disk, so we can keep using them
    ### from now on, till they become invalid
    ### write them if the original sources weren't uptodate, or
    ### we didn't just load storable files
    $self->_save_source() if !$uptodate or not keys %$stored;

    ### still necessary? can only run one instance now ###
    ### will probably stay that way --kane
#     my $id = $self->_store_id( $self );
#
#     unless ( $id == $self->_id ) {
#         error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
#     }

    return 1;
}

=pod

=head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])

This method retrieves a I<storable>d tree identified by C<$name>.

It takes the following arguments:

=over 4

=item name

The internal name for the source file to retrieve.

=item uptodate

A flag indicating whether the file-cache is up-to-date or not.

=item path

The absolute path to the directory holding the source files.

=item verbose

A boolean flag indicating whether or not to be verbose.

=back

Will get information from the config file by default.

Returns a tree on success, false on failure.

=cut

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

    my $tmpl = {
        path     => { default => $conf->get_conf('base') },
        verbose  => { default => $conf->get_conf('verbose') },
        uptodate => { default => 0 },
    };

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

    ### check if we can retrieve a frozen data structure with storable ###
    my $storable = can_load( modules => {'Storable' => '0.0'} )
                        if $conf->get_conf('storable');

    return unless $storable;

    ### $stored is the name of the frozen data structure ###
    my $stored = $self->__storable_file( $args->{path} );

    if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
        msg( loc("Retrieving %1", $stored), $args->{'verbose'} );

        my $href = Storable::retrieve($stored);
        return $href;
    } else {
        return;
    }
}

=pod

=head2 $cb->_save_source([verbose => BOOL, path => $path])

This method saves all the parsed trees in I<storable>d format if
C<Storable> is available.