inc/Module/Install/Fetch.pm

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