File Coverage

blib/lib/Net/FTP/AutoReconnect.pm

Criterion	Covered	Total	%
statement	9	224	4.0
branch	0	64	0.0
condition	0	3	0.0
subroutine	3	76	3.9
pod	4	45	8.8
total	16	412	3.8

package Net::FTP::AutoReconnect;
our $VERSION = '0.3';

use warnings;
use strict;

use Net::FTP;

=head1 NAME

Net::FTP::AutoReconnect - FTP client class with automatic reconnect on failure

=head1 SYNOPSIS

C is a wrapper module around C.
For many commands, if anything goes wrong on the first try, it tries
to disconnect and reconnect to the server, restore the state to the
same as it was when the command was executed, then execute it again.
The state includes login credentials, authorize credentials, transfer
mode (ASCII or binary), current working directory, and any restart,
passive, or port commands sent.

=head1 DESCRIPTION

The goal of this method is to hide some implementation details of FTP
server systems from the programmer.  In particular, many FTP systems
will automatically disconnect a user after a relatively short idle
time or after a transfer is aborted.  In this case,
C will simply reconnect, send the commands
necessary to return your session to its previous state, then resend
the command.  If that fails, it will return the error.

It makes no effort to determine what sorts of errors are likely to
succeed when they're retried.  Partly that's because it's hard to
know; if you're retreiving a file from an FTP site with several
mirrors and the file is not found, for example, maybe on the next try
you'll connect to a different server and find it.  But mostly it's
from laziness; if you have some good ideas about how to determine when
to retry and when not to bother, by all means send patches.

This module contains an instance of C, which it passes most
method calls along to.

These methods also record their state: C, C,
C, C, C, C, C,
C,C, C, C.  Directory changing commands
execute a C afterwards and store their new working directory.

These methods are automatically retried: C, C, C,
C, C, C, C, C, C, C,
C, C, C, C, C, C, C, C,
C, C, C, C, C, C, C,
C.

These methods are tried just once: C, C, C,
C, C, C, C, C,
C, C, C.  From C: C,
C, C, C.  C doesn't actually send any
FTP commands (they're sent along with the command they apply to),
which is why it's not restarted.

Any other commands are unimplemented (or possibly misdocumented); if I
missed one you'd like, please send a patch.

=head2 CONSTRUCTOR

=head3 new

All parameters are passed along verbatim to C, as well as
stored in case we have to reconnect.

=cut
  ;

sub new {
  my $self = {};
  my $class = shift;
  bless $self,$class;

  # Adapted from the Net::FTP constructor, version 2.77
  if (@_ % 2)
  {
    $self->{_peer} = shift;
    $self->{_args} = { @_ };
  }
  else
  {
    $self->{_args} = { @_ };
    $self->{_peer} = delete $self->{_args}{Host};
  }
  $self->{_connect_count} = 0;

  $self->reconnect( 0 );

  $self;
}

=head2 METHODS

Most of the methods are those of L.  One additional
method is available:

=head3 reconnect()

Abandon the current FTP connection and create a new one, restoring all
the state we can.

=cut
  ;

sub reconnect
{
  my $self = shift;

  my $is_reconnect = shift;
  my $connection_type = ($is_reconnect) ? "Reconnecting" : "Connecting";

  warn join(' ',ref($self),$connection_type." to FTP server $self->{_peer}\n")
    if ($ENV{DEBUG} || $self->{_args}{Debug});

  ++$self->{_connect_count};

  $self->{ftp} = Net::FTP->new($self->{_peer}, %{$self->{_args}})
    or die "Couldn't create new FTP object: $@\n";

  if ($self->{login})
  {
    $self->{ftp}->login(@{$self->{login}});
  }
  if ($self->{authorize})
  {
    $self->{ftp}->authorize(@{$self->{authorize}});
  }
  if ($self->{mode})
  {
    if ($self->{mode} eq 'ascii')
    {
      $self->{ftp}->ascii();
    }
    else
    {
      $self->{ftp}->binary();
    }
  }
  if ($self->{cwd})
  {
    $self->{ftp}->cwd($self->{cwd});
  }
  if ($self->{hash})
  {
    $self->{ftp}->hash(@{$self->{hash}});
  }
  if ($self->{restart})
  {
    $self->{ftp}->restart(@{$self->{restart}});
  }
  if ($self->{alloc})
  {
    $self->{ftp}->restart(@{$self->{alloc}});
  }
  if ($self->{pasv})
  {
    $self->{ftp}->pasv(@{$self->{pasv}});
  }
  if ($self->{port})
  {
    $self->{ftp}->port(@{$self->{port}});
  }
}

sub _auto_reconnect
{
  my $self = shift;
  my($code)=@_;

  my $ret = $code->();
  if (!defined($ret))
  {
    $self->reconnect( 1 );
    $ret = $code->();
  }
  $ret;
}

sub _after_pcmd
{
  my $self = shift;
  my($r) = @_;
  if ($r)
  {
    # succeeded
    delete $self->{port};
    delete $self->{pasv};
    delete $self->{restart};
    delete $self->{alloc};
  }
  $r;
}

=head3 disconnect()

Disconnect the current FTP connection abruptly.  Mostly useful for
testing.

=cut
  ;

sub disconnect
{
  my $self = shift;
  return POSIX::close(fileno($self->{ftp}));
}

=head3 connect_count()

Return the number of times we have connected or reconnected to this
server.  Mostly useful for testing.

=cut
  ;

sub connect_count
{
  my $self = shift;
  return $self->{_connect_count};
}

sub login
{
  my $self = shift;

  $self->{login} = \@_;
  $self->{ftp}->login(@_);
}

sub authorize
{
  my $self = shift;
  $self->{authorize} = \@_;
  $self->{ftp}->authorize(@_);
}

sub site
{
  my $self = shift;
  $self->{ftp}->site(@_);
}

sub ascii
{
  my $self = shift;
  $self->{mode} = 'ascii';
  $self->_auto_reconnect(sub { $self->{ftp}->ascii() || undef });
}

sub binary
{
  my $self = shift;
  $self->{mode} = 'binary';
  $self->_auto_reconnect(sub { $self->{ftp}->binary() || undef });
}

sub rename
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->rename(@a) || undef });
}

