Test::Smoke::FTPClient - Implement a mirror like object

Test-Smoke documentation Contained in the Test-Smoke distribution.

Index

Code Index:

NAME

Top

Test::Smoke::FTPClient - Implement a mirror like object

SYNOPSIS

Top

    use Test::Smoke::FTPClient;

    my $server = 'ftp.linux.activestate.com';
    my $fc = Test::Smoke::FTPClient->new( $server );

    my $sdir = '/pub/staff/gsar/APC/perl-current';
    my $ddir = '~/perlsmoke/perl-current';
    my $cleanup = 1; # like --delete for rsync

    $fc->connect;
    $fc->mirror( $sdir, $ddir, $cleanup );

    $fc->bye;

DESCRIPTION

Top

This module was written specifically to fetch a perl source-tree from the APC. It will not suffice as a general purpose mirror module! It only distinguishes between files and directories and relies on the output of the Net::FTP->dir method.

This solution is slow, you'd better use rsync!

METHODS

Top

Test::Smoke::FTPClient->new( $server[, %options] )

Create a new object with option checking:

    * fuser
    * fpasswd
    * v
    * fpassive
    * ftype

$ftpclient->connect( )

Returns true for success after connecting and login.

$client->mirror( $sdir, $ddir )

Set-up the environment and call __do_mirror()

$client->bye

Disconnect from the FTP-server and cleanup the Net::FTP client;

Test::Smoke::FTPClient->config( $key[, $value] )

config() is an interface to the package lexical %CONFIG, which holds all the default values for the new() arguments.

With the special key all_defaults this returns a reference to a hash holding all the default values.

__do_mirror( $ftp, $ftpdir, $localdir, $lroot, $verbose, $cleanup )

Recursive sub to mirror a tree from an FTP server.

dirlist( $ftp, $verbose )

Return a list of entries (hashrefs) with these properties:

    * name:    Filename
    * type     f/d/l
    * mode     unix file mode
    * size     filessize in bytes
    * date     file date

__parse_line_from_dir( $line, $verbose )

The dir command in FTP gives a sort of ls -la output, parts of this output are used as remote file-info.

__get_mode_from_text( $tmode )

This takes the text representation of a file-mode (like 'rwxr--r--') and return the numeric value.

__time_from_ls( $mname, $day, $time_or_year )

This takes the three date/time related columns from the ls -la output and returns a localtime-stamp.

__time_from_windows( $date, $time )

This takes the two date/time related columns from the dir output and returns a localtime-stamp

SEE ALSO

Top

Test::Smoke::Syncer

COPYRIGHT & LICENSE

Top

(c) 2003, 2004, 2005, Abe Timmerman <abeltje@cpan.org> All rights reserved.

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

See:

  * <http://www.perl.com/perl/misc/Artistic.html>,
  * <http://www.gnu.org/copyleft/gpl.html>

This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

Test-Smoke documentation Contained in the Test-Smoke distribution. 
package Test::Smoke::FTPClient;
use strict;

use Net::FTP;
use Cwd;
use File::Path;
use File::Spec::Functions qw( :DEFAULT abs2rel rel2abs );
use Test::Smoke::Util qw( clean_filename time_in_hhmm );

# $Id: FTPClient.pm 1187 2008-06-19 21:17:20Z abeltje $
use vars qw( $VERSION );
$VERSION = '0.011';

my %CONFIG = (
    df_fserver  => undef,
    df_fuser    => 'anonymous',
    df_fpasswd  => 'smokers@perl.org',
    df_v        => 0,
    df_fpassive => 1,
    df_ftype    => undef,

    valid      => [qw( fuser fpasswd fpassive ftype )],
);
my @sn = qw( B KB MB GB TB );

BEGIN { eval qq/use Time::HiRes qw( time ) / }


sub  new {
    my $class = shift;

    my $server = shift;

    unless ( $server ) {
        require Carp;
        Carp::croak( "Usage: Test::Smoke::FTPClient->new( \$server )" );
    };

    my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();

    my %args = map {
        ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
        ( $key => $args_raw{ $_ } );
    } keys %args_raw;

    my %fields = map {
        my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
        ( $_ => $value )
    } ( v => @{ $CONFIG{ valid } } );
    $fields{fserver} = $server;
    $fields{v} ||= 0;

    return bless \%fields, $class;

}


