File Coverage

blib/lib/Test/Smoke/FTPClient.pm
Criterion Covered Total %
statement 165 199 82.9
branch 60 108 55.5
condition 14 34 41.1
subroutine 17 20 85.0
pod 6 6 100.0
total 262 367 71.3


line stmt bran cond sub pod time code
1             package Test::Smoke::FTPClient;
2 1     1   7 use strict;
  1         6  
  1         30  
3              
4 1     1   5 use Net::FTP;
  1         2  
  1         46  
5 1     1   5 use Cwd;
  1         10  
  1         43  
6 1     1   5 use File::Path;
  1         2  
  1         62  
7 1     1   7 use File::Spec::Functions qw( :DEFAULT abs2rel rel2abs );
  1         2  
  1         222  
8 1     1   7 use Test::Smoke::Util qw( clean_filename time_in_hhmm );
  1         2  
  1         50  
9              
10 1     1   6 use vars qw( $VERSION );
  1         14  
  1         105  
11             $VERSION = '0.011';
12              
13             my %CONFIG = (
14             df_fserver => undef,
15             df_fuser => 'anonymous',
16             df_fpasswd => 'smokers@perl.org',
17             df_v => 0,
18             df_fpassive => 1,
19             df_ftype => undef,
20              
21             valid => [qw( fuser fpasswd fpassive ftype )],
22             );
23             my @sn = qw( B KB MB GB TB );
24              
25 1     1   94 BEGIN { eval qq/use Time::HiRes qw( time ) / }
  1     1   7  
  1         2  
  1         10  