sub delete
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->delete(@a) || undef });
}

sub cwd
{
  my $self = shift;
  my @a = @_;
  my $ret = $self->_auto_reconnect(sub { $self->{ftp}->cwd(@a) || undef });
  if ($ret)
  {
    $self->{cwd} = $self->{ftp}->pwd()
      or die "Couldn't get directory after cwd\n";
  }
  $ret;
}

sub cdup
{
  my $self = shift;
  my @a = @_;
  my $ret = $self->_auto_reconnect(sub { $self->{ftp}->cdup(@a) || undef});
  if ($ret)
  {
    $self->{cwd} = $self->{ftp}->pwd()
      or die "Couldn't get directory after cdup\n";
  }
  $ret;
}

sub pwd
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->pwd(@a)});
}

sub rmdir
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->rmdir(@a) || undef});
}

sub mkdir
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->mkdir(@a) });
}

sub ls
{
  my $self = shift;
  my @a = @_;
  my $ret = $self->_auto_reconnect(sub { $self->{ftp}->ls(@a) });
  return $ret ? (wantarray ? @$ret : $ret) : undef;
}

sub dir
{
  my $self = shift;
  my @a = @_;
  my $ret = $self->_auto_reconnect(sub { $self->{ftp}->dir(@a) });
  return $ret ? (wantarray ? @$ret : $ret) : undef;
}

sub restart
{
  my $self = shift;
  my @a = @_;
  $self->{restart} = \@a;
  $self->{ftp}->restart(@_);
}

sub retr
{
  my $self = shift;
  my @a = @_;
  $self->_after_pcmd($self->_auto_reconnect(sub { $self->{ftp}->retr(@a) || undef }));
}

sub get
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->get(@a) });
}

sub mdtm
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->mdtm(@a) });
}

sub size
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->size(@a) });
}

sub abort
{
  my $self = shift;
  $self->{ftp}->abort();
}

sub quit
{
  my $self = shift;
  $self->{ftp}->quit();
}

sub hash
{
  my $self = shift;
  my @a = @_;
  $self->{hash} = \@a;
  $self->{ftp}->hash(@_);
}

sub alloc
{
  my $self = shift;
  my @a = @_;
  $self->{alloc} = \@a;
  $self->_auto_reconnect(sub { $self->{ftp}->alloc(@a) });
}

sub put
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->put(@a) });
}

sub put_unique
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->put_unique(@a) });
}

sub append
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->append(@a) });
}

sub unique_name
{
  my $self = shift;
  $self->{ftp}->unique_name(@_);
}

sub supported
{
  my $self = shift;
  my @a = @_;
  $self->_auto_reconnect(sub { $self->{ftp}->supported(@a) });
}

sub port
{
  my $self = shift;
  my @a = @_;
  $self->{port} = \@a;
  $self->_auto_reconnect(sub { $self->{ftp}->port(@a) });
}

sub pasv
{
  my $self = shift;
  my @a = @_;
  $self->{pasv} = \@a;
  $self->_auto_reconnect(sub { $self->{ftp}->pasv(@a) });
}

sub nlst
{
  my $self = shift;
  my @a = @_;
  $self->_after_pcmd($self->_auto_reconnect(sub { $self->{ftp}->nlst(@a) }));
}

sub stou
{
  my $self = shift;
  my @a = @_;
  $self->_after_pcmd($self->_auto_reconnect(sub { $self->{ftp}->stou(@a) }));
}

sub appe
{
  my $self = shift;
  my @a = @_;
  $self->_after_pcmd($self->_auto_reconnect(sub { $self->{ftp}->appe(@a) }));
}

sub list
{
  my $self = shift;
  my @a = @_;
  $self->_after_pcmd($self->_auto_reconnect(sub { $self->{ftp}->list(@a) }));
}

sub pasv_xfer
{
  my $self = shift;
  $self->{ftp}->pasv_xfer(@_);
}

sub pasv_xfer_unique
{
  my $self = shift;
  $self->{ftp}->pasv_xfer_unique(@_);
}

sub pasv_wait
{
  my $self = shift;
  $self->{ftp}->pasv_wait(@_);
}

sub message
{
  my $self = shift;
  $self->{ftp}->message(@_);
}

sub code
{
  my $self = shift;
  $self->{ftp}->code(@_);
}

sub ok
{
  my $self = shift;
  $self->{ftp}->ok(@_);
}

sub status
{
  my $self = shift;
  $self->{ftp}->status(@_);
}

=head1 AUTHOR

Scott Gifford

=head1 BUGS

We should really be smarter about when to retry.

We shouldn't be hardwired to use C, but any FTP-compatible
class; that would allow all modules similar to this one to be chained
together.

Much of this is only lightly tested; it's hard to find an FTP server
unreliable enough to test all aspects of it.  It's mostly been tested
with a server that dicsonnects after an aborted transfer, and the
module seems to work OK.

=head1 SEE ALSO

L.

=head1 COPYRIGHT

Copyright (c) 2006 Scott Gifford. All rights reserved.  This program
is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.

=cut

1;