File Coverage

inc/Module/Install/Fetch.pm
Criterion Covered Total %
statement 12 68 17.6
branch 0 34 0.0
condition 0 14 0.0
subroutine 4 5 80.0
pod 0 1 0.0
total 16 122 13.1


line stmt bran cond sub pod time code
1             #line 1
2             package Module::Install::Fetch;
3 1     1   7  
  1         2  
  1         66  
4 1     1   675 use strict;
  1         4  
  1         42  
5             use Module::Install::Base;
6 1     1   7  
  1         2  
  1         130  
7             use vars qw{$VERSION $ISCORE @ISA};
8 1     1   3 BEGIN {
9 1         2 $VERSION = '0.75';
10 1         1128 $ISCORE = 1;
11             @ISA = qw{Module::Install::Base};
12             }
13              
14 0     0 0   sub get_file {
15 0 0         my ($self, %args) = @_;
16             my ($scheme, $host, $path, $file) =
17             $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
18 0 0 0        
  0            
  0            
19 0 0         if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
20             $args{url} = $args{ftp_url}
21 0 0         or (warn("LWP support unavailable!\n"), return);
22             ($scheme, $host, $path, $file) =
23             $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
24             }
25 0            
26 0           $|++;
27             print "Fetching '$file' from $host... ";
28 0 0          
  0            
  0            
29 0           unless (eval { require Socket; Socket::inet_aton($host) }) {
30 0           warn "'$host' resolve failed!\n";
31             return;
32             }
33 0 0 0        
34             return unless $scheme eq 'ftp' or $scheme eq 'http';
35 0            
36 0           require Cwd;
37 0 0 0       my $dir = Cwd::getcwd();
38             chdir $args{local_dir} or return if exists $args{local_dir};
39 0 0          
  0 0          
  0 0          
40 0           if (eval { require LWP::Simple; 1 }) {
41             LWP::Simple::mirror($args{url}, $file);
42 0           }
  0            
  0            
43             elsif (eval { require Net::FTP; 1 }) { eval {
44 0           # use Net::FTP to get past firewall
45 0           my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
46 0           $ftp->login("anonymous", 'anonymous@example.com');
47 0           $ftp->cwd($path);
48 0 0         $ftp->binary;
49 0           $ftp->get($file) or (warn("$!\n"), return);
50             $ftp->quit;
51 0           } }
52             elsif (my $ftp = $self->can_run('ftp')) { eval {
53 0           # no Net::FTP, fallback to ftp.exe
54 0           require FileHandle;
55             my $fh = FileHandle->new;
56 0            
57 0 0         local $SIG{CHLD} = 'IGNORE';
58 0           unless ($fh->open("|$ftp -n")) {
59 0           warn "Couldn't open ftp: $!\n";
  0            
60             chdir $dir; return;
61             }
62 0            
63             my @dialog = split(/\n/, <<"END_FTP");
64             open $host
65             user anonymous anonymous\@example.com
66             cd $path
67             binary
68             get $file $file
69             quit
70 0           END_FTP
  0            
71 0           foreach (@dialog) { $fh->print("$_\n") }
72             $fh->close;
73             } }
74 0           else {
75 0           warn "No working 'ftp' program available!\n";
  0            
76             chdir $dir; return;
77             }
78 0 0          
79 0           unless (-f $file) {
80 0           warn "Fetching failed: $@\n";
  0            
81             chdir $dir; return;
82             }
83 0 0 0        
84 0 0         return if exists $args{size} and -s $file != $args{size};
85 0 0         system($args{run}) if exists $args{run};
86             unlink($file) if $args{remove};
87 0 0 0        
88             print(((!exists $args{check_for} or -e $args{check_for})
89 0           ? "done!" : "failed! ($!)"), "\n");
  0            
90             chdir $dir; return !$?;
91             }
92              
93             1;