26              
27             =head1 NAME
28              
29             Test::Smoke::FTPClient - Implement a mirror like object
30              
31             =head1 SYNOPSIS
32              
33             use Test::Smoke::FTPClient;
34              
35             my $server = 'ftp.linux.activestate.com';
36             my $fc = Test::Smoke::FTPClient->new( $server );
37              
38             my $sdir = '/pub/staff/gsar/APC/perl-current';
39             my $ddir = '~/perlsmoke/perl-current';
40             my $cleanup = 1; # like --delete for rsync
41              
42             $fc->connect;
43             $fc->mirror( $sdir, $ddir, $cleanup );
44              
45             $fc->bye;
46              
47             =head1 DESCRIPTION
48              
49             This module was written specifically to fetch a perl source-tree
50             from the APC. It will not suffice as a general purpose mirror module!
51             It only distinguishes between files and directories and relies on the
52             output of the C<< Net::FTP->dir >> method.
53              
54             This solution is B, you'd better use B!
55              
56             =head1 METHODS
57              
58             =head2 Test::Smoke::FTPClient->new( $server[, %options] )
59              
60             Create a new object with option checking:
61              
62             * fuser
63             * fpasswd
64             * v
65             * fpassive
66             * ftype
67              
68             =cut
69              
70             sub new {
71 3     3 1 7 my $class = shift;
72              
73 3         14 my $server = shift;
74              
75 3 50       11 unless ( $server ) {
76 0         0 require Carp;
77 0         0 Carp::croak( "Usage: Test::Smoke::FTPClient->new( \$server )" );
78             };
79              
80 3 50       28 my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();
  3 50       27  
81              
82             my %args = map {
83 3         12 ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
  15         73  
  15         44  
84 15         47 ( $key => $args_raw{ $_ } );
85             } keys %args_raw;
86              
87             my %fields = map {
88 15 100       33 my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
89 15         38 ( $_ => $value )
90 3         8 } ( v => @{ $CONFIG{ valid } } );
  3         7  
91 3         14 $fields{fserver} = $server;
92 3   50     32 $fields{v} ||= 0;
93              
94 3         17 return bless \%fields, $class;
95              
96             }
97              
98             =head2 $ftpclient->connect( )
99              
100             Returns true for success after connecting and login.
101              
102             =cut
103              
104             sub connect {
105 3     3 1 6 my $self = shift;
106              
107 3 50       17 $self->{v} and print "Connecting to '$self->{fserver}' ";
108             $self->{client} = Net::FTP->new( $self->{fserver},
109             Passive => $self->{fpassive},
110 3         47 Debug => ( $self->{v} > 2 ),
111             );
112 3 50       84 unless ( $self->{client} ) {
113 0         0 $self->{error} = $@;
114 0 0       0 $self->{v} and print "NOT OK ($self->{error})\n";
115 0         0 return;
116             }
117 3 50       8 $self->{v} and print "OK\n";
118              
119 3 50       12 $self->{v} and print "Authenticating ";
120 3 50       29 unless ( $self->{client}->login( $self->{fuser}, $self->{fpasswd} ) ) {
121 0   0     0 $self->{error} = $@ ||
122             "Could not login($self->{fuser}) on $self->{fserver}";
123 0 0       0 $self->{v} and print "NOT OK ($self->{error})\n";
124 0         0 return;
125             }
126 3 50       17 $self->{v} and print "OK\n";
127              
128 3         8 return 1;
129             }
130              
131             =head2 $client->mirror( $sdir, $ddir )
132              
133             Set-up the environment and call C<__do_mirror()>
134              
135             =cut
136              
137             sub mirror {
138 3     3 1 6 my $self = shift;
139 3 50       10 return unless UNIVERSAL::isa( $self->{client}, 'Net::FTP' );
140              
141 3         10 my( $fdir, $ddir, $cleanup ) = @_;
142 3         12755 my $cwd = cwd();
143             # Get the local directory sorted
144 3         117 $ddir = rel2abs( $ddir );
145 3 100       993 mkpath( $ddir, $self->{v} ) unless -d $ddir;
146 3 50       58 unless ( chdir $ddir ) {
147 0         0 $self->{error} = "Cannot chdir($ddir): $!";
148 0         0 return;
149             }
150 3         41 my $lroot = catdir( $ddir, updir );
151 3 50 33     12894 chdir $lroot and $lroot = cwd() and chdir $cwd;
152              
153 3 50 33     46 if ( $self->{ftype} && $self->{client}->can( $self->{ftype} ) ) {
154 0         0 my $ftype = $self->{ftype};
155 0         0 eval '$self->{client}->$ftype';
156             }
157 3         25 my( $totsize, $tottime ) = ( 0, 0 );
158 3 50       43 $self->{v} and print "Start mirror to: $ddir\n";
159 3         27 my $start = time;
160             my $ret = __do_mirror( $self->{client}, $fdir, $ddir, $lroot,
161 3         49 $self->{v}, $cleanup, $totsize, $tottime );
162 3         11 my $ttime = time - $start;
163 3 100       9 $tottime or $tottime = 0.001;
164 3         7 my $speed = $totsize / $tottime;
165 3         5 my $ord = 0;
166 3         15 while ( $speed > 1024 ) { $speed /= 1024; $ord++ }
  2         3  
  2         5  
167 3 50       7 $self->{v} and printf "Mirror took %s \@ %.3f %s\n",
168             time_in_hhmm( $ttime ), $speed, $sn[ $ord ];
169 3         27 chdir $cwd;
170 3         126 return $ret;
171             }
172              
173             =head2 $client->bye
174              
175             Disconnect from the FTP-server and cleanup the Net::FTP client;
176              
177             =cut
178              
179             sub bye {
180 0     0 1 0 my $self = shift;
181 0         0 $self->{client}->quit;
182             }
183              
184             =head2 Test::Smoke::FTPClient->config( $key[, $value] )
185              
186             C is an interface to the package lexical C<%CONFIG>,
187             which holds all the default values for the C arguments.
188              
189             With the special key B this returns a reference
190             to a hash holding all the default values.
191              
192             =cut
193              
194             sub config {
195 0     0 1 0 my $dummy = shift;
196              
197 0         0 my $key = lc shift;
198              
199 0 0       0 if ( $key eq 'all_defaults' ) {
200             my %default = map {
201 0         0 my( $pass_key ) = $_ =~ /^df_(.+)/;
  0         0  
202 0         0 ( $pass_key => $CONFIG{ $_ } );
203             } grep /^df_/ => keys %CONFIG;
204 0         0 return \%default;
205             }
206              
207 0 0       0 return undef unless exists $CONFIG{ "df_$key" };
208              
209 0 0       0 $CONFIG{ "df_$key" } = shift if @_;
210              
211 0         0 return $CONFIG{ "df_$key" };
212             }
213              
214             =head2 __do_mirror( $ftp, $ftpdir, $localdir, $lroot, $verbose, $cleanup )
215              
216             Recursive sub to mirror a tree from an FTP server.
217              
218             =cut
219              
220             {
221             my $mirror_ok = 1;
222             sub __do_mirror {
223 35     35   176 my( $ftp, $ftpdir, $localdir, $lroot, $verbose, $cleanup,
224             $totsize, $tottime ) = @_;
225 35   50     170 $verbose ||= 0;
226              
227 35         336 $ftp->cwd( $ftpdir );
228 35 50       706 $verbose > 1 and printf "Entering %s\n", $ftp->pwd;
229              
230 35         90 my @list = dirlist( $ftp, $verbose );
231              
232 35         2804 foreach my $entry ( sort { $a->{type} cmp $b->{type} ||
233 203 50       525 $a->{name} cmp $b->{name} } @list ) {
234              
235 144 100       316 if ( $entry->{type} eq 'd' ) {
236 108 100       390 $entry->{name} =~ m/^\.\.?$/ and next;
237 38         275 my $new_locald = File::Spec->catdir( $localdir, $entry->{name} );
238 38 100       894 unless ( -d $new_locald ) {
239 24 50       78 eval { mkpath( $new_locald, $verbose, $entry->{mode} ) } or
  24         3588  
240             return;
241 24 50       96 $@ and return;
242             }
243 38         416 chdir $new_locald;
244             $mirror_ok &&= __do_mirror( $ftp, $entry->{name},
245 38   100     277 $new_locald, $lroot, $verbose,
246             $cleanup, $totsize, $tottime );
247 38   33     172 $entry->{time} ||= $entry->{date};
248 38         635 utime $entry->{time}, $entry->{time}, $new_locald;
249 38         202 $ftp->cwd( '..' );
250 38         1067 chdir File::Spec->updir;
251 38 50       175 $verbose > 1 and print "Leaving '$entry->{name}' [$new_locald]\n";
252             } else {
253 36         166 $entry->{time} = $ftp->mdtm( $entry->{name} ); #slow down
254 36         1417 my $fname = clean_filename( $entry->{name} );
255              
256 36         183 my $destname = catfile( $localdir, canonpath($fname) );
257              
258 36         68 my $skip;
259 36 100       637 if ( -e $destname ) {
260 17         220 my( $l_size, $l_mode, $l_time ) = (stat $destname)[7, 2, 9];
261 17         51 $l_mode &= 07777;
262             $skip = ($l_size == $entry->{size}) &&
263             ($l_mode == $entry->{mode}) &&
264 17   33     146 ($l_time == $entry->{time});
265             }
266 36 100       88 unless ( $skip ) {
267 19         185 1 while unlink $destname;
268             $verbose and printf "%s: %d/", abs2rel( $destname, $lroot ),
269 19 50       60 $entry->{size};
270 19         81 my $start = time;
271 19         78 my $dest = $ftp->get( $entry->{name}, $destname );
272 19         3727 my $t_time = time - $start;
273 19 100       71 $dest or $mirror_ok = 0, return;
274              
275 17 50       36 $t_time or $t_time = 0.001; # avoid div by zero
276 17         237 my $size = -s $dest;
277 17         43 $totsize += $size;
278 17         22 $tottime += $t_time;
279 17         39 my $speed = $size / $t_time;
280 17         26 my $ord = 0;
281 17         51 while ( $speed > 1024 ) { $speed /= 1024; $ord++ }
  22         30  
  22         46  
282 17 50       40 my $dig = $ord ? '3' : '0';
283              
284 17         265 utime $entry->{time}, $entry->{time}, $dest;
285 17         239 chmod $entry->{mode}, $dest;
286 17 50       78 $verbose and printf "$size (%.${dig}f $sn[$ord]/s)\n",
287             $speed;
288             } else {
289             $verbose > 1 and
290             printf "%s: %d/skipped\n", abs2rel( $destname, $lroot),
291 17 50       61 $entry->{size};
292             }
293             }
294             }
295 33 50       73 if ( $cleanup ) {
296 33         289 chdir $localdir;
297 33 50       99 $verbose > 1 and print "Cleanup '$localdir'\n";
298             my %ok_file = map {
299 33         73 ( clean_filename( $_->{name} ) => $_->{type} )
300 132         296 } @list;
301 33         139 local *DIR;
302 33 50       796 if ( opendir DIR, '.' ) {
303 33         687 foreach ( readdir DIR ) {
304 134         439 my $cmpname = clean_filename( $_ );
305 134 50       296 $^O eq 'VMS' and $cmpname =~ s/\.$//;
306 134 100 66     2388 if( -f $cmpname ) {
    100          
307 36 100 66     196 unless ( exists $ok_file{ $cmpname } &&
308             $ok_file{ $cmpname } eq 'f' ) {
309 2 50       11 $verbose and printf "Delete %s\n",
310             abs2rel( rel2abs( $cmpname ),
311             $lroot );
312 2         135 1 while unlink $_;
313             }
314             } elsif ( -d && ! /^..?\z/ ) {
315 19 50       74 $^O eq 'VMS' and $cmpname =~ s/\.DIR$//i;
316 19 50 33     89 unless ( exists $ok_file{ $cmpname } &&
317             $ok_file{ $cmpname } eq 'd' ) {
318 0         0 rmtree( $cmpname, $verbose );
319             }
320             }
321             }
322 33         450 closedir DIR;
323             }
324             }
325 33         125 @_[ -2, -1 ] = ( $totsize, $tottime );
326 33         186 return $mirror_ok;
327             }
328             }
329              
330             =head2 dirlist( $ftp, $verbose )
331              
332             Return a list of entries (hashrefs) with these properties:
333              
334             * name: Filename
335             * type f/d/l
336             * mode unix file mode
337             * size filessize in bytes
338             * date file date
339              
340             =cut
341              
342             sub dirlist {
343 35     35 1 70 my( $ftp, $verbose ) = @_;
344 35         124 map __parse_line_from_dir( $_, $verbose ) => $ftp->dir;
345             }
346              
347             =head2 __parse_line_from_dir( $line, $verbose )
348              
349             The C command in FTP gives a sort of C output,
350             parts of this output are used as remote file-info.
351              
352             =cut
353              
354             sub __parse_line_from_dir {
355 147     147   26142 my( $entry, $verbose ) = @_;
356 147         555 my @field = split " ", $entry;
357              
358 147 50       719 if ( $field[0] =~ /[dwrx-]{7}/ ) { # Unixy dir entry
359              
360 147         356 ( my $type = substr $field[0], 0, 1 ) =~ tr/-/f/;
361             return {
362 147         442 name => $field[-1],
363             type => $type,
364             mode => __get_mode_from_text( substr $field[0], 1 ),
365             size => $field[4],
366             time => 0,
367             date => __time_from_ls( @field[5, 6, 7] ),
368             }
369             } else { # Windowsy dir entry
370 0 0       0 my $type = $field[2] eq '' ? 'd' : 'f';
371             return {
372 0         0 name => $field[-1],
373             type => $type,
374             mode => 0777,
375             size => $field[2],
376             time => 0,
377             date => __time_from_windows( @field[0, 1] ),
378             }
379             }
380             }
381              
382             =head2 __get_mode_from_text( $tmode )
383              
384             This takes the text representation of a file-mode (like 'rwxr--r--')
385             and return the numeric value.
386              
387             =cut
388              
389             sub __get_mode_from_text {
390 147     147   433 my( $tmode ) = @_; # nine letter/dash
391              
392 147         209 $tmode =~ tr/rwx-/1110/;
393 147         233 my $mode = 0;
394 147         674 for ( my $i = 0; $i < 3; $i++ ) {
395 441         645 $mode <<= 3;
396 441         1180 $mode += ord(pack B3 => substr $tmode, $i*3, 3) >> 5;
397             }
398              
399 147         373 return $mode;
400             }
401              
402             =head2 __time_from_ls( $mname, $day, $time_or_year )
403              
404             This takes the three date/time related columns from the C output
405             and returns a localtime-stamp.
406              
407             =cut
408              
409             sub __time_from_ls {
410 147     147   302 my( $mname, $day, $time_or_year ) = @_;
411              
412 147         2612 my( $local_year, $local_month) = (localtime)[5, 4];
413 147         491 $local_year += 1900;
414              
415 147         402 my $month = int( index('JanFebMarAprMayJunJulAugSepOctNovDec', $mname)/3 );
416              
417 147 50       608 my( $year, $time ) = $time_or_year =~ /:/
    100          
418             ? $month > $local_month ? ( $local_year - 1, $time_or_year ) :
419             ($local_year, $time_or_year) : ($time_or_year, '00:00' );
420              
421 147         805 my( $hour, $minutes ) = $time =~ /(\d+):(\d+)/;
422              
423 147         811 require Time::Local;
424 147         576 return Time::Local::timelocal( 0, $minutes, $hour, $day, $month, $year );
425             }
426              
427             =head2 __time_from_windows( $date, $time )
428              
429             This takes the two date/time related columns from the C output
430             and returns a localtime-stamp
431              
432             =cut
433              
434             sub __time_from_windows {
435 0     0     my( $date, $time ) = @_;
436              
437 0           my( $day, $month, $year ) = split m/-/, $date;
438 0           $month--;
439 0           my( $hour, $minutes, $off ) = $time =~ m/(\d+):(\d+)([ap])m/i;
440 0 0 0       $off && lc $off eq 'p' and $hour += 12;
441              
442 0           require Time::Local;
443 0           return Time::Local::timelocal( 0, $minutes, $hour, $day, $month, $year );
444             }
445              
446             1;
447              
448             =head1 SEE ALSO
449              
450             L
451              
452             =head1 COPYRIGHT & LICENSE
453              
454             (c) 2003, 2004, 2005, Abe Timmerman All rights reserved.
455              
456             This library is free software; you can redistribute it and/or modify
457             it under the same terms as Perl itself.
458              
459             See:
460              
461             * ,
462             *
463              
464             This program is distributed in the hope that it will be useful,
465             but WITHOUT ANY WARRANTY; without even the implied warranty of
466             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
467              
468             =cut