File Coverage

blib/lib/PPM/Make.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package PPM::Make;
use strict;
use warnings;
use PPM::Make::Config qw(:all);
use PPM::Make::Util qw(:all);
use PPM::Make::Meta;
use PPM::Make::Search;
use Cwd;
use Pod::Find qw(pod_find contains_pod);
use File::Basename;
use File::Path;
use File::Find;
use File::Copy;
use File::Spec;
use Net::FTP;
use Pod::Html;
use XML::Writer;
use version;

our $VERSION = '0.9902';

my $protocol = $PPM::Make::Util::protocol;
my $ext = $PPM::Make::Util::ext;
my $no_case = 0;
my $html = 'blib/html';

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

  die "\nInvalid option specification" unless check_opts(%opts);

  $opts{zip_archive} = 1 if ($opts{binary} and $opts{binary} =~ /\.zip$/);

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

  my %cfg;
#  $opts{no_cfg} = 1 if $opts{install};
  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;

  $no_case = 1 if defined $opts->{no_case};
  my $search = PPM::Make::Search->new(
    no_remote_lookup => $opts->{no_remote_lookup},
  );
  my $self = {
              opts => $opts || {},
              cwd => '',
              has => $has,
              args => {},
              ppd => '',
              archive => '',
              zip => '',
              prereq_pm => {},
              file => '',
              version => '',
              use_mb => '',
              ARCHITECTURE => $arch,
              OS => $os,
              cpan_meta => $opts->{cpan_meta},
              search => $search,
              fetch_error => '',
             };
  bless $self, $class;
}

sub make_ppm {
  my $self = shift;
  die 'No software available to make a zip archive'
    if ( ($self->{opts}->{zip_archive} or $self->{opts}->{zipdist})
        and not $self->{has}->{zip});
  my $dist = $self->{opts}->{dist};
  $self->{org_dir} = my $org_dir = cwd;
  if ($dist) {
    my $build_dir = File::Spec->tmpdir;
    chdir $build_dir or die "Cannot chdir to $build_dir: $!";
    print "Working directory: $build_dir\n";

    my $local_dist = File::Spec->file_name_is_absolute($dist)
      ? $dist
      : File::Spec->catfile($org_dir, $dist);
    if (-f $local_dist) {
      print "Found a local distribution: $local_dist\n";
      my $basename = basename($local_dist);
      copy($local_dist, File::Spec->catfile($build_dir, $basename));
      $self->{search}->{no_remote_lookup} = 0;
    }

    die $self->{fetch_error}
      unless ($dist = $self->fetch_file($dist, no_case => $no_case));
#      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');
  my $force = $self->{opts}->{force};
  $self->{cwd} = cwd;
  print "Working directory: $self->{cwd}\n";
  my $mb = -e 'Build.PL';
  $self->{mb} = $mb;
  die "This distribution requires Module::Build to build"
    if ($mb and not HAS_MB);
  $self->check_script() if $self->{opts}->{script};
  $self->check_files() if $self->{opts}->{add};
  $self->adjust_binary() if $self->{opts}->{arch_sub};
  $self->build_dist()
    unless (-d 'blib' and
            (-f 'Makefile' or ($mb and -f 'Build' and -d '_build'))
            and not $force);

  my $meta = PPM::Make::Meta->new(dir => $self->{cwd},
                                  search => $self->{search},
                                  );
  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};
  }

  if ($self->{version} = $self->{args}->{VERSION}) {
    my $version = version->new($self->{version});
    $self->{version} = $version;
    $self->{version} =~ s/^v//x;
  }
  else {
    warn "Could not extract version information";
  }
  unless ($self->{opts}->{no_html}) {
    $self->make_html() unless (-d 'blib/html' and not $force);
  }
  $dist = $self->make_dist();
  $self->make_ppd($dist);
