Module-DependencyTree

#!/usr/local/bin/perl

use 5.012;

use strict;
use warnings FATAL => 'all';

use Data::Dump

$|=1;

use MooseX::Declare;
################################################################################
class Module::DependecyTree::Module {
    use Module::CoreList ();
    use Moose::Util::TypeConstraints;
    use version;

    class_type 'version';
    coerce 'version'
      => from 'Str'
        => via { version->parse($_) };

    has qw(cpan_version      is ro isa version coerce 1 required 1);
    has qw(excuse            is ro isa Str), writer => '_set_excuse';
    has qw(installed_version is ro isa version|Undef coerce 1 required 1);
    has qw(is_installed      is ro isa Str);
    has qw(name              is ro isa Str required 1);
   #has qw(required_for      is ro isa Str required 1);

    method is_core() {
        return !! $Module::CoreList::version{$]}{$self->name};
    }

    method needs_to_be_installed() {
        return 1 unless $self->is_installed;
        return $self->cpan_version > $self->installed_version;
    }

    method make_excuse(Module::DependecyTree::Module $parent?) {
        if ($self->needs_to_be_installed) {
            my $u_or_i  = $self->is_installed ? "Upgrade" : "Install";
            my $ver_str = $self->is_installed
                          ? sprintf("%s-->%s", $self->installed_version, $self->cpan_version)
                          : sprintf("%s",      $self->cpan_version);
            my $prereq  = $parent
                          ? sprintf " (prereq of %s %s)", $parent->name, $parent->cpan_version
                          : '';

            my $excuse = sprintf "%s %s (%s)%s",
              $u_or_i, $self->name, $ver_str, $prereq;

            $self->_set_excuse($excuse);
        }
        else {
            $self->_set_excuse(
                sprintf "%s (%s) is up to date",
                  $self->name, $self->installed_version
            )
        }
    }
};

class Module::DependecyTree {
    use Config ();
    use File::Spec ();
    use LWP::Simple ();
    use Module::Extract::VERSION;
    use Moose::Util::TypeConstraints;
    use Parse::CPAN::Packages::Fast;

    # public attr

    has qw(cpandeps_url     is ro isa Str),
      default => 'http://deps.cpantesters.org/';
    has qw(module           is ro isa Str required 1);
    has qw(os               is ro isa Str default Linux);
    has qw(packages_details is ro isa Str required 1);
    has qw(perl_version     is ro isa Str), default => $Config::Config{version};

    # private attr

    has qw(_dependencies    is rw isa HashRef[ArrayRef]),
      default => sub { {} };
    has qw(_modules    is rw isa HashRef[Module::DependecyTree::Module]),
      default => sub { {} };
    has qw(_packages_parser is rw);

    method BUILD {
        my $pp = Parse::CPAN::Packages::Fast->new(
            $self->packages_details
        );
        $self->_packages_parser($pp);
    }

    method build_cpandeps_url() {
        join '', $self->cpandeps_url,
          '?xml=1',
          ';module=', $self->module,
          ';perl=',   $self->perl_version,
          ';os=',     $self->os,
          ';pureperl=0';
    }

    method parse() {
        my $xml = $self->get_xml();
        my @dependencies = split /\s*<dependency>.*?\n/, $xml;
        shift @dependencies;

        my $mods = $self->get_modules(@dependencies);
        $self->_dependencies($self->get_dependencies_of($mods));
    }

    method get_modules(Str @dependencies) {
        my @mods;
        for (@dependencies) {
            my ($mod)     = /<module>(.*?)</;
            my ($depth)   = /<depth>(.*?)</;
            my ($is_core) = /<textresult>(.*?)</;

            next if $is_core;

            say "  " x $depth, "$mod ($depth)";
            push @mods, [ $mod, $depth ];

            my $mdm = Module::DependecyTree::Module->new(
                name              => $mod,
                cpan_version      => $self->get_cpan_version($mod),
                installed_version => $self->get_installed_version($mod),
                is_installed      => !! $self->find_location_of($mod),
            );
            $self->_modules->{$mod} = $mdm;
        }
        return \@mods;
    }

    method get_dependencies_of(ArrayRef[ArrayRef] $mods) {
        $self->_modules->{$mods->[0][0]}->make_excuse;

        my %deps_of;
        for my $i (0..$#$mods) {
            my ($parent, $depth) = @{$mods->[$i]};
            $deps_of{$parent} = [];

            for my $j ($i+1..$#$mods) {
                my ($m, $d) = @{$mods->[$j]};
                if ($d == $depth + 1) {
                    my $mdm = $self->_modules->{$m};
                    $mdm->make_excuse($self->_modules->{$parent});
                    push @{$deps_of{$parent}}, $mdm;
                }
                last
                  if $d <= $depth;
            }
        }
        return \%deps_of;
    }

    method get_cpan_version(Str $mod) {
        my $parser = $self->_packages_parser;
        return $parser->package($mod)->version;
    }

    method get_installed_version(Str $mod) {
        my $path = $self->find_location_of($mod);
        return $path
               ? scalar Module::Extract::VERSION->parse_version_safely($path)
               : undef;
    }

    method find_location_of(Str $mod) {
        my $file .= "$mod.pm";
        $file =~ s{::}{/}g;

        for (@INC) {
            my $path = File::Spec->catfile($_, $file);
            return $path
              if -e $path;
        }
        return;
    }

    method install() {
        $self->install_($self->module, '', $self->_dependencies);
    }

    method install_(Str $mod, Str $parent, HashRef[ArrayRef] $tree) {
        $self->install_($_->name, $mod, $tree)
          for @{$tree->{$mod}};
        say $self->_modules->{$mod}->excuse;
        #"Installing $mod", $parent ? " (prereq of $parent)" : '';
    }

    method print_tree(Str $parent, Int $depth = 0) {
        say '  ' x $depth, "$parent ($depth)";
        $self->print_tree($_, $depth+1)
          for @{$self->_dependencies->{$parent}};
    }

    method get_xml() {
        my $module = $self->module;
        my $file   = "$module.xml";
        $file =~ s/::/-/g;
        return $self->get_xml_from($file)
          if -e $file;

        my $url = $self->build_cpandeps_url;
        my $xml = LWP::Simple::get($url)
          or die "can't fetch $url";

        open my $XML, ">", $file
          or die "can't open $file for writing: $!";

        print $XML $xml;

        return $xml;
    }

    method get_xml_from(Str $filename) {
        open my $XML, "<", $filename
          or die "can't open $filename for reading: $!";

        my $xml = do { local $/; <$XML> };

        return $xml;
    }
};
################################################################################
my $tree = Module::DependecyTree->new(
    module           => 'POE',
    packages_details => '/mirrors/cpan/modules/02packages.details.txt.gz'
);
$tree->parse;
say "===";
$tree->install;