File Coverage

lib/Net/FTP/Robust.pm

Criterion	Covered	Total	%
statement	24	150	16.0
branch	0	70	0.0
condition	0	45	0.0
subroutine	8	20	40.0
pod	2	4	50.0
total	34	289	11.7

# Copyrights 2009-2018 by [Mark Overmeer].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution Net-FTP-Robust.  Meta-POD processed
# with OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package Net::FTP::Robust;
use vars '$VERSION';
$VERSION = '0.09';


use warnings;
use strict;

use Log::Report 'net-ftp-robust', syntax => 'SHORT';
use Net::FTP;
use Time::HiRes qw/gettimeofday tv_interval/;

use Data::Dumper;

sub size_short($);
use constant
  { GB => 1024 * 1024 * 1024
  , MB => 1024 * 1024
  , kB => 1024
  };


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

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

    # delete all my own options from the %$args
    $self->{login_attempts}
       = defined $args->{login_attempts} ? delete $args->{login_attempts} : 10;

    # probably, some people will attempt lowercased 'host'
    $args->{Host}         ||= delete $args->{host};

    $self->{login_user}     = delete $args->{user}        || 'anonymous';
    $self->{login_password} = delete $args->{password}    || '-anonymous@';
    $self->{login_delay}    = delete $args->{login_delay} || 60;

    $self->{skip_names}     = delete $args->{skip_names}
       || sub { $_[2] =~ m/^\./ };  # UNIX hidden files

    $self->{ftp_opts}       = $args;
    $self;
}


sub _connect($)
{   my ($self, $opts) = @_;
    my $ftp  = Net::FTP->new(%$opts);
    my $err  = defined $ftp ? undef : $@;
    ($ftp, $err);
}

sub get($$)
{   my ($self, $from, $to) = @_;

    $to = File::Spec->curdir
        unless defined $to && length $to;
    $from =~ s,^/?,/,g;  # ensure leading /

    my $retries = $self->{login_attempts} || 1_000_000;
    my $success = 0;

  ATTEMPT:   # see continue block at end
    foreach my $attempt (1..$retries)
    {   info __x"connection attempt {nr}{max}"
          , nr => $attempt, max => ($retries ? " of $retries" : '')
            if $attempt != 1;

        my ($ftp, $err) = $self->_connect($self->{ftp_opts});
        unless($ftp)
        {   notice __x"cannot establish contact: {err}", err => $err;
            next ATTEMPT;
        }

        unless( $ftp->login($self->{login_user}, $self->{login_password}))
        {   notice __x"login failed: {msg}", msg => ($ftp->message || $!);
            next ATTEMPT;
        }

        $ftp->binary;
        my ($dir, $base) = $from =~ m!^(?:(.*)/)?([^/]*)!;
        $dir ||= '/';
        unless($ftp->cwd($dir))
        {   notice __x"directory {dir} does not exist: {msg}"
              , dir => $dir, msg => ($ftp->message || $!);
            next ATTEMPT;
        }

        my $stats   = $self->{stats}
                    = { files => 0, new_files => 0, downloaded => 0 };
        my $start   = [ gettimeofday ];
        $success    = $self->_recurse($ftp, $dir, $base, $to);
        my $elapsed = tv_interval $start;

        $success
            or notice __x"attempt {nr} unsuccessful", nr => $attempt;

        info __x"Got {new} new files, {size} in {secs}s avg {speed}/s"
          , new   => $stats->{new_files}
          , total => $stats->{files}
          , size  => size_short($stats->{downloaded})
          , secs  => int($elapsed)
          , speed => size_short($stats->{downloaded} / $elapsed);

        $ftp->close;

        last if $success;
    }
    continue
    {   sleep $self->{login_delay};
    }

    $success;
}

sub _recurse($$$$)
{   my ($self, $ftp, $dir, $entry, $to) = @_;

    my $full = $dir . $entry;
    if($self->{skip_names}->($ftp, $full, $entry))
    {   trace "skipping $full";
        return 1;
    }

    if(!length $entry)
    {   -d $to || mkdir $to
            or fault __x"cannot create directory {dir}", dir => $to;

        return $self->_get_directory($ftp, $dir, $to);
    }
    elsif($ftp->cwd($entry))
    {   # Entering directory
        $to = File::Spec->catdir($to, $entry);

        -d $to || mkdir $to
            or fault __x"cannot create directory {dir}", dir => $to;

        $full .= '/' if $full ne '/';
        my $success = $self->_get_directory($ftp, $full, $to);
        if($success)
        {   $success = $ftp->cdup
                or notice __x"cannot go cdup to {dir}: {msg}"
                     , dir => $dir, msg => ($ftp->message || $!);
        }
        return $success;
    }

    $self->_get_file($ftp, $dir, $entry, $to);
}

