File Coverage

blib/lib/PPM/Make/Bundle.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package PPM::Make::Bundle;

use strict;
use warnings;
use Cwd;
use File::Spec::Functions qw(:ALL);
use File::Copy;
use File::Path;
use PPM::Make;
use PPM::Make::Util qw(:all);
use PPM::Make::Config qw(:all);
use PPM::Make::Search;

our $VERSION = '0.9902';

my @cpan_mirrors = url_list();
my $protocol = qr{^(http|ftp)://};
my $ext = qr{\.(tar\.gz|tgz|tar\.Z|zip)};

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

  my $bundle_name = delete $opts{bundle_name};
  if ($bundle_name) {
    $bundle_name =~ s{$ext$}{} if $bundle_name;
    $bundle_name .= '.zip';
  }

  my $clean = delete $opts{clean};

  my ($arch, $os) = arch_and_os($opts{arch}, $opts{os}, $opts{noas});
  my $has = what_have_you($opts{program}, $arch, $os);

  die "\nInvalid option specification" unless check_opts(%opts);
  my %cfg;
  unless ($opts{no_cfg}) {
    if (my $file = get_cfg_file()) {
      %cfg = read_cfg($file, $arch) or die "\nError reading config file";
    }
  }
  my $opts = %cfg ? merge_opts(\%cfg, \%opts) : \%opts;
  my $search = PPM::Make::Search->new(
    no_remote_lookup => $opts->{no_remote_lookup},
  );

  my $cwd = cwd;
  my $build_dir = catdir(tmpdir, "ppm_make-$$");
  mkdir $build_dir or die qq{Cannot mkdir $build_dir: $!};
  my $self = {cwd => $cwd, opts => $opts, files => {}, name => '',
              build_dir => $build_dir, has => $has, zipdist => $bundle_name,
              clean => $clean, arch => $arch, os => $os,
              search => $search,
              };
  bless $self, $class;
}

sub make_bundle {
  my $self = shift;
  $self->make_package($self->{opts}->{dist}) or return;
  $self->make_zip() or return;
  if ($self->{opts}->{upload}) {
    $self->upload_zip() or return;
  }
  my $cwd = $self->{cwd};
  chdir($cwd) or die qq{Cannot chdir to $cwd: $!};
  if ($self->{clean}) {
    chdir($self->{cwd}) or die qq{Cannot chdir to $self->{cwd}: $!};
    my $build_dir = $self->{build_dir};
    if (-d $build_dir) {
      rmtree($build_dir, 1, 1) or warn qq{Cannot rmtree $build_dir: $!};
    }
  }
  return 1;
}

sub make_package {
  my ($self, $dist, $info) = @_;

  my ($dist_name, $cpan_file);
  if ($dist and $dist !~ /$ext$/) {
    return 1 if (defined $self->{files}->{$dist} or is_ap_core($dist));
    $info = $self->get_info($dist) unless ($info and (ref($info) eq 'HASH'));
    $dist_name = $info->{dist_name};
    $cpan_file = $info->{cpan_file};
  }
  my $name;
 TRY: {
    (not $dist and (-e 'Makefile.PL' || -e 'Build.PL')) and do {
      last TRY if ($name = $self->from_cpan());
    };
    ($dist =~ /$ext$/) and do {
      last TRY if ($name = $self->from_cpan($dist));
    };
    ($dist_name) and do {
      last TRY if ($name = $self->from_repository($dist_name));
    };
    ($cpan_file) and do {
      my $url = $cpan_mirrors[0] . '/authors/id/' . $cpan_file;
      last TRY if ($name = $self->from_cpan($url));
    };
    last TRY if ($name = $self->from_cpan($dist));
    die qq{Cannot build "$dist"};
  }
  $self->{name} ||= $name;
  my $prereqs = $self->{files}->{$name}->{prereqs};
  if ($prereqs and (ref($prereqs) eq 'ARRAY')) {
    foreach my $item(@$prereqs) {
      $self->make_package($item->{dist_name}, $item);
    }
  }
  return 1;
}

