File Coverage

blib/lib/Alien/Build/Plugin/Fetch/NetFTP.pm

Criterion	Covered	Total	%
statement	29	86	33.7
branch	2	42	4.7
condition	2	8	25.0
subroutine	8	10	80.0
pod	1	1	100.0
total	42	147	28.5

package Alien::Build::Plugin::Fetch::NetFTP;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use Carp ();
use File::Temp ();
use Path::Tiny qw( path );

# ABSTRACT: Plugin for fetching files using Net::FTP
our $VERSION = '2.46'; # VERSION


has '+url' => '';


has ssl => 0;


has passive => 0;

sub init
{
  my($self, $meta) = @_;

  $meta->prop->{start_url} ||= $self->url;
  $self->url($meta->prop->{start_url});
  $self->url || Carp::croak('url is a required property');

  $meta->add_requires('share' => 'Net::FTP' => 0 );
  $meta->add_requires('share' => 'URI' => 0 );
  $meta->add_requires('share' => 'Alien::Build::Plugin::Fetch::NetFTP' => '0.61')
    if $self->passive;

  $meta->register_hook( fetch => sub {
    my($build, $url, %options) = @_;
    $url ||= $self->url;

    $build->log("plugin Fetch::NetFTP does not support http_headers option") if $options{http_headers};

    $url = URI->new($url);

    die "Fetch::NetFTP does not support @{[ $url->scheme ]}"
      unless $url->scheme eq 'ftp';

    $build->log("trying passive mode FTP first") if $self->passive;
    my $ftp = _ftp_connect($url, $self->passive);

    my $path = $url->path;

    unless($path =~ m!/$!)
    {
      my(@parts) = split /\//, $path;
      my $filename = pop @parts;
      my $dir      = join '/', @parts;

      my $path = eval {
        $ftp->cwd($dir) or die;
        my $tdir = File::Temp::tempdir( CLEANUP => 1);
        my $path = path("$tdir/$filename")->stringify;

        unless(eval { $ftp->get($filename, $path) }) # NAT problem? try to use passive mode
        {
          $ftp->quit;

          $build->log("switching to @{[ $self->passive ? 'active' : 'passive' ]} mode");
          $ftp = _ftp_connect($url, !$self->passive);

          $ftp->cwd($dir) or die;

          $ftp->get($filename, $path) or die;
        }

        $path;
      };

      if(defined $path)
      {
        return {
          type     => 'file',
          filename => $filename,
          path     => $path,
        };
      }

      $path .= "/";
    }

    $ftp->quit;
    $ftp = _ftp_connect($url, $self->passive);
    $ftp->cwd($path) or die "unable to fetch $url as either a directory or file";

    my $list = eval { $ftp->ls };
    unless(defined $list) # NAT problem? try to use passive mode
    {
      $ftp->quit;

      $build->log("switching to @{[ $self->passive ? 'active' : 'passive' ]} mode");
      $ftp = _ftp_connect($url, !$self->passive);

      $ftp->cwd($path) or die "unable to fetch $url as either a directory or file";

      $list = $ftp->ls;

      die "cannot list directory $path on $url" unless defined $list;
    }

    die "no files found at $url" unless @$list;

    $path .= '/' unless $path =~ /\/$/;

    return {
      type => 'list',
      list => [
        map {
          my $filename = $_;
          my $furl = $url->clone;
          $furl->path($path . $filename);
          my %h = (
            filename => $filename,
            url      => $furl->as_string,
          );
          \%h;
        } sort @$list,
      ],
    };

  });

  $self;
}

sub _ftp_connect {
  my $url = shift;
  my $is_passive = shift || 0;

  my $ftp = Net::FTP->new(
    $url->host, Port =>$url->port, Passive =>$is_passive,
  ) or die "error fetching $url: $@";

  $ftp->login($url->user, $url->password)
    or die "error on login $url: @{[ $ftp->message ]}";

  $ftp->binary;

  $ftp;
}

1;

__END__