File Coverage

blib/lib/CPAN/Unwind.pm

Criterion	Covered	Total	%
statement	189	214	88.3
branch	33	58	56.9
condition	3	5	60.0
subroutine	34	41	82.9
pod	3	5	60.0
total	262	323	81.1

###########################################
# CPAN::Unwind -- 2005, Mike Schilli
###########################################

###########################################
package CPAN::Unwind;
###########################################

use strict;
use warnings;
use CPAN qw();
use File::Temp qw(tempfile tempdir);
use Log::Log4perl qw(:easy);
use Log::Log4perl::Util;
use Data::Dumper;
use LWP::UserAgent;
use Module::Depends::Intrusive;
use Archive::Tar;
use Storable qw(freeze thaw);
use Cache::FileCache;
use Cache::Cache;
use Cwd;

our $VERSION = "0.06";
our $TGZ     = "tar.tgz";

  # These troublemakers are ignored when listed as a dependency
our %BLACKLISTED = map { $_ => 1 } qw(perl);

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        add          => [],
        core_include => 0,
        %options,
    };

    if(exists $options{cache}) {
        $options{cache} = CPAN::Unwind::Pseudocache->new()
          unless $options{cache};
    } else {
        $self->{cache} = Cache::FileCache->new(
                     {namespace           => "cpan_unwind",
                     });
    }

    bless $self, $class;
}

###########################################
sub tarball_url {
###########################################
    my($self, $mname) = @_;

    my $cpan_url;

    eval {
        require CPAN::Config;
        $cpan_url   = $CPAN::Config->{urllist}->[0];
    };

    $cpan_url    ||= "http://search.cpan.org/CPAN";
    $cpan_url     .= "/modules/by-authors/id";

    my ($fh, $filename) = tempfile(CLEANUP => 1);

    local(*STDOUT);
    local(*STDERR);
    open STDOUT, ">$filename" or die "Can't open $filename";
    open STDERR, ">>$filename" or die "Can't open $filename";

    for my $type (qw(Module Distribution)) {

        DEBUG "Expanding $type/$mname";
        my @expands = CPAN::Shell->expand($type, $mname);

        DEBUG Dumper(\@expands);
        next unless @expands;

        for (@expands) {
            my $f = ($type eq "Module") ? $_->cpan_file : $_->id;
            unlink $filename;
            close STDOUT;
            close STDERR;
            return "$cpan_url/$f";
        }
    }

    unlink $filename;
    close STDOUT;
    close STDERR;

    return undef;
}

###########################################
sub lookup {
###########################################
    my($self, @mnames) = @_;

    my %unresolved = map { ($_ => 1) } @mnames;
    my %resolved   = ();
    my @in_core    = ();

    my $result = CPAN::Unwind::Response->new(mname   => [@mnames],
                                             success => 1);
    $result->{dependency_graph} = Algorithm::Dependency::Source::Mem->new();
    $result->{dependents}       = {};

    while(keys %unresolved) {

        my $mname = (keys %unresolved)[0];

        delete $unresolved{$mname};

        $resolved{$mname}++;

        my $resp = $self->lookup_single($mname);

        return $resp unless $resp->is_success();

        if(!$self->{core_include} and $resp->is_core()) {
            # Mark item as taken care of, it's in the core
            $result->{dependency_graph}->item_select($mname);
        }

        my $deps = $resp->dependent_versions();

        $result->{dependency_graph}->item_add($mname, keys %$deps);
        $result->{dependents}->{$mname} = [];

        for(keys %$deps) {
            DEBUG "Adding dependency $_";
            push @{$result->{dependents}->{$mname}}, $_;

            $unresolved{$_} = 1 unless exists $resolved{$_};

            if(exists $result->{dependent_versions}->{$_}) {
                    # Already got that one, only store it if the
                    # required version number is higher
                if($result->{dependent_versions}->{$_} < $deps->{$_}) {
                    $result->{dependent_versions}->{$_} = $deps->{$_};
                }
            } else {
                $result->{dependent_versions}->{$_} = $deps->{$_};
            }
        }
    }

    return $result;
}