sub get_info {
  my ($self, $dist) = @_;
  return if (-f $dist or $dist =~ /^$protocol/ or $dist =~ /$ext$/);
  my $search = $self->{search};
  $dist =~ s{::}{-}g;
  {
    if ($search->search($dist, mode => 'dist')) {
      my $results = $search->{dist_results}->{$dist};
      my $cpan_file = cpan_file($results->{cpanid}, $results->{dist_file});
      my $info = {cpan_file => $cpan_file, dist_name => $results->{dist_name}};
      return $info;
    }
    else {
      $search->search_error(qq{Cannot obtain information on '$dist'});
    }
  }
  return;
}

sub from_cpan {
  my ($self, $pack) = @_;
  my $ppm = PPM::Make->new(%{$self->{opts}}, dist => $pack, no_cfg => 1);
  $ppm->make_ppm();
  my $name;
  if (defined $ppm->{ppd} and defined $ppm->{codebase}) {
    ($name = $ppm->{ppd}) =~ s{\.ppd$}{};
    (my $ar = $ppm->{codebase}) =~ s{.*/([^/]+)$}{$1};
    $self->{files}->{$name} = {cwd => $ppm->{cwd},
                               ppd => $ppm->{ppd},
                               ar => $ar};
  }
  else {
    return;
  }
  my @full_prereqs = keys %{$ppm->{args}->{PREREQ_PM}};
  return $name unless (scalar @full_prereqs > 0);
  my @prereqs = ();
  foreach my $mod(@full_prereqs) {
    push @prereqs, $mod unless ($mod eq 'perl' or is_core($mod));
  }
  my $search = $self->{search};
  {
    if (scalar @prereqs > 0) {
      my $matches = $search->search(\@prereqs, mode => 'mod');
      if ($matches and (ref($matches) eq 'HASH')) {
        foreach my $mod (keys %$matches) {
              my $item = $matches->{$mod};
              my $dist_name = $item->{dist_name};
              next if is_ap_core($dist_name);
              my $cpan_file = cpan_file($item->{cpanid}, $item->{dist_file});
              push @{$self->{files}->{$name}->{prereqs}},
                {dist_name => $dist_name,
                cpan_file => $cpan_file};
        }
      }
    }
  }
  return $name;
}

