File Coverage

lib/Haul.pm

Criterion	Covered	Total	%
statement	85	145	58.6
branch	14	38	36.8
condition	2	14	14.2
subroutine	17	20	85.0
pod	5	7	71.4
total	123	224	54.9

package Haul;
use strict;
use Cwd;
use CPAN::DistnameInfo;
use File::Basename;
use File::Copy;
use File::Path;
use IPC::Run3;
use Module::Depends::Intrusive;
use vars qw($VERSION);
$VERSION = '2.24';

sub new {
  my $class = shift;
  my $self = {};
  bless $self, $class;
  $self->_init(@_);
  return $self;
}

sub fetch {
  my $self = shift;
  my $what = shift;
  my $prefix;
  if (exists $self->{modules}->{$what}) {
    $prefix = $self->{modules}->{$what};
#  } elsif (exists $self->{distributions}->{$what}) {
#    $prefix = $self->{distributions}->{$what};
  } else {
    die "Could not find $what";
  }
  my $path = "authors/id/" . $prefix;
  my $filename = $self->_fetch($path);
  return $filename;
}

sub extract {
  my $self = shift;
  my $what = shift;
  my $filename = $self->fetch($what);

  my $d = CPAN::DistnameInfo->new($filename);
  my $dir = $d->distvname;

  return $dir if -d $dir;

  if ($filename =~ /\.tar\.gz$/ || $filename =~ /\.tgz$/) {
    $self->_extract_aux("tar xzf ../$filename", $dir);
  }

  die "failed to extract" unless -d $dir;
  return $dir;
}

sub _extract_aux {
  my $self = shift;
  my $command = shift;
  my $dir = shift;

  mkdir "test";
  chdir "test";
  system($command);

  my @dirs = grep { -d $_ } <*>;
  my @files = grep { -f $_ } <*>;
  if (@files) {
    chdir "..";
    move("test", $dir);
    return;
  }
  if (scalar(@dirs) == 1) {
    move($dirs[0], "../$dir");
    rmdir "test";
    chdir "..";
    return;
  } else {
    chdir "..";
    move("test", $dir);
    return;
  }
}

sub install {
  my $self = shift;
  my $what = shift;
  my $dir = $self->extract($what);
  my $perl = $self->perl;

  my $deps = Module::Depends::Intrusive->new->dist_dir($dir)->find_modules;
  my $requires = $deps->requires;

  foreach my $module (keys %$requires) {
    my $version = $requires->{$module};
    my $installed = $self->installed($module);
    next if defined $installed && $version <= $installed;
#    warn "need to install $module ($version > $installed)";
    $self->install($module);
    $installed = $self->installed($module);
    next if defined $installed && $version <= $installed;
    die "failed to install $module";
  }

  my $cwd = cwd;
  chdir $dir;
  if (-f "Makefile.PL") {
    $self->run($perl, "Makefile.PL");
    $self->run("make");
    $self->run("make", "test");
    $self->run("make", "install");
    my $installed = $self->installed($what);
    die "$what failed to install" unless $installed;
  } else {
    die "need code here to install $dir";
  }
  chdir $cwd;
}

sub run {
  my $self = shift;
  my @commands = @_;
  my($out, $err);
#  warn "(@commands)\n";
  run3 [@commands], \undef, \$out, \$err;
#warn "[STDERR: $err]\n";
  return($out, $err);
}

sub installed {
  my $self = shift;
  my $module = shift;
  my $perl = $self->perl;

  my $code;

  if ($module eq 'perl') {
    $code = qq(print "VERSION IS $]\n");
  } else {
    $code = qq(use $module; print 'VERSION IS ' . \$${module}::VERSION . "\n");
  }

  my $command = "$perl -e '$code'";

  my($in, $out, $err);
  run3 [$perl, '-e', $code], \$in, \$out, \$err;

  return if $err;
  my($version) = $out =~ /VERSION IS (.+)\n/;
  return $version || "0E0";
}

sub _init {
  my($self, %conf) = @_;

  $self->perl($conf{perl} || $^X);
  $self->_parse_packages_details;
}

sub perl {
  my($self, $perl) = @_;
  if (defined $perl) {
    die "perl not at $perl" unless -f $perl;
    $self->{perl} = $perl;
  } else {
    return $self->{perl};
  }
}

sub _parse_packages_details {
  my $self = shift;
  my $filename = $self->_fetch("modules/02packages.details.txt.gz");
  open(IN, "zcat $filename |");
  # skip the header
  while(my $line = ) {
    last if $line eq "\n";
  }
  while(my $line = ) {
    chomp $line;
    my($module, $moduleversion, $prefix) = split ' ', $line;
    die "$line = $module/$moduleversion/$prefix" unless defined $prefix;
    $self->{modules}->{$module} = $prefix;
#    my $d = CPAN::DistnameInfo->new($prefix);
#    my $dist = $d->dist;
#    my $distversion = $d->version;
#    my $distvname = $d->distvname;
#    next unless $dist;
#    next unless $distversion; # ignore stupid packages
#    $self->{distributions}->{$dist} = $prefix;
  }
  close(IN);
}

sub _fetch {
  my $self = shift;
  my $path = shift;
  my $basename = basename($path);
  my $url = "http://www.cpan.org/$path";

  if ($path =~ m{/perl-5\.}) {
    die "do not install perl";
  }

  unless (-f $basename) {
    system("wget -N $url");
  }
  die "Error fetching $url" unless -f $basename;
  return $basename;
}

1;

__END__