#  if ($self->{opts}->{install}) {
#    die 'Must have the ppm utility to install' unless HAS_PPM;
#    $self->ppm_install();
#  }
  $self->make_cpan() if $self->{opts}->{cpan};
  $self->make_zipdist($dist)
    if ($self->{opts}->{zipdist} and not $self->{opts}->{no_upload});
  if (defined $self->{opts}->{upload} and not $self->{opts}->{no_upload}) {
    die 'Please specify the location to place the ppd file'
      unless $self->{opts}->{upload}->{ppd};
    $self->upload_ppm();
  }

  if ($org_dir ne $self->{cwd}) {
    for (qw/archive ppd zip/) {
      copy(File::Spec->catfile($self->{cwd}, $self->{$_}), $org_dir) if $self->{$_};
    }
  }

  return 1;
}

sub check_script {
  my $self = shift;
  my $script = $self->{opts}->{script};
  return if ($script =~ m!$protocol!);
  my ($name, $path, $suffix) = fileparse($script, '\..*');
  my $file = $name . $suffix;
  $self->{opts}->{script} = $file;
  return if (-e $file);
  copy($script, $file) or die "Copying $script to $self->{cwd} failed: $!";
}

sub check_files {
  my $self = shift;
  my @entries = ();
  foreach my $file (@{$self->{opts}->{add}}) {
    my ($name, $path, $suffix) = fileparse($file, '\..*');
    my $entry = $name . $suffix;
    push @entries, $entry;
    next if (-e $entry);
    copy($file, $entry) or die "Copying $file to $self->{cwd} failed: $!";
  }
  $self->{opts}->{add} = \@entries if @entries;
}

sub extract_dist {
  my ($self, $file, $build_dir) = @_;

  my $has = $self->{has};
  my ($tar, $gzip, $unzip) = @$has{qw(tar gzip unzip)};

  my ($name, $path, $suffix) = fileparse($file, $ext);
  if (-d "$build_dir/$name") {
      rmtree("$build_dir/$name", 1, 0)
          or die "rmtree of $name failed: $!";
  }
  EXTRACT: {
    if ($suffix eq '.zip') {
      ($unzip eq 'Archive::Zip') && do {
        my $arc = Archive::Zip->new();
        die "Read of $file failed"
          unless $arc->read($file) == Archive::Zip::AZ_OK();
        $arc->extractTree();
        last EXTRACT;
      };
      ($unzip) && do {
        my @args = ($unzip, $file);
        print "@args\n";
        system(@args) == 0 or die "@args failed: $?";
        last EXTRACT;
      };

    }
    else {
      ($tar eq 'Archive::Tar') && do {
        my $arc = Archive::Tar->new($file, 1);
        $arc->extract($arc->list_files);
        last EXTRACT;
      };
      ($tar and $gzip) && do {
        my @args = ($gzip, '-dc', $file, '|', $tar, 'xvf', '-');
        print "@args\n";
        system(@args) == 0 or die "@args failed: $?";
        last EXTRACT;
      };
    }
    die "Cannot extract $file";
  }
  return $name;
}

sub adjust_binary {
  my $self = shift;
  my $binary = $self->{opts}->{binary};
  my $archname = $self->{ARCHITECTURE};
  return unless $archname;
  if ($binary) {
    if ($binary =~ m!$ext!) {
      if ($binary =~ m!/!) {
        $binary =~ s!(.*?)([\w\-]+)$ext!$1$archname/$2$3!;
      }
      else {
        $binary = $archname . '/' . $binary;
      }
    }
    else {
      $binary =~ s!/$!!;
      $binary .= '/' . $archname . '/';
    }
  }
  else {
    $binary = $archname . '/';
  }
  $self->{opts}->{binary} = $binary;
}