###########################################
sub lookup_single {
###########################################
    my($self, $mname) = @_;

    if($self->{cache}) {
        my $cached = $self->{cache}->get($mname);

        if($cached) {
            my $href = thaw($cached);
            DEBUG "Found $mname deps in cache";
            return CPAN::Unwind::Response->new(
                       mname        => $mname,
                       success      => 1,
                       dependent_versions => $href);
        }
    }

    my $url = $self->tarball_url($mname);

    LOGDIE "Couldn't get tarball for $mname from CPAN" unless defined $url;

        # Don't knock yourself out on modules that are part of the core
    if($url =~ m#/perl-\d#) {
        return CPAN::Unwind::Response->new(
                   mname              => $mname,
                   success            => 1,
                   is_core            => 1,
                   dependent_versions => {} );
    }

    return CPAN::Unwind::Response->new(
               mname              => $mname,
               message => "No tarball found for $mname") unless $url;

    my $tempdir = tempdir(
                      CLEANUP => 1
                  );

    DEBUG "Created tempdir $tempdir";

    my $ua = LWP::UserAgent->new();
    my $resp = $ua->get("$url");

    if($resp->is_error()) {
        return CPAN::Unwind::Response->new(
                   mname   => $mname,
                   message => "Fetching tarball $url failed");
    }

    my $tgzfile = "$tempdir/$TGZ";
    open FILE, ">$tgzfile" or LOGDIE "Can't open $tgzfile ($!)";
    print FILE $resp->content();
    close FILE;

    my $cwd = getcwd();
    chdir $tempdir or LOGDIE "Cannot chdir to $tempdir";

    my $deps = {};

    eval {
        my $tar = Archive::Tar->new();
        $tar->read($TGZ, 1);
        $tar->extract() or LOGDIE "Cannot extract";

        $deps = Module::Depends::Intrusive->new()->
                  dist_dir(subdir_find("."))->find_modules()->requires();

        DEBUG "Found dependent_versions of $mname: ", Dumper($deps);
    };

    delete $deps->{$_} for keys %BLACKLISTED;

    chdir $cwd or LOGDIE "Cannot chdir to $cwd";

    return CPAN::Unwind::Response->new(
               mname   => $mname,
               message => "Determining dependencies failed") if $@;

    if($self->{cache}) {
        DEBUG "Setting cache for $mname";
        $self->{cache}->set($mname, freeze($deps));
    }

    return CPAN::Unwind::Response->new(
               mname              => $mname,
               success            => 1,
               dependent_versions => $deps);
}

###########################################
sub subdir_find {
###########################################
    my($dir) = @_;

    opendir DIR, $dir or LOGDIE "opendir $dir failed ($!)";
    my @dirs = readdir(DIR);
    closedir DIR;

    for(@dirs) {
        next if /^\./;
        next unless -d;
        return $_;
    }

    return undef;
}

###########################################
package CPAN::Unwind::Response;
###########################################
use Algorithm::Dependency::Ordered;
use Log::Log4perl qw(:easy);
use Data::Dumper;

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        is_success         => 0,
        is_core            => 0,
        mname              => [],
        dependent_versions => {},
        message            => "",
        %options,
    };

    bless $self, $class;
}

###########################################
sub is_success { $_[0]->{success} }
###########################################

###########################################
sub is_core { $_[0]->{is_core} }
###########################################

###########################################
sub message { $_[0]->{message} }
###########################################

###########################################
sub dependent_versions { return $_[0]->{dependent_versions} }
###########################################

###########################################
sub dependents { return $_[0]->{dependents} }
###########################################

###########################################
sub missing {
###########################################
    my($self) = @_;

    my %missing = map { $_ => $self->{dependent_versions}->{$_} }
                  grep { ! Log::Log4perl::Util::module_available($_) }
                       keys %{$self->{dependent_versions}};
    return \%missing;
}

###########################################
sub schedule {
###########################################
    my($self) = @_;

    DEBUG "Dependency graph: ", Dumper($self->{dependency_graph});

    my $dep = Algorithm::Dependency::Ordered->new(
        source   => $self->{dependency_graph},
        selected => $self->{dependency_graph}->{selected},
    ) or die "Failed to set up dependency algorithm";

    my $schedule = $dep->schedule(@{$self->{mname}});

    LOGDIE "Cannot determine schedule for @{$self->{mname}}" unless $schedule;
    return @$schedule;
}

sub CORE::GLOBAL::exit { }

################################################
package Algorithm::Dependency::Source::Mem;
################################################
use base qw(Algorithm::Dependency::Source);
use Algorithm::Dependency::Item;
use Log::Log4perl qw(:easy);

################################################
sub new {
################################################
    my($class) = @_;

    # Get the basic source object
    my $self = $class->SUPER::new() or return undef;

    # Add our arguments
    $self->{deps} = [];
    $self;
}

#######################################
sub item_add {
#######################################
    my($self, $item, @deps) = @_;

    DEBUG "Adding $item - (", join(', ', @deps), ")";

    push @{$self->{deps}}, [$item, @deps];
}

#######################################
sub item_select {
#######################################
    my($self, $item) = @_;

    DEBUG "Selecting $item";

    push @{$self->{selected}}, $item;
}

#######################################
sub _load_item_list {
#######################################
    my($self) = @_;

    my @items;

    for(@{$self->{deps}}) {
        my $item = Algorithm::Dependency::Item->new(@$_);
        push @items, $item;
    }

    return \@items;
}

###########################################
package CPAN::Unwind::Pseudocache;
###########################################
sub new { bless {}, shift }
sub get { return undef; }
sub set { }

1;

__END__