sub from_repository {
  my ($self, $pack) = @_;
  return if (-f $pack or $pack =~ /^$protocol/ or $pack =~ /$ext$/);
  my $cwd = $self->{build_dir};
  $pack =~ s/::/-/g;
  my $reps = $self->{opts}->{reps};
  return unless $reps;
  my @reps = ref($reps) eq 'ARRAY' ? @$reps : ($reps);
  chdir($cwd) or die qq{Cannot chdir to $cwd: $!};

  my $dist_name = $pack;
  my $ppd_local = $dist_name . '.ppd';
  my $arch = $self->{arch};
  my ($url, $ppd_remote, $info);
  foreach my $item (@reps) {
    if ($item !~ /^$protocol/) {
      $ppd_remote = catfile($item, $ppd_local);
      if (-f $ppd_remote) {
        copy($ppd_remote, $ppd_local) or do {
          warn qq{Cannot copy "$ppd_remote" to "$ppd_local": $!};
          return;
        };
        $info = parse_ppd(catfile($cwd, $ppd_local), $arch);
        next unless ($info and (ref($info) eq 'HASH'));
        my $info_arch = $info->{ARCHITECTURE}->{NAME};
        if ($info_arch  and ($info_arch eq $arch)) {
          $url = $item;
          print qq{\nUsing $ppd_local from $url\n};
          last;
        }
      }
    }
    else {
      $item .= '/' unless $item =~ m{/$};
      my $ppd_remote = $item . $ppd_local;
      if (head($ppd_remote)) {
        if (mirror($ppd_remote, $ppd_local)) {
          $info = parse_ppd(catfile($cwd, $ppd_local), $arch);
          next unless ($info and (ref($info) eq 'HASH'));
          my $info_arch = $info->{ARCHITECTURE}->{NAME};
          if ($info_arch  and ($info_arch eq $arch)) {
            $url = $item;
            print qq{\nUsing $ppd_local from $url\n};
            last;
          }
        }
      }
    }
  }
  return unless (-f $ppd_local);
  return unless ($info and (ref($info) eq 'HASH'));

  my $codebase = $info->{CODEBASE}->{HREF};
  (my $ar_local = $codebase) =~ s{.*?/([^/]+)$}{$1};
  if ($codebase =~ /^$protocol/) {
    my $ar_remote = $codebase;
    return unless mirror($ar_remote, $ar_local);
  }
  elsif ($url !~ /^$protocol/) {
    my $ar_remote = catfile($url, $codebase);
    if (-f $ar_remote) {
      copy($ar_remote, $ar_local) or do {
        warn qq{Cannot copy "$ar_remote" to "$ar_local": $!};
        return;
      };
    }
  }
  else {
    my $ar_remote = $url . $codebase;
    return unless mirror($ar_remote, $ar_local);
  }
  unless (-f $ar_local) {
    warn qq{Cannot get "$ar_local"};
    return;
  }
  (my $name = $ppd_local) =~ s{\.ppd$}{};
  $self->{files}->{$name} = {cwd => $cwd,
                             ppd => $ppd_local,
                             ar => $ar_local};

  my $deps = $info->{DEPENDENCY};
  return 1 unless ($deps and (ref($deps) eq 'ARRAY'));
  foreach my $item (@$deps) {
    my $dist_name = $item->{NAME};
    next if is_ap_core($dist_name);
    push @{$self->{files}->{$name}->{prereqs}}, {dist_name => $dist_name};
  }
  return $name;
}

sub fetch_prereqs {
  my ($self, $ppm) = @_;
  die qq{Please supply a PPM::Make object}
    unless ($ppm and (ref($ppm) eq 'PPM::Make'));

  my @full_prereqs = keys %{$ppm->{args}->{PREREQ_PM}};
  my @prereqs = ();
  foreach my $mod(@full_prereqs) {
    push @prereqs, $mod unless ($mod eq 'perl' or is_core($mod));
  }
  my $search = $self->{search};
  {
    if (scalar @prereqs > 0) {
      my $matches = $search->search(\@prereqs, mode => 'mod');
      if ($matches and (ref($matches) eq 'HASH')) {
        foreach my $mod(keys %$matches) {
            next if is_ap_core($matches->{$mod}->{dist_name});
            print qq{\nFetching prerequisite "$mod"\n};
            my $download = $cpan_mirrors[0] . '/authors/id/' .
              $matches->{$mod}->{download};
            my $ppm = PPM::Make->new(%{$self->{opts}},
                                         no_cfg => 1, dist => $download);
            $ppm->make_ppm();
            (my $name = $ppm->{ppd}) =~ s{\.ppd$}{};
            $self->{files}->{$name} = {cwd => $ppm->{cwd},
                                           ppd => $ppm->{ppd},
                                           ar => $ppm->{codebase}};
            $self->fetch_prereqs($ppm);
        }
      }
    }
  }
}