sub connect {
    my $self = shift;

    $self->{v} and print "Connecting to '$self->{fserver}' ";
    $self->{client} = Net::FTP->new( $self->{fserver},
        Passive => $self->{fpassive},
        Debug   => ( $self->{v} > 2 ),
    );
    unless ( $self->{client} ) {
        $self->{error} = $@;
        $self->{v} and print "NOT OK ($self->{error})\n";
        return;
    }
    $self->{v} and print "OK\n";

    $self->{v} and print "Authenticating ";
    unless ( $self->{client}->login( $self->{fuser}, $self->{fpasswd} ) ) {
        $self->{error} = $@ || 
            "Could not login($self->{fuser}) on $self->{fserver}";
        $self->{v} and print "NOT OK ($self->{error})\n";
        return;
    }
    $self->{v} and print "OK\n";

    return 1;
}


sub mirror {
    my $self = shift;
    return unless UNIVERSAL::isa( $self->{client}, 'Net::FTP' );

    my( $fdir, $ddir, $cleanup ) = @_;
    my $cwd = cwd();
    # Get the local directory sorted
    $ddir = rel2abs( $ddir );
    mkpath( $ddir, $self->{v} ) unless -d $ddir;
    unless ( chdir $ddir ) {
        $self->{error} = "Cannot chdir($ddir): $!";
        return;
    }
    my $lroot = catdir( $ddir, updir );
    chdir $lroot and $lroot = cwd() and chdir $cwd;

    if ( $self->{ftype} && $self->{client}->can( $self->{ftype} ) ) {
        my $ftype = $self->{ftype};
        eval '$self->{client}->$ftype';
    }
    my( $totsize, $tottime ) = ( 0, 0 );
    $self->{v} and print "Start mirror to: $ddir\n";
    my $start = time;
    my $ret = __do_mirror( $self->{client}, $fdir, $ddir, $lroot,
                           $self->{v}, $cleanup, $totsize, $tottime );
    my $ttime = time - $start;
    $tottime or $tottime = 0.001;
    my $speed = $totsize / $tottime;
    my $ord = 0;
    while ( $speed > 1024 ) { $speed /= 1024; $ord++ }
    $self->{v} and printf "Mirror took %s \@ %.3f %s\n",
                          time_in_hhmm( $ttime ), $speed, $sn[ $ord ];
    chdir $cwd;
    return $ret;
}


sub bye {
    my $self = shift;
    $self->{client}->quit;
}


sub config {
    my $dummy = shift;

    my $key = lc shift;

    if ( $key eq 'all_defaults' ) {
        my %default = map {
            my( $pass_key ) = $_ =~ /^df_(.+)/;
            ( $pass_key => $CONFIG{ $_ } );
        } grep /^df_/ => keys %CONFIG;
        return \%default;
    }

    return undef unless exists $CONFIG{ "df_$key" };

    $CONFIG{ "df_$key" } = shift if @_;

    return $CONFIG{ "df_$key" };
}