sub _ls($) { $_[1]->ls }

sub _get_directory($$$)
{   my ($self, $ftp, $where, $to) = @_;
    my @entries = $self->_ls($ftp);

    trace "directory $where has ".@entries. " entries";

    foreach my $entry (@entries)
    {   my $success = $self->_recurse($ftp, $where, $entry, $to);
        $success or return 0;
    }

    1;
}

# Different in Net::FTPSSL
sub _modif_time($$)
{   my ($self, $ftp, $fn) = @_;
    $ftp->mdtm($fn) || 0;
}

sub _can_restart($$$$)
{   my ($self, $ftp, $name, $temp, $expected_size) = @_;
    my $got_size = -s $temp || 0;
    $got_size or return 0;

    # download did not complete last time
    my $to_download   = $expected_size - $got_size;
    info "continue file $name, got " . size_short($got_size)
       . " from " . size_short($expected_size)
       . ", needs " . size_short($to_download);

    $ftp->restart($got_size);
    $got_size;
}

sub _get_file($$$$)
{   my ($self, $ftp, $dir, $base, $to) = @_;

    my $remote_name = $dir . $base;
    my $local_name  = "$to/$base";
    my $local_temp  = "$to/.$base";

    my $remote_mtime = $self->_modif_time($ftp, $base);
    my $stats        = $self->{stats};
    $stats->{files}++;

    if(-e $local_name)
    {   # file already downloaded, still valid?
        if(! -f $local_name)
        {   # not downloadable
            notice __x"download file {fn}, but already exists as non-file"
              , fn => $local_name;
            return 1;
        }

        my $local_mtime = (stat $to)[9];
        if($remote_mtime && $local_mtime >= $remote_mtime)
        {   trace "file $remote_name already downloaded";
            return 1;
        }

        trace "local file $local_name is outdated";
        # continue as if the file does not exist
    }

    my $expected_size = $ftp->size($base);
    my $got_size
       = $self->_can_restart($ftp, $local_name, $local_temp, $expected_size)
          or trace "get " . size_short($expected_size). " for $local_name";

    my $success;
    if(defined $expected_size && $expected_size==$got_size)
    {   # download succesful, but mv or close was not
        $success = 1;
        if($expected_size==0)
        {   open OUT, '>', $local_temp
                or fault __x"cannot create empty {file}", file => $local_temp;
            close OUT;
        }
    }
    else
    {   my $start   = [ gettimeofday ];
        $success    = $ftp->get($base, $local_temp);
        my $elapsed = tv_interval $start;

        my $downloaded = (-s $local_temp || 0) - $got_size;

        if($downloaded)
        {   info __x"{amount} in {secs}s is {speed}/s: {fn}"
             , amount => size_short($downloaded)
             , secs => sprintf("%7.3f", $elapsed)
             , speed  => size_short($downloaded/$elapsed), fn => $base;
            $stats->{downloaded} += $downloaded;
        }
        else
        {   notice __x"failed to get any bytes from {fn}: {err}"
              , fn => $local_name, err => $ftp->message;
            $success = 0;
        }
    }

    if($success)
    {   # accept the downloaded file
        utime $remote_mtime, $remote_mtime, $local_temp; # only root
        unlink $local_name;                              # might exist
        unless(rename $local_temp, $local_name)
        {   fault __x"cannot rename {old} to {new}"
              , old => $local_temp, new => $local_name;
        }
        $stats->{new_files}++;
    }

    $success;
}

sub size_short($)
{   my $size = shift || 0;
    my $name = ' B';
    ($size, $name) = ($size/1024, 'kB') if $size > 1000;
    ($size, $name) = ($size/1024, 'MB') if $size > 1000;
    ($size, $name) = ($size/1024, 'GB') if $size > 1000;

    my $format = $size >= 100 ? "%4.0f%s" : "%4.1f%s";
    sprintf $format, $size, $name;
}


1;