sub build_dist {
  my $self = shift;
  my $binary = $self->{opts}->{binary};
  my $script = $self->{opts}->{script};
  my $exec = $self->{opts}->{exec};

  my $has = $self->{has};
  my ($make, $perl) = @$has{qw(make perl)};
  my $mb = $self->{mb};

  my $makepl = $mb ? 'Build.PL' : 'Makefile.PL';
  my @args = ($perl, $makepl);
  if (not $mb and my $makepl_arg = $CPAN::Config->{makepl_arg}) {
    push @args, (split ' ', $makepl_arg);
  }
  print "@args\n";
  system(@args) == 0 or die qq{@args failed: $?};

#  if ($mb) {
#    my $file = 'Build.PL';
#    unless (my $r = do $file) {
#      die "Can't parse $file: $@" if $@;
#      die "Can't do $file: $!" unless defined $r;
#      die "Can't run $file" unless $r;
#    }
#  }
#  else {
#    $self->write_makefile();
#  }

  my $build = 'Build';
  @args = $mb ? ($perl, $build) : ($make);
  if (not $mb and my $make_arg = $CPAN::Config->{make_arg}) {
    push @args, (split ' ', $make_arg);
  }
  print "@args\n";
  system(@args) == 0 or die "@args failed: $?";

  unless ($self->{opts}->{skip}) {
    @args = $mb ? ($perl, $build, 'test') : ($make, 'test');
    print "@args\n";
    unless (system(@args) == 0) {
      die "@args failed: $?" unless $self->{opts}->{ignore};
      warn "@args failed: $?";
    }
  }
  return 1;
}

sub make_html {
  my $self = shift;
  my $args = $self->{args};
  my $cwd = $self->{cwd};
  unless (-d $html) {
    mkpath($html, 1, 0755) or die "Couldn't mkdir $html: $!";
  }
  my %pods = pod_find({-verbose => 1}, "$cwd/blib/");
  if (-d "$cwd/blib/script/") {
    finddepth( sub {
                $pods{$File::Find::name} =
                  "script::" . basename($File::Find::name)
                    if (-f $_ and not /\.bat$/ and contains_pod($_));
              }, "$cwd/blib/script");
  }

  foreach my $pod (keys %pods){
    my @dirs = split /::/, $pods{$pod};
    my $isbin = shift @dirs eq 'script';

    (my $infile = File::Spec->abs2rel($pod)) =~ s!^\w+:!!;
    $infile =~ s!\\!/!g;
    my $outfile = (pop @dirs) . '.html';

    my @rootdirs  = $isbin? ('bin') : ('site', 'lib');
    (my $path2root = "../" x (@rootdirs+@dirs)) =~ s|/$||;

    (my $fulldir = File::Spec->catfile($html, @rootdirs, @dirs)) =~ s!\\!/!g;
    unless (-d $fulldir){
      mkpath($fulldir, 1, 0755)
        or die "Couldn't mkdir $fulldir: $!";
    }
    ($outfile = File::Spec->catfile($fulldir, $outfile)) =~ s!\\!/!g;

    my $htmlroot = "$path2root/site/lib";
    my $podroot = "$cwd/blib";
    my $podpath = join ":" => map { $podroot . '/' . $_ }
      ($isbin ? qw(bin lib) : qw(lib));
    (my $package = $pods{$pod}) =~ s!^(lib|script)::!!;
    my $abstract = parse_abstract($package, $infile);
    my $title =  $abstract ? "$package - $abstract" : $package;
    my @opts = (
                '--header',
                "--title=$title",
                "--infile=$infile",
                "--outfile=$outfile",
                "--podroot=$podroot",
                "--htmlroot=$htmlroot",
                "--css=$path2root/Active.css",
               );
    print "pod2html @opts\n";
    pod2html(@opts);# or warn "pod2html @opts failed: $!";
  }
  ###################################
}

