File Coverage

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