{
my $mirror_ok = 1;
sub __do_mirror {
    my( $ftp, $ftpdir, $localdir, $lroot, $verbose, $cleanup,
        $totsize, $tottime ) = @_;
    $verbose ||= 0;

    $ftp->cwd( $ftpdir );
    $verbose > 1 and printf "Entering %s\n", $ftp->pwd;

    my @list = dirlist( $ftp, $verbose );

    foreach my $entry ( sort { $a->{type} cmp $b->{type} ||
                               $a->{name} cmp $b->{name} } @list ) {
        
        if ( $entry->{type} eq 'd' ) {
            $entry->{name} =~ m/^\.\.?$/ and next;
            my $new_locald = File::Spec->catdir( $localdir, $entry->{name} );
            unless ( -d $new_locald ) {
                eval { mkpath( $new_locald, $verbose, $entry->{mode} ) } or
                    return;
                $@ and return;
            }
            chdir $new_locald;
            $mirror_ok &&= __do_mirror( $ftp, $entry->{name}, 
                                        $new_locald, $lroot, $verbose,
                                        $cleanup, $totsize, $tottime );
            $entry->{time} ||= $entry->{date};
            utime $entry->{time}, $entry->{time}, $new_locald;
            $ftp->cwd( '..' );
            chdir File::Spec->updir;
            $verbose > 1 and print "Leaving '$entry->{name}' [$new_locald]\n";
        } else {
            $entry->{time}  = $ftp->mdtm( $entry->{name} ); #slow down
            my $fname = clean_filename( $entry->{name} );

            my $destname = catfile( $localdir, canonpath($fname) );

            my $skip;
            if ( -e $destname ) {
                my( $l_size, $l_mode, $l_time ) = (stat $destname)[7, 2, 9];
                $l_mode &= 07777;
                $skip = ($l_size == $entry->{size}) && 
                        ($l_mode == $entry->{mode}) &&
		        ($l_time == $entry->{time});
            }
            unless ( $skip ) {
                1 while unlink $destname;
                $verbose and printf "%s: %d/", abs2rel( $destname, $lroot ),
                                               $entry->{size};
                my $start = time;
                my $dest = $ftp->get( $entry->{name}, $destname );
                my $t_time = time - $start;
                $dest or $mirror_ok = 0, return;

                $t_time or $t_time = 0.001; # avoid div by zero
                my $size = -s $dest;
                $totsize += $size;
                $tottime += $t_time;
                my $speed = $size / $t_time;
                my $ord = 0;
                while ( $speed > 1024 ) { $speed /= 1024; $ord++ }
                my $dig = $ord ? '3' : '0';

                utime $entry->{time}, $entry->{time}, $dest;
                chmod $entry->{mode}, $dest;
                $verbose and printf "$size (%.${dig}f $sn[$ord]/s)\n",
                                     $speed;
            } else { 
                $verbose > 1 and
                    printf "%s: %d/skipped\n", abs2rel( $destname, $lroot),
                                               $entry->{size};
            }
        }
    }
    if ( $cleanup ) {
        chdir $localdir;
        $verbose > 1 and print "Cleanup '$localdir'\n";
        my %ok_file = map {
            ( clean_filename( $_->{name} ) => $_->{type} )
        } @list;
        local *DIR;
        if ( opendir DIR, '.' ) {
            foreach ( readdir DIR ) {
                my $cmpname = clean_filename( $_ );
                $^O eq 'VMS' and $cmpname =~ s/\.$//;
                if( -f $cmpname ) {
                    unless ( exists $ok_file{ $cmpname } && 
                             $ok_file{ $cmpname } eq 'f' ) {
                        $verbose and printf "Delete %s\n",
                                             abs2rel( rel2abs( $cmpname ),
                                                      $lroot );
                        1 while unlink $_;
                    }
                } elsif ( -d && ! /^..?\z/ ) {
                     $^O eq 'VMS' and $cmpname =~ s/\.DIR$//i;
                     unless ( exists $ok_file{ $cmpname } &&
                              $ok_file{ $cmpname } eq 'd' ) {
                        rmtree( $cmpname, $verbose );
                    }
                }
            }
            closedir DIR;
        }
    }
    @_[ -2, -1 ] = ( $totsize, $tottime );
    return $mirror_ok;
}
}


sub dirlist {
    my( $ftp, $verbose ) = @_;
    map __parse_line_from_dir( $_, $verbose ) => $ftp->dir;
}


sub __parse_line_from_dir {
    my( $entry, $verbose ) = @_;
    my @field = split " ", $entry;

    if ( $field[0] =~ /[dwrx-]{7}/ ) { # Unixy dir entry

        ( my $type = substr $field[0], 0, 1 ) =~ tr/-/f/;
        return {
            name => $field[-1],
            type => $type,
            mode => __get_mode_from_text( substr $field[0], 1 ),
            size => $field[4],
            time => 0, 
            date => __time_from_ls( @field[5, 6, 7] ),
        }
    } else { # Windowsy dir entry
        my $type = $field[2] eq '<DIR>' ? 'd' : 'f';
        return {
            name => $field[-1],
            type => $type,
            mode => 0777,
            size => $field[2],
            time => 0,
            date => __time_from_windows( @field[0, 1] ),
        }
    }
}


sub __get_mode_from_text {
    my( $tmode ) = @_; # nine letter/dash

    $tmode =~ tr/rwx-/1110/;
    my $mode = 0;
    for ( my $i = 0; $i < 3; $i++ ) {
        $mode <<= 3;
        $mode  += ord(pack B3 => substr $tmode, $i*3, 3) >> 5;
    }

    return $mode;
}


sub __time_from_ls { 
    my( $mname, $day, $time_or_year ) = @_;

    my( $local_year, $local_month) = (localtime)[5, 4];
    $local_year += 1900;

    my $month = int( index('JanFebMarAprMayJunJulAugSepOctNovDec', $mname)/3 );

    my( $year, $time ) = $time_or_year =~ /:/
        ? $month > $local_month ? ( $local_year - 1, $time_or_year ) :
            ($local_year, $time_or_year) : ($time_or_year, '00:00' );

    my( $hour, $minutes ) = $time =~ /(\d+):(\d+)/;

    require Time::Local;
    return Time::Local::timelocal( 0, $minutes, $hour, $day, $month, $year );
}


sub __time_from_windows {
    my( $date, $time ) = @_;

    my( $day, $month, $year ) = split m/-/, $date;
    $month--;
    my( $hour, $minutes, $off )     = $time =~ m/(\d+):(\d+)([ap])m/i;
    $off && lc $off eq 'p' and $hour += 12;

    require Time::Local;
    return Time::Local::timelocal( 0, $minutes, $hour, $day, $month, $year );
}

1;