inc/Module/Install/Fetch.pm

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