sub make_dist {
  my $self = shift;
  my $args = $self->{args};
  my $has = $self->{has};
  my ($tar, $gzip, $zip) = @$has{qw(tar gzip zip)};
  my $force_zip = $self->{opts}->{zip_archive};
  my $binary = $self->{opts}->{binary};
  my $name;
  if ($binary and $binary =~ /$ext/) {
    ($name = $binary) =~ s!.*/(.*)$ext!$1!;
  }
  else {
    $name = $args->{DISTNAME} || $args->{NAME};
    $name  =~ s!::!-!g;
  }

  $name .= "-$self->{version}"
    if ( ($self->{opts}->{vs} or $self->{opts}->{vsr}) and $self->{version});

  my $is_Win32 = (not $self->{OS} or $self->{OS} =~ /Win32/i
                  or not $self->{ARCHITECTURE} or
                  $self->{ARCHITECTURE} =~ /Win32/i);

  my $script = $self->{opts}->{script};
  my $script_is_external = $script ? ($script =~ /$protocol/) : '';
  my @files;
  if ($self->{opts}->{add}) {
    @files = @{$self->{opts}->{add}};
  }

  my $arc = $force_zip ? ($name . '.zip') : ($name . '.tar.gz');
#  unless ($self->{opts}->{force}) {
#    return $arc if (-f $arc);
#  }
  unlink $arc if (-e $arc);

  DIST: {
    ($tar eq 'Archive::Tar' and not $force_zip) && do {
      $name .= '.tar.gz';
      my @f;
      my $arc = Archive::Tar->new();
      if ($is_Win32) {
        finddepth(sub { push @f, $File::Find::name
                          unless $File::Find::name =~ m!blib/man\d!;
                        print $File::Find::name,"\n"}, 'blib');
      }
      else {
        finddepth(sub { push @f, $File::Find::name;
                        print $File::Find::name,"\n"}, 'blib');
      }
      if ($script and not $script_is_external) {
        push @f, $script;
        print "$script\n";
      }
      if (@files) {
        push @f, @files;
        print join "\n", @files;
      }
      $arc->add_files(@f);
      $arc->write($name, 1);
      last DIST;
    };
    ($tar and $gzip and not $force_zip) && do {
      $name .= '.tar';
      my @args = ($tar, 'cvf', $name);

      if ($is_Win32) {
        my @f;
        finddepth(sub {
                        push @f, $File::Find::name
                          if $File::Find::name =~ m!blib/man\d!;},
                             'blib');
        for (@f) {
          push @args, "--exclude", $_;
        }
      }

      push @args, 'blib';

      if ($script and not $script_is_external) {
        push @args, $script;
      }
      if (@files) {
        push @args, @files;
      }
      print "@args\n";
      system(@args) == 0 or die "@args failed: $?";
      @args = ($gzip, $name);
      print "@args\n";
      system(@args) == 0 or die "@args failed: $?";
      $name .= '.gz';
      last DIST;
    };
    ($zip eq 'Archive::Zip') && do {
      $name .= '.zip';
      my $arc = Archive::Zip->new();
      if ($is_Win32) {
        die "zip of blib failed" unless $arc->addTree('blib', 'blib',
                     sub{$_ !~ m!blib/man\d/!
                           && print "$_\n";}) == Archive::Zip::AZ_OK();
      }
      else {
        die "zip of blib failed" unless $arc->addTree('blib', 'blib',
                              sub{print "$_\n";}) == Archive::Zip::AZ_OK();
      }
      if ($script and not $script_is_external) {
        die "zip of $script failed"
          unless $arc->addFile($script, $script);
        print "$script\n";
      }
      if (@files) {
        for (@files) {
          die "zip of $_ failed" unless $arc->addFile($_, $_);
          print "$_\n";
        }
      }
      die "Writing to $name failed"
        unless $arc->writeToFileNamed($name) == Archive::Zip::AZ_OK();
      last DIST;
    };
    ($zip) && do {
      $name .= '.zip';
      my @args = ($zip, '-r', $name, 'blib');
      if ($script and not $script_is_external) {
        push @args, $script;
        print "$script\n";
      }
      if (@files) {
        push @args, @files;
        print join "\n", @files;
      }
      if ($is_Win32) {
        my @f;
        finddepth(sub {
                        push @f, $File::Find::name
                          unless $File::Find::name =~ m!blib/man\d!;},
                             'blib');
        for (@f) {
          push @args, "-x", $_;
        }
      }

      print "@args\n";
      system(@args) == 0 or die "@args failed: $?";
      last DIST;
    };
    die "Cannot make archive for $name";
  }
  return $name;
}

