94 lines
2.4 KiB
Perl
94 lines
2.4 KiB
Perl
#line 1
|
|
package Module::Install::Fetch;
|
|
|
|
use strict;
|
|
use Module::Install::Base;
|
|
|
|
use vars qw{$VERSION $ISCORE @ISA};
|
|
BEGIN {
|
|
$VERSION = '0.77';
|
|
$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;
|