File Coverage

blib/lib/PPM/Make/Install.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package PPM::Make::Install;
use strict;
use warnings;
use base qw(PPM::Make);
use File::Path;
use PPM::Make::Util qw(:all);
use PPM::Make::Config qw(:all);
use PPM::Make::Meta;
use Config;
use Cwd;
require File::Spec;

our $VERSION = '0.9902';
my $fetch_error;

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

  die "\nInvalid option specification" unless check_opts_install(%opts);
  die "Must have the ppm utility to install" unless HAS_PPM;
  my $arch = $Config{archname};
  my $os = $Config{osname};
  if ($] >= 5.008) {
    my $vstring = sprintf "%vd", $^V;
    $vstring =~ s/\.\d+$//;
    $arch .= "-$vstring";
  }
  my $has = what_have_you($opts{program}, $arch, $os);
  my $self = {
              opts => \%opts || {},
              cwd => '',
              has => $has,
              args => {},
              ppd => '',
              archive => '',
          prereq_pm => {},
              file => '',
              version => '',
          use_mb => '',
              ARCHITECTURE => $arch,
              OS => $os,
             };
  bless $self, $class;
}

sub check_opts_install {
  my %opts = @_;
  my %legal =
    map {$_ => 1} qw(force ignore dist program upgrade remove skip);
  foreach (keys %opts) {
    next if $legal{$_};
    warn "Unknown option '$_'\n";
    return;
  }

  if (defined $opts{program} and my $progs = $opts{program}) {
    unless (ref($progs) eq 'HASH') {
      warn "Please supply a HASH reference to 'program'";
      return;
    }
    my %ok = map {$_ => 1} qw(zip unzip tar gzip make);
    foreach (keys %{$progs}) {
      next if $ok{$_};
      warn "Unknown program option '$_'\n";
      return;
    }
  }
  return 1;
}

sub make_ppm {
  my $self = shift;
  my $dist = $self->{opts}->{dist};
  if ($dist) {
    my $build_dir = File::Spec->tmpdir;
    chdir $build_dir or die "Cannot chdir to $build_dir: $!";
    print "Working directory: $build_dir\n";
    unless ($dist = $self->fetch_file($dist)) {
      die $self->{fetch_error};
    }
#      if ($dist =~ m!$protocol!
#          or $dist =~ m!^\w/\w\w/! or $dist !~ m!$ext!);
    print "Extracting files from $dist ....\n";
    my $name = $self->extract_dist($dist, $build_dir);
    chdir $name or die "Cannot chdir to $name: $!";
    $self->{file} = $dist;
  }
  die "Need a Makefile.PL or Build.PL to build"
    unless (-f 'Makefile.PL' or -f 'Build.PL');
  $self->{cwd} = cwd;
  my $mb = -e 'Build.PL';
  $self->{mb} = $mb;
  my $force = $self->{opts}->{force};
  die "This distribution requires Module::Build to build"
    if ($mb and not HAS_MB);
  $self->build_dist()
      unless (-d 'blib' and (-f 'Makefile' or ($mb and -f 'Build') )
              and not $force);
  my $meta = PPM::Make::Meta->new(dir => $self->{cwd});
  die qq{Creating PPM::Make::Meta object failed}
    unless ($meta and (ref($meta) eq 'PPM::Make::Meta'));
  $meta->meta();
  foreach my $key( keys %{$meta->{info}}) {
    next unless defined $meta->{info}->{$key};
    $self->{args}->{$key} ||= $meta->{info}->{$key};
  }
  for my $search_info(qw(dist_search mod_search)) {
    next unless defined $meta->{$search_info};
    $self->{$search_info} = $meta->{$search_info};
  }
  $self->{version} = (defined $self->{args}->{VERSION_FROM}) ?
    parse_version($self->{args}->{VERSION_FROM}) :
      ($self->{args}->{VERSION});
  $self->make_html() unless (-d 'blib/html' and not $force);
  $dist = $self->make_dist();
  $self->make_ppd($dist);
  return 1;
}

sub ppm_install {
  my $self = shift;
  my $cwd = $self->{cwd};
  (my $package = $self->{ppd}) =~ s!\.ppd$!!;
  my $version = $self->{version};
  print "Installing $package ...\n";
  if (HAS_PPM >= 3) {
    my @args = $self->{opts}->{upgrade} ?
      ('ppm', 'upgrade', $self->{ppd}) :
        ('ppm', 'install', $self->{ppd});
    system(@args) == 0 or die "Cannot install/upgrade $self->{ppd}: $?";
  }
  else {
    my @args = $self->{opts}->{upgrade} ?
      ('ppm', 'verify', '--upgrade', $self->{ppd}) :
        ('ppm', 'install', $self->{ppd});
    system(@args) == 0 or die "Cannot install/upgrade $self->{ppd}: $?";
  }
  return unless $self->{opts}->{remove};
  my $file = $self->{file};
  unless ($file) {
    warn "Cannot clean files unless a distribution is specified";
    return;
  }
  if (-f "../$file") {
    print "Removing $cwd/../$file ....\n";
    unlink "$cwd/../$file" or warn "Cannot unlink $cwd/../$file: $!";
  }
  chdir('..') or die "Cannot move up one directory: $!";
  if (-d $cwd) {
    print "Removing $cwd ...\n";
    rmtree($cwd) or warn "Cannot remove $cwd: $!";
  }
  return 1;
}

1;

__END__