sub make_zip {
  my $self = shift;
  my $cwd = $self->{build_dir};
  chdir($cwd) or die qq{Cannot chdir to $cwd: $!};
  my $files = $self->{files};
  my $bundle_name = $self->{name};
  foreach my $name(keys %$files) {
    my $item = $self->{files}->{$name};
    my $item_cwd = $item->{cwd};
    next if ($item_cwd eq $cwd);
    my $ppd = $item->{ppd};
    my $ar = $item->{ar};
    copy(catfile($item_cwd, $ppd), $ppd)
      or die qq{Cannot copy $ppd from $item_cwd: $!};
    copy(catfile($item_cwd, $ar), $ar)
      or die qq{Cannot copy $ar from $item_cwd: $!};
  }
  my $ppd_master = $self->{files}->{$bundle_name}->{ppd};
  my $zipdist = $self->{zipdist} ||
    ($bundle_name =~ /^(Bundle|Task)/ ?
     $bundle_name : ('Bundle-' . $bundle_name)) . '.zip';
  if (-f $zipdist) {
    unlink $zipdist or warn "Could not unlink $zipdist: $!";
  }
  my $readme = 'README';
  open(my $fh, '>', $readme) or die "Cannot open $readme: $!";
  print $fh <<"END";
To install this ppm package, run the following command
in the current directory:

   ppm rep add temp_repository file://C:/Path/to/current/directory
   ppm install $ppd_master
   ppm rep del temp_repository_id_number

END
  close $fh;

  my %contents = ($readme => 'README');
  foreach my $name(keys %$files) {
    my $item = $self->{files}->{$name};
    my $item_cwd = $item->{cwd};
    my $ppd = $item->{ppd};
    my $ar = $item->{ar};
    my $ppd_orig = $ppd . '.orig';
    rename($ppd, $ppd_orig) or die "Cannot rename $ppd to $ppd_orig: $!";
    open(my $rfh, '<', $ppd_orig) or die "Cannot open $ppd_orig: $!";
    open(my $wfh, '>', $ppd) or die "Cannot open $ppd: $!";
    while (my $line = <$rfh>) {
      $line =~ s{HREF=\".*/([^/]+)\"}{HREF="$1"};
      print $wfh $line;
    }
    close($rfh);
    close($wfh);
    $contents{$ar} = $ar;
    $contents{$ppd} = $ppd;
  }

  my $zip = $self->{has}->{zip};
  print qq{\nCreating $zipdist ...\n};
  if ($zip eq 'Archive::Zip') {
    my $arc = Archive::Zip->new();
    foreach (sort keys %contents) {
      print "Adding $contents{$_}\n";
      unless ($arc->addFile($_, $contents{$_})) {
        die "Failed to add $_";
      }
    }
    die "Writing to $zipdist failed"
      unless $arc->writeToFileNamed($zipdist) == Archive::Zip::AZ_OK();
  }
  else {
    my @args = ($zip, $zipdist, keys %contents);
    print "@args\n";
    system(@args) == 0 or die "@args failed: $?";
  }
  unless ($self->{opts}->{upload}) {
    my $cwd = $self->{cwd};
    copy($zipdist, $cwd) or warn qq{Cannot copy $zipdist to $cwd: $!};
    print qq{\nCopying $zipdist to $cwd.\n};
  }
  $self->{zipdist} = $zipdist;
  return 1;
}

sub upload_zip {
  my $self = shift;
  my $upload = $self->{opts}->{upload};
  my $bundle_loc = $upload->{bundle};
  my $zipdist = $self->{zipdist};
  my $cwd = $self->{build_dir};
  chdir($cwd) or die qq{Cannot chdir to $cwd: $!};

  if (my $host = $upload->{host}) {
    print qq{\nUploading $zipdist to $host ...\n};
    my ($user, $passwd) = ($upload->{user}, $upload->{passwd});
    die "Must specify a username and password to log into $host"
      unless ($user and $passwd);
    my $ftp = Net::FTP->new($host)
      or die "Cannot connect to $host: $@";
    $ftp->login($user, $passwd)
      or die "Login for user $user failed: ", $ftp->message;
    $ftp->cwd($bundle_loc) or die
      "cwd to $bundle_loc failed: ", $ftp->message;
    $ftp->binary;
    $ftp->put($zipdist)
      or die "Cannot upload $zipdist: ", $ftp->message;
    $ftp->quit;
  }
  else {
    print qq{\nCopying $zipdist to $bundle_loc\n};
    copy($zipdist, "$bundle_loc/$zipdist")
      or die "Cannot copy $zipdist to $bundle_loc: $!";
  }
  print qq{Done!\n};
  return 1;
}

1;

__END__