treedeps/lib/Module.pm

package Module;
use 5.22.0;
use Moose;
use Dist;
use Module::CoreList;
use Storable;
use IPC::Run qw/run/;
no warnings 'experimental';
use Carp qw/croak carp cluck confess/;

has 'name' => (is => 'ro');
has 'dist' => (is => 'ro',
	builder => '_get_dist',
	lazy => 1);

has 'depends' => (
    builder => 'get_deps',
    is => 'ro',
    isa => 'ArrayRef[Module]',
    lazy => 1,
);

sub _get_dist {
	my $self = shift;
	return $Dist::mod_to_dist{$self->name} // $self->name;
}

our %cache;
our %rev_depcache;

if (-e 'modcache.stor') {
    eval {
      my $cache_href=retrieve('modcache.stor');
      %cache = $cache_href->%*;
    };
    if ($@) {
        print STDERR "Couldn't load cache $@\n";
    }
}
if (-e 'revdepcache.stor') {
    eval {
      my $cache_href=retrieve('revdepcache.stor');
      %rev_depcache = $cache_href->%*;
    };
    if ($@) {
        print STDERR "Couldn't load cache $@\n";
    }
}

sub __save_cache {
 store \%cache, 'modcache.stor';
 store \%rev_depcache, 'revdepcache.stor';
};
END {__save_cache};

sub new_module {
    my $class = shift;
    my $module = shift;
    confess "\n\nNo module name given\n" unless $module;
    my ($name, $version) = split (/[\-~]/, $module);


    my $dist = $Dist::mod_to_dist{$name} // $name;

    return $cache{$dist} if exists $cache{$dist};

    $cache{$dist} = Module->new(name => $name);
}

{
    my @banned = do {open (my $fh, "<banned.lst"); map {chomp; $Dist::mod_to_dist{$_} // $_} <$fh>};
    use Data::Dumper;
    sub _is_banned {
        my $module = shift;
        my $dist = $Dist::mod_to_dist{$module} // $module;

        return _is_core($module) || ($dist ~~ @banned);
    }
}

sub _is_core {
    my $module = shift;
    my ($name, $version) = split (/[\-~]/, $module);

    return 0 unless $name;

    my $ret = ($name eq 'perl' || Module::CoreList->first_release($name)) // 0;

    return $ret;
}

sub get_deps {
    my $self=shift;
    my $module = $self->name;

    # skip perl, or core modules
    return [] if _is_banned($module);

    print "Getting deps for $module\n";
    my @cmd = (qw|cpanm --quiet --showdeps|, $module);

    $SIG{TERM}="ignore";
    my $out;
    my $ret = run \@cmd, '>&', \$out;

    die "Failed to get deps for $module: $?" unless $ret;



    my $deps = [map {Module->new_module($_)} grep {!_is_core($_)} grep {defined $_ && $_ !~ /^\s*$/} split($/, $out)];
    __save_cache;
    return $deps;
}

sub print_deps {
  my $self = shift;
  $self->_print_deps(0, []);
}

sub _print_deps {
    my ($self, $level, $v) = @_;

    for my $dep ($self->depends->@*) {
        my $name = $dep->name;
        print ((" " x $level), $name, "\n");
        $dep->_print_deps($level+1, [@$v, $name]) unless ($name ~~ @$v);
    }
}

sub depends_on {
  my ($self, $module) = @_;

  my $dist = $module->_get_dist();

  for my $dep ($self->depends->@*) {
    return 1 if $dep->_get_dist eq $dist;
  }

  return 0;
}

# Look at all failed modules, see if they might have depended on us.
sub get_failed_descendants {
  my $self = shift;
  my $candidates = shift;
  my $level = shift || 0;
  my $loop = shift || [];

  my $sdist = $self->_get_dist;
  if (grep {$_->_get_dist eq $sdist} @$loop) {
    print STDERR "Loop detected with ", $self->name, ".  Short circuiting\n";
    return();
  }

  if (ref($rev_depcache{$self->name}) eq 'ARRAY') {
    return $rev_depcache{$self->name}->@*;
  }

  my @total;

  my $c=1;
  for my $mod_name (@$candidates) {
    print STDERR sprintf "%03d %05d\r", $level, $c++;
    my $module = Module->new_module($mod_name);

    if ($module->depends_on($self)) {
      push @total, $module, $module->get_failed_descendants($candidates, $level+1, [@$loop, $self]);
    }
  }

  print STDERR "\n";

  $rev_depcache{$self->name} = [@total];
  __save_cache;
  return @total;
}

1;