/ModelSim-List-0.06/inc/Module/Install/Fetch.pm
# · Perl · 93 lines · 75 code · 15 blank · 3 comment · 8 complexity · 741e32c49c4372d052417e73cf2dd07b MD5 · raw file
- #line 1
- package Module::Install::Fetch;
- use strict;
- use Module::Install::Base;
- use vars qw{$VERSION $ISCORE @ISA};
- BEGIN {
- $VERSION = '0.67';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
- }
- sub get_file {
- my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
- if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
- $args{url} = $args{ftp_url}
- or (warn("LWP support unavailable!\n"), return);
- ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
- }
- $|++;
- print "Fetching '$file' from $host... ";
- unless (eval { require Socket; Socket::inet_aton($host) }) {
- warn "'$host' resolve failed!\n";
- return;
- }
- return unless $scheme eq 'ftp' or $scheme eq 'http';
- require Cwd;
- my $dir = Cwd::getcwd();
- chdir $args{local_dir} or return if exists $args{local_dir};
- if (eval { require LWP::Simple; 1 }) {
- LWP::Simple::mirror($args{url}, $file);
- }
- elsif (eval { require Net::FTP; 1 }) { eval {
- # use Net::FTP to get past firewall
- my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
- $ftp->login("anonymous", 'anonymous@example.com');
- $ftp->cwd($path);
- $ftp->binary;
- $ftp->get($file) or (warn("$!\n"), return);
- $ftp->quit;
- } }
- elsif (my $ftp = $self->can_run('ftp')) { eval {
- # no Net::FTP, fallback to ftp.exe
- require FileHandle;
- my $fh = FileHandle->new;
- local $SIG{CHLD} = 'IGNORE';
- unless ($fh->open("|$ftp -n")) {
- warn "Couldn't open ftp: $!\n";
- chdir $dir; return;
- }
- my @dialog = split(/\n/, <<"END_FTP");
- open $host
- user anonymous anonymous\@example.com
- cd $path
- binary
- get $file $file
- quit
- END_FTP
- foreach (@dialog) { $fh->print("$_\n") }
- $fh->close;
- } }
- else {
- warn "No working 'ftp' program available!\n";
- chdir $dir; return;
- }
- unless (-f $file) {
- warn "Fetching failed: $@\n";
- chdir $dir; return;
- }
- return if exists $args{size} and -s $file != $args{size};
- system($args{run}) if exists $args{run};
- unlink($file) if $args{remove};
- print(((!exists $args{check_for} or -e $args{check_for})
- ? "done!" : "failed! ($!)"), "\n");
- chdir $dir; return !$?;
- }
- 1;