sub make_ppd {
  my ($self, $dist) = @_;
  my $has = $self->{has};
  my ($make, $perl) = @$has{qw(make perl)};
  my $binary = $self->{opts}->{binary};
  if ($binary) {
    unless ($binary =~ /$ext/) {
      $binary =~ s!/$!!;
      $binary .= '/' . $dist;
    }
  }

  (my $name = $dist) =~ s!$ext!!;
  if ($self->{opts}->{vsr} and not $self->{opts}->{vsp}) {
     $name =~ s/-$self->{version}// if $self->{version};
  }
  if ($self->{opts}->{vsp} and $name !~ m/-$self->{version}/) {
     $name .= "-$self->{version}";
  }
  my $ppd = $name . '.ppd';
  my $args = $self->{args};
  my $os = $self->{OS};
  my $arch = $self->{ARCHITECTURE};
  my $d;

  $d->{SOFTPKG}->{NAME} = $d->{TITLE} = $name;
  $d->{SOFTPKG}->{VERSION} = cpan2ppd_version($self->{version} || 0);
  $d->{OS}->{NAME} = $os if $os;
  $d->{ARCHITECTURE}->{NAME} = $arch if $arch;
  $d->{ABSTRACT} = $args->{ABSTRACT};
  $d->{AUTHOR} = (ref($args->{AUTHOR}) eq 'ARRAY') ?
    (join ', ', @{$args->{AUTHOR}}) : $args->{AUTHOR};
  $d->{CODEBASE}->{HREF} = $self->{opts}->{no_upload} ? $dist :
    ($binary || $dist);
  ($self->{archive} = $d->{CODEBASE}->{HREF}) =~ s!.*/(.*)!$1!;

  if ( my $script = $self->{opts}->{script}) {
    if (my $exec = $self->{opts}->{exec}) {
      $d->{INSTALL}->{EXEC} = $exec;
    }
    if ($script =~ m!$protocol!) {
      $d->{INSTALL}->{HREF} = $script;
      (my $name = $script) =~ s!.*/(.*)!$1!;
      $d->{INSTALL}->{SCRIPT} = $name;
    }
    else {
      $d->{INSTALL}->{SCRIPT} = $script;
    }
  }

  my $search = $self->{search};
  {
    if ($search->search($name, mode => 'dist')) {
      my $mods = $search->{dist_results}->{$name}->{mods};
      if ($mods and (ref($mods) eq 'ARRAY')) {
        foreach my $mod (@$mods) {
          my $mod_name = $mod->{mod_name};
          next unless $mod_name;
          my $mod_vers = $mod->{mod_vers};
          if ($] < 5.10) {
            $mod_name .= '::' unless ($mod_name =~ /::/);
          }
          push @{$d->{PROVIDE}}, {NAME => $mod_name, VERSION => $mod_vers};
        }
      }
    }
    else {
      $search->search_error(qq{Cannot obtain the modules that '$name' provides});
    }
  }
  my $mod_ref;
  foreach my $dp (keys %{$args->{PREREQ_PM}}) {
    next if ($dp eq 'perl' or is_core($dp));
    $dp =~ s{-}{::}g;
    $d->{REQUIRE}->{$dp} = $args->{PREREQ_PM}->{$dp} || 0;
    push @$mod_ref, $dp;
  }
  my %deps = map {$_ => 1} @$mod_ref;
  {
    if ($mod_ref and ref($mod_ref) eq 'ARRAY') {
      if ($search->search($mod_ref, mode => 'mod')) {
        my $matches = $search->{mod_results};
        if ($matches and ref($matches) eq 'HASH') {
          foreach my $dp(keys %$matches) {
            next unless $deps{$dp};
            my $results = $matches->{$dp};
            next unless (defined $results and defined $results->{mod_name});
            my $dist = $results->{dist_name};
            next if (not $dist or $dist =~ m!^perl$!
                      or $dist =~ m!^Test! or is_ap_core($dist));
            $self->{prereq_pm}->{$dist} =
              $d->{DEPENDENCY}->{$dist} =
                cpan2ppd_version($args->{PREREQ_PM}->{$dp} || 0);
          }
        }
        else {
          $search->search_error(qq{Cannot find information on prerequisites for '$name'});
        }
      }
    }
  }
  foreach (qw(OS ARCHITECTURE)) {
    delete $d->{$_}->{NAME} unless $self->{$_};
  }
  $self->print_ppd($d, $ppd);
  $self->{ppd} = $ppd;
}

sub print_ppd {
  my ($self, $d, $fn) = @_;
  open (my $fh, '>', $fn) or die "Couldn't write to $fn: $!";
  my $writer = XML::Writer->new(OUTPUT => $fh, DATA_INDENT => 2);
  $writer->xmlDecl('UTF-8');
  # weird hack to eliminate an empty line after the XML declaration
  $writer->startTag('SOFTPKG', NAME => $d->{SOFTPKG}->{NAME}, VERSION => $d->{SOFTPKG}->{VERSION});
  $writer->setDataMode(1);
  $writer->dataElement(TITLE => $d->{TITLE});
  $writer->dataElement(ABSTRACT => $d->{ABSTRACT});
  $writer->dataElement(AUTHOR => $d->{AUTHOR});
  $writer->startTag('IMPLEMENTATION');

  foreach (sort keys %{$d->{DEPENDENCY}}) {
    $writer->emptyTag('DEPENDENCY' => NAME => $_, VERSION => $d->{DEPENDENCY}->{$_});
  }
  if ($] > 5.008) {
    foreach (sort keys %{$d->{REQUIRE}}) {
      $writer->emptyTag('REQUIRE' => NAME => $_, VERSION => $d->{REQUIRE}->{$_});
    }
  }
  foreach (qw(OS ARCHITECTURE)) {
    next unless $d->{$_}->{NAME};
    $writer->emptyTag($_ => NAME => $d->{$_}->{NAME});
  }

  if (my $script = $d->{INSTALL}->{SCRIPT}) {
    my %attr;
    for (qw/EXEC HREF/) {
      next unless $d->{INSTALL}->{$_};
      $attr{$_} = $d->{INSTALL}->{$_};
    }
    $writer->dataElement('INSTALL', $script, %attr);
  }

  $writer->emptyTag('CODEBASE' => HREF => $d->{CODEBASE}->{HREF});

  my $provide = $d->{PROVIDE};
  unless ($self->{opts}->{no_ppm4}) {
    if ($provide and (ref($provide) eq 'ARRAY')) {
      foreach my $mod(@$provide) {
        my %attr;
        if ($mod->{VERSION}) {
          $attr{VERSION} = $mod->{VERSION};
        }
        $writer->emptyTag('PROVIDE' => NAME => $mod->{NAME}, %attr);
      }
    }
  }
  $writer->endTag('IMPLEMENTATION');
  $writer->endTag('SOFTPKG');
  $writer->end;
  $fh->close;
  $self->{codebase} = $d->{CODEBASE}->{HREF};
}

sub make_zipdist {
  my ($self, $dist) = @_;
  my $ppd = $self->{ppd};
  (my $zipdist = $ppd) =~ s!\.ppd$!.zip!;
  if (-f $zipdist) {
      unlink $zipdist or warn "Could not unlink $zipdist: $!";
  }
  my $cb = $self->{codebase};
  my ($path, $archive, $local);
  if ($cb =~ m!/!) {
    ($path, $archive) = $cb =~ m!(.*)/(.*)!;
    $local = ($path !~ m!(http|ftp)://!
              and not File::Spec->file_name_is_absolute($path) ) ? 1 : 0;
  }
  else {
    $archive = $cb;
  }
  my $readme = 'README.ppm';
  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 install $ppd

END
  close $fh;

  my $ppd_zip = $ppd . '.copy';
  open(my $rfh, '<', $ppd) or die "Cannot open $ppd: $!";
  open(my $wfh, '>', $ppd_zip) or die "Cannot open $ppd_zip: $!";
  while (my $line = <$rfh>) {
    $line =~ s{HREF=\"(http|ftp)://.*/([^/]+)\"}{HREF="$2"};
    print $wfh $line;
  }
  close($rfh);
  close($wfh);

  my $zip = $self->{has}->{zip};
  my $copy = $local ? File::Spec::Unix->catfile($path, $archive) : $archive;
  print qq{\nCreating $zipdist ...\n};
  if ($zip eq 'Archive::Zip') {
    my %contents = ($ppd_zip => $ppd,
                    $archive => $copy,
                    $readme => 'README');
    my $arc = Archive::Zip->new();
    foreach (keys %contents) {
      print "Adding $_ as $contents{$_}\n";
      unless ($arc->addFile($_, $contents{$_})) {
        die "Failed to add $_";
      }
    }
    die "Writing to $zipdist failed"
      unless $arc->writeToFileNamed($zipdist) == Archive::Zip::AZ_OK();
  }
  else {
    if ($path and $local) {
      unless (-d $path) {
        mkpath($path, 1, 0777) or die "Cannot mkpath $path: $!";
      }
      copy($archive, $copy) or die "Cannot cp $archive to $copy: $!";
    }
    rename($ppd, "$ppd.tmp") or die "Cannnot rename $ppd to $ppd.tmp: $!";
    rename($ppd_zip, $ppd) or die "Cannnot rename $ppd_zip to $ppd: $!";

    my @args = ($zip, $zipdist, $ppd, $copy, $readme);
    print "@args\n";
    system(@args) == 0 or die "@args failed: $?";
    rename($ppd, $ppd_zip) or die "Cannnot rename $ppd to $ppd_zip: $!";
    rename("$ppd.tmp", $ppd) or die "Cannnot rename $ppd.tmp to $ppd: $!";
    if ($path and $local and -d $path) {
      rmtree($path, 1, 1) or warn "Cannot rmtree $path: $!";
    }
  }
  $self->{zip} = $zipdist;
  unlink $readme;
  unlink $ppd_zip;
}

sub make_cpan {
  my $self = shift;
  my ($ppd, $archive) = ($self->{ppd}, $self->{archive});
  my %seen;
  my $man = 'MANIFEST';
  my $copy = $man . '.orig';
  unless (-e $copy) {
    rename($man, $copy) or die "Cannot rename $man: $!";
  }
  open(my $orig, '<', $copy) or die "Cannot read $copy: $!";
  open(my $new, '>', $man) or die "Cannot open $man for writing: $!";
  while (<$orig>) {
    $seen{ppd}++ if $_ =~ /$ppd/;
    $seen{archive}++ if $_ =~ /$archive/;
    print $new $_;
  }
  close $orig;
  print $new "\n$ppd\n" unless $seen{ppd};
  print $new "$archive\n" unless $seen{archive};
  close $new;
  my @args = ($self->{has}->{make}, 'dist');
  print "@args\n";
  system(@args) == 0 or die qq{system @args failed: $?};
  return;
}

sub upload_ppm {
  my $self = shift;
  my ($ppd, $archive, $zip) = ($self->{ppd}, $self->{archive}, $self->{zip});
  my $upload = $self->{opts}->{upload};
  my $ppd_loc = $upload->{ppd};
  my $zip_loc = $upload->{zip};
  my $ar_loc = $self->{opts}->{arch_sub} ?
    $self->{ARCHITECTURE} : $upload->{ar} || $ppd_loc;
  if (defined $ar_loc) {
    if (not File::Spec->file_name_is_absolute($ar_loc)) {
      ($ar_loc = File::Spec->catdir($ppd_loc, $ar_loc)) =~ s!\\!/!g;
    }
  }
  if (defined $zip_loc) {
    if (not File::Spec->file_name_is_absolute($zip_loc)) {
      ($zip_loc = File::Spec->catdir($ppd_loc, $zip_loc)) =~ s!\\!/!g;
    }
  }

  if (my $host = $upload->{host}) {
    print qq{\nUploading files 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($ppd_loc) or die
      "cwd to $ppd_loc failed: ", $ftp->message;
    if ($Net::FTP::VERSION eq '2.77') {
      $ftp->binary;
    }
    else {
      $ftp->ascii;
    }
    $ftp->put($ppd)
      or die "Cannot upload $ppd: ", $ftp->message;
    $ftp->cwd($ar_loc)
      or die "cwd to $ar_loc failed: ", $ftp->message;
    $ftp->binary;
    $ftp->put($archive)
      or die "Cannot upload $archive: ", $ftp->message;
    if ($self->{opts}->{zipdist} and -f $zip) {
      $ftp->cwd($zip_loc)
        or die "cwd to $zip_loc failed: ", $ftp->message;
      $ftp->put($zip)
        or die "Cannot upload $zip: ", $ftp->message;
    }
    $ftp->quit;
    print qq{Done!\n};
  }
  else {
    print qq{\nCopying files ....\n};
    copy($ppd, "$ppd_loc/$ppd")
      or die "Cannot copy $ppd to $ppd_loc: $!";
    unless (-d $ar_loc) {
      mkdir $ar_loc or die "Cannot mkdir $ar_loc: $!";
    }
    copy($archive, "$ar_loc/$archive")
      or die "Cannot copy $archive to $ar_loc: $!";
    if ($self->{opts}->{zipdist} and -f $zip) {
      unless (-d $zip_loc) {
        mkdir $zip_loc or die "Cannot mkdir $zip_loc: $!";
      }
      copy($zip, "$zip_loc/$zip")
        or die "Cannot copy $zip to $zip_loc: $!";
    }
    print qq{Done!\n};
  }
}

sub fetch_file {
  my ($self, $dist, %args) = @_;
  my $no_case = $args{no_case};
  my $to;
  if (-f $dist) {
    $to = basename($dist, $ext);
    unless ($dist eq $to) {
      copy($dist, $to) or die "Cannot cp $dist to $to: $!";
    }
    return $to;
  }
  if ($dist =~ m!$protocol!) {
    ($to = $dist) =~ s!.*/(.*)!$1!;
    print "Fetching $dist ....\n";
    my $rc = mirror($dist, $to);
    unless ($rc) {
      $self->{fetch_error} = qq{Fetch of $dist failed.};
      return;
    }
    return $to;
  }
  my $search = $self->{search};
  my $results;
  unless ($dist =~ /$ext$/) {
    my $mod = $dist;
    $mod =~ s!-!::!g;
    if ($search->search($mod, mode => 'mod')) {
      $results = $search->{mod_results}->{$mod};
    }
    unless ($results) {
      $mod =~ s!::!-!g;
      if ($search->search($mod, mode => 'dist')) {
        $results = $search->{dist_results}->{$mod};
      }
    }
    unless ($results->{cpanid} and $results->{dist_file}) {
      $self->{fetch_error} = qq{Cannot get distribution name of '$mod'};
      return;
    }
    $dist = cpan_file($results->{cpanid}, $results->{dist_file});
  }
  my $id = dirname($dist);
  $to = basename($dist, $ext);
  my $src = HAS_CPAN ?
    File::Spec->catdir($src_dir, 'authors/id', $id) :
        $src_dir;
  my $CS = 'CHECKSUMS';
  my $get_cs = 0;
  for my $file( ($to, $CS)) {
    my $local = File::Spec->catfile($src, $file);
    if (-e $local and $src_dir ne $build_dir and not $get_cs) {
      copy($local, '.') or do {
        $self->{fetch_error} = "Cannot copy $local: $!";
        return;
      };
      next;
    }
    else {
      my $from;
      $get_cs = 1;
      foreach my $url(@url_list) {
        $url =~ s!/$!!;
        $from = $url . '/authors/id/' . $id . '/' . $file;
        print "Fetching $from ...\n";
        last if mirror($from, $file);
      }
      unless (-e $file) {
        $self->{fetch_error} = "Fetch of $file from $from failed";
        return;
      }
      if ($src_dir ne $build_dir) {
        unless (-d $src) {
          mkpath($src) or do {
            $self->{fetch_error} = "Cannot mkdir $src: $!";
            return;
          };
        }
        copy($file, $src) or warn "Cannot copy $to to $src: $!";
      }
    }
  }
  return $to unless $to =~ /$ext$/;
  my $cksum;
  unless ($cksum = load_cs($CS)) {
    $self->{fetch_error} = qq{Checksums check disabled - cannot load $CS file.};
    return;
  }
  unless (verifyMD5($cksum, $to)) {
    $self->{fetch_error} =  qq{Checksums check for "$to" failed.};
    return;
  }
  unlink $CS or warn qq{Cannot unlink "$CS": $!\n};
  return $to;
}

1;

__END__