1154 lines
42 KiB
Perl
1154 lines
42 KiB
Perl
|
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||
|
|
# vim: ts=4 sts=4 sw=4:
|
||
|
|
package CPAN::FTP;
|
||
|
|
use strict;
|
||
|
|
|
||
|
|
use Errno ();
|
||
|
|
use Fcntl qw(:flock);
|
||
|
|
use File::Basename qw(dirname);
|
||
|
|
use File::Path qw(mkpath);
|
||
|
|
use CPAN::FTP::netrc;
|
||
|
|
use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
|
||
|
|
|
||
|
|
@CPAN::FTP::ISA = qw(CPAN::Debug);
|
||
|
|
|
||
|
|
use vars qw(
|
||
|
|
$VERSION
|
||
|
|
);
|
||
|
|
$VERSION = "5.5013";
|
||
|
|
|
||
|
|
sub _plus_append_open {
|
||
|
|
my($fh, $file) = @_;
|
||
|
|
my $parent_dir = dirname $file;
|
||
|
|
mkpath $parent_dir;
|
||
|
|
my($cnt);
|
||
|
|
until (open $fh, "+>>$file") {
|
||
|
|
next if exists &Errno::EAGAIN && $! == &Errno::EAGAIN; # don't increment on EAGAIN
|
||
|
|
$CPAN::Frontend->mydie("Could not open '$file' after 10000 tries: $!") if ++$cnt > 100000;
|
||
|
|
sleep 0.0001;
|
||
|
|
mkpath $parent_dir;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#-> sub CPAN::FTP::ftp_statistics
|
||
|
|
# if they want to rewrite, they need to pass in a filehandle
|
||
|
|
sub _ftp_statistics {
|
||
|
|
my($self,$fh) = @_;
|
||
|
|
my $ftpstats_size = $CPAN::Config->{ftpstats_size};
|
||
|
|
return if defined $ftpstats_size && $ftpstats_size <= 0;
|
||
|
|
my $locktype = $fh ? LOCK_EX : LOCK_SH;
|
||
|
|
# XXX On Windows flock() implements mandatory locking, so we can
|
||
|
|
# XXX only use shared locking to still allow _yaml_loadfile() to
|
||
|
|
# XXX read from the file using a different filehandle.
|
||
|
|
$locktype = LOCK_SH if $^O eq "MSWin32";
|
||
|
|
|
||
|
|
$fh ||= FileHandle->new;
|
||
|
|
my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
|
||
|
|
_plus_append_open($fh,$file);
|
||
|
|
my $sleep = 1;
|
||
|
|
my $waitstart;
|
||
|
|
while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
|
||
|
|
$waitstart ||= localtime();
|
||
|
|
if ($sleep>3) {
|
||
|
|
my $now = localtime();
|
||
|
|
$CPAN::Frontend->mywarn("$now: waiting for read lock on '$file' (since $waitstart)\n");
|
||
|
|
}
|
||
|
|
sleep($sleep); # this sleep must not be overridden;
|
||
|
|
# Frontend->mysleep with AUTOMATED_TESTING has
|
||
|
|
# provoked complete lock contention on my NFS
|
||
|
|
if ($sleep <= 6) {
|
||
|
|
$sleep+=0.5;
|
||
|
|
} else {
|
||
|
|
# retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock
|
||
|
|
_plus_append_open($fh, $file);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
my $stats = eval { CPAN->_yaml_loadfile($file); };
|
||
|
|
if ($@) {
|
||
|
|
if (ref $@) {
|
||
|
|
if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
|
||
|
|
chomp $@;
|
||
|
|
$CPAN::Frontend->myprintonce("Warning (usually harmless): $@\n");
|
||
|
|
return;
|
||
|
|
} elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
|
||
|
|
my $time = time;
|
||
|
|
my $to = "$file.$time";
|
||
|
|
$CPAN::Frontend->mywarn("Error reading '$file': $@
|
||
|
|
Trying to stash it away as '$to' to prevent further interruptions.
|
||
|
|
You may want to remove that file later.\n");
|
||
|
|
# may fail because somebody else has moved it away in the meantime:
|
||
|
|
rename $file, $to or $CPAN::Frontend->mywarn("Could not rename '$file' to '$to': $!\n");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->mydie($@);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
CPAN::_flock($fh, LOCK_UN);
|
||
|
|
return $stats->[0];
|
||
|
|
}
|
||
|
|
|
||
|
|
#-> sub CPAN::FTP::_mytime
|
||
|
|
sub _mytime () {
|
||
|
|
if (CPAN->has_inst("Time::HiRes")) {
|
||
|
|
return Time::HiRes::time();
|
||
|
|
} else {
|
||
|
|
return time;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#-> sub CPAN::FTP::_new_stats
|
||
|
|
sub _new_stats {
|
||
|
|
my($self,$file) = @_;
|
||
|
|
my $ret = {
|
||
|
|
file => $file,
|
||
|
|
attempts => [],
|
||
|
|
start => _mytime,
|
||
|
|
};
|
||
|
|
$ret;
|
||
|
|
}
|
||
|
|
|
||
|
|
#-> sub CPAN::FTP::_add_to_statistics
|
||
|
|
sub _add_to_statistics {
|
||
|
|
my($self,$stats) = @_;
|
||
|
|
my $yaml_module = CPAN::_yaml_module();
|
||
|
|
$self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
|
||
|
|
if ($CPAN::META->has_inst($yaml_module)) {
|
||
|
|
$stats->{thesiteurl} = $ThesiteURL;
|
||
|
|
$stats->{end} = CPAN::FTP::_mytime();
|
||
|
|
my $fh = FileHandle->new;
|
||
|
|
my $time = time;
|
||
|
|
my $sdebug = 0;
|
||
|
|
my @debug;
|
||
|
|
@debug = $time if $sdebug;
|
||
|
|
my $fullstats = $self->_ftp_statistics($fh);
|
||
|
|
close $fh if $fh && defined(fileno($fh));
|
||
|
|
$fullstats->{history} ||= [];
|
||
|
|
push @debug, scalar @{$fullstats->{history}} if $sdebug;
|
||
|
|
push @debug, time if $sdebug;
|
||
|
|
push @{$fullstats->{history}}, $stats;
|
||
|
|
# YAML.pm 0.62 is unacceptably slow with 999;
|
||
|
|
# YAML::Syck 0.82 has no noticable performance problem with 999;
|
||
|
|
my $ftpstats_size = $CPAN::Config->{ftpstats_size};
|
||
|
|
$ftpstats_size = 99 unless defined $ftpstats_size;
|
||
|
|
my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
|
||
|
|
while (
|
||
|
|
@{$fullstats->{history} || []}
|
||
|
|
&&
|
||
|
|
(
|
||
|
|
@{$fullstats->{history}} > $ftpstats_size
|
||
|
|
|| $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
|
||
|
|
)
|
||
|
|
) {
|
||
|
|
shift @{$fullstats->{history}}
|
||
|
|
}
|
||
|
|
push @debug, scalar @{$fullstats->{history}} if $sdebug;
|
||
|
|
push @debug, time if $sdebug;
|
||
|
|
push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
|
||
|
|
# need no eval because if this fails, it is serious
|
||
|
|
my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
|
||
|
|
CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
|
||
|
|
if ( $sdebug ) {
|
||
|
|
local $CPAN::DEBUG = 512; # FTP
|
||
|
|
push @debug, time;
|
||
|
|
CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
|
||
|
|
"after[%d]at[%d]oldest[%s]dumped backat[%d]",
|
||
|
|
@debug,
|
||
|
|
));
|
||
|
|
}
|
||
|
|
# Win32 cannot rename a file to an existing filename
|
||
|
|
unlink($sfile) if ($^O eq 'MSWin32' or $^O eq 'os2');
|
||
|
|
_copy_stat($sfile, "$sfile.$$") if -e $sfile;
|
||
|
|
rename "$sfile.$$", $sfile
|
||
|
|
or $CPAN::Frontend->mywarn("Could not rename '$sfile.$$' to '$sfile': $!\nGiving up\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Copy some stat information (owner, group, mode and) from one file to
|
||
|
|
# another.
|
||
|
|
# This is a utility function which might be moved to a utility repository.
|
||
|
|
#-> sub CPAN::FTP::_copy_stat
|
||
|
|
sub _copy_stat {
|
||
|
|
my($src, $dest) = @_;
|
||
|
|
my @stat = stat($src);
|
||
|
|
if (!@stat) {
|
||
|
|
$CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
eval {
|
||
|
|
chmod $stat[2], $dest
|
||
|
|
or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
|
||
|
|
};
|
||
|
|
warn $@ if $@;
|
||
|
|
eval {
|
||
|
|
chown $stat[4], $stat[5], $dest
|
||
|
|
or do {
|
||
|
|
my $save_err = $!; # otherwise it's lost in the get... calls
|
||
|
|
$CPAN::Frontend->mywarn("Can't chown '$dest' to " .
|
||
|
|
(getpwuid($stat[4]))[0] . "/" .
|
||
|
|
(getgrgid($stat[5]))[0] . ": $save_err\n"
|
||
|
|
);
|
||
|
|
};
|
||
|
|
};
|
||
|
|
warn $@ if $@;
|
||
|
|
}
|
||
|
|
|
||
|
|
# if file is CHECKSUMS, suggest the place where we got the file to be
|
||
|
|
# checked from, maybe only for young files?
|
||
|
|
#-> sub CPAN::FTP::_recommend_url_for
|
||
|
|
sub _recommend_url_for {
|
||
|
|
my($self, $file, $urllist) = @_;
|
||
|
|
if ($file =~ s|/CHECKSUMS(.gz)?$||) {
|
||
|
|
my $fullstats = $self->_ftp_statistics();
|
||
|
|
my $history = $fullstats->{history} || [];
|
||
|
|
while (my $last = pop @$history) {
|
||
|
|
last if $last->{end} - time > 3600; # only young results are interesting
|
||
|
|
next unless $last->{file}; # dirname of nothing dies!
|
||
|
|
next unless $file eq dirname($last->{file});
|
||
|
|
return $last->{thesiteurl};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($CPAN::Config->{randomize_urllist}
|
||
|
|
&&
|
||
|
|
rand(1) < $CPAN::Config->{randomize_urllist}
|
||
|
|
) {
|
||
|
|
$urllist->[int rand scalar @$urllist];
|
||
|
|
} else {
|
||
|
|
return ();
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#-> sub CPAN::FTP::_get_urllist
|
||
|
|
sub _get_urllist {
|
||
|
|
my($self, $with_defaults) = @_;
|
||
|
|
$with_defaults ||= 0;
|
||
|
|
CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;
|
||
|
|
|
||
|
|
$CPAN::Config->{urllist} ||= [];
|
||
|
|
unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
|
||
|
|
$CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
|
||
|
|
$CPAN::Config->{urllist} = [];
|
||
|
|
}
|
||
|
|
my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
|
||
|
|
push @urllist, @CPAN::Defaultsites if $with_defaults;
|
||
|
|
for my $u (@urllist) {
|
||
|
|
CPAN->debug("u[$u]") if $CPAN::DEBUG;
|
||
|
|
if (UNIVERSAL::can($u,"text")) {
|
||
|
|
$u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
|
||
|
|
} else {
|
||
|
|
$u .= "/" unless substr($u,-1) eq "/";
|
||
|
|
$u = CPAN::URL->new(TEXT => $u, FROM => "USER");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
\@urllist;
|
||
|
|
}
|
||
|
|
|
||
|
|
#-> sub CPAN::FTP::ftp_get ;
|
||
|
|
sub ftp_get {
|
||
|
|
my($class,$host,$dir,$file,$target) = @_;
|
||
|
|
$class->debug(
|
||
|
|
qq[Going to fetch file [$file] from dir [$dir]
|
||
|
|
on host [$host] as local [$target]\n]
|
||
|
|
) if $CPAN::DEBUG;
|
||
|
|
my $ftp = Net::FTP->new($host);
|
||
|
|
unless ($ftp) {
|
||
|
|
$CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
return 0 unless defined $ftp;
|
||
|
|
$ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
|
||
|
|
$class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
|
||
|
|
unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
|
||
|
|
my $msg = $ftp->message;
|
||
|
|
$CPAN::Frontend->mywarn(" Couldn't login on $host: $msg\n");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
unless ( $ftp->cwd($dir) ) {
|
||
|
|
my $msg = $ftp->message;
|
||
|
|
$CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg\n");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$ftp->binary;
|
||
|
|
$class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
|
||
|
|
unless ( $ftp->get($file,$target) ) {
|
||
|
|
my $msg = $ftp->message;
|
||
|
|
$CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg\n");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$ftp->quit; # it's ok if this fails
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# If more accuracy is wanted/needed, Chris Leach sent me this patch...
|
||
|
|
|
||
|
|
# > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
|
||
|
|
# > --- /tmp/cp Wed Sep 24 13:26:40 1997
|
||
|
|
# > ***************
|
||
|
|
# > *** 1562,1567 ****
|
||
|
|
# > --- 1562,1580 ----
|
||
|
|
# > return 1 if substr($url,0,4) eq "file";
|
||
|
|
# > return 1 unless $url =~ m|://([^/]+)|;
|
||
|
|
# > my $host = $1;
|
||
|
|
# > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
|
||
|
|
# > + if ($proxy) {
|
||
|
|
# > + $proxy =~ m|://([^/:]+)|;
|
||
|
|
# > + $proxy = $1;
|
||
|
|
# > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
|
||
|
|
# > + if ($noproxy) {
|
||
|
|
# > + if ($host !~ /$noproxy$/) {
|
||
|
|
# > + $host = $proxy;
|
||
|
|
# > + }
|
||
|
|
# > + } else {
|
||
|
|
# > + $host = $proxy;
|
||
|
|
# > + }
|
||
|
|
# > + }
|
||
|
|
# > require Net::Ping;
|
||
|
|
# > return 1 unless $Net::Ping::VERSION >= 2;
|
||
|
|
# > my $p;
|
||
|
|
|
||
|
|
|
||
|
|
#-> sub CPAN::FTP::localize ;
|
||
|
|
sub localize {
|
||
|
|
my($self,$file,$aslocal,$force,$with_defaults) = @_;
|
||
|
|
$force ||= 0;
|
||
|
|
Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" )
|
||
|
|
unless defined $aslocal;
|
||
|
|
if ($CPAN::DEBUG){
|
||
|
|
require Carp;
|
||
|
|
my $longmess = Carp::longmess();
|
||
|
|
$self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
|
||
|
|
}
|
||
|
|
if ($^O eq 'MacOS') {
|
||
|
|
# Comment by AK on 2000-09-03: Uniq short filenames would be
|
||
|
|
# available in CHECKSUMS file
|
||
|
|
my($name, $path) = File::Basename::fileparse($aslocal, '');
|
||
|
|
if (length($name) > 31) {
|
||
|
|
$name =~ s/(
|
||
|
|
\.(
|
||
|
|
readme(\.(gz|Z))? |
|
||
|
|
(tar\.)?(gz|Z) |
|
||
|
|
tgz |
|
||
|
|
zip |
|
||
|
|
pm\.(gz|Z)
|
||
|
|
)
|
||
|
|
)$//x;
|
||
|
|
my $suf = $1;
|
||
|
|
my $size = 31 - length($suf);
|
||
|
|
while (length($name) > $size) {
|
||
|
|
chop $name;
|
||
|
|
}
|
||
|
|
$name .= $suf;
|
||
|
|
$aslocal = File::Spec->catfile($path, $name);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if (-f $aslocal && -r _ && !($force & 1)) {
|
||
|
|
my $size;
|
||
|
|
if ($size = -s $aslocal) {
|
||
|
|
$self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
|
||
|
|
return $aslocal;
|
||
|
|
} else {
|
||
|
|
# empty file from a previous unsuccessful attempt to download it
|
||
|
|
unlink $aslocal or
|
||
|
|
$CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
|
||
|
|
"could not remove.");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
my($maybe_restore) = 0;
|
||
|
|
if (-f $aslocal) {
|
||
|
|
rename $aslocal, "$aslocal.bak$$";
|
||
|
|
$maybe_restore++;
|
||
|
|
}
|
||
|
|
|
||
|
|
my($aslocal_dir) = dirname($aslocal);
|
||
|
|
# Inheritance is not easier to manage than a few if/else branches
|
||
|
|
if ($CPAN::META->has_usable('LWP::UserAgent')) {
|
||
|
|
unless ($Ua) {
|
||
|
|
CPAN::LWP::UserAgent->config;
|
||
|
|
eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
|
||
|
|
if ($@) {
|
||
|
|
$CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
|
||
|
|
if $CPAN::DEBUG;
|
||
|
|
} else {
|
||
|
|
my($var);
|
||
|
|
$Ua->proxy('ftp', $var)
|
||
|
|
if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
|
||
|
|
$Ua->proxy('http', $var)
|
||
|
|
if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
|
||
|
|
$Ua->no_proxy($var)
|
||
|
|
if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
|
||
|
|
$ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
|
||
|
|
}
|
||
|
|
|
||
|
|
# Try the list of urls for each single object. We keep a record
|
||
|
|
# where we did get a file from
|
||
|
|
my(@reordered,$last);
|
||
|
|
my $ccurllist = $self->_get_urllist($with_defaults);
|
||
|
|
$last = $#$ccurllist;
|
||
|
|
if ($force & 2) { # local cpans probably out of date, don't reorder
|
||
|
|
@reordered = (0..$last);
|
||
|
|
} else {
|
||
|
|
@reordered =
|
||
|
|
sort {
|
||
|
|
(substr($ccurllist->[$b],0,4) eq "file")
|
||
|
|
<=>
|
||
|
|
(substr($ccurllist->[$a],0,4) eq "file")
|
||
|
|
or
|
||
|
|
defined($ThesiteURL)
|
||
|
|
and
|
||
|
|
($ccurllist->[$b] eq $ThesiteURL)
|
||
|
|
<=>
|
||
|
|
($ccurllist->[$a] eq $ThesiteURL)
|
||
|
|
} 0..$last;
|
||
|
|
}
|
||
|
|
my(@levels);
|
||
|
|
$Themethod ||= "";
|
||
|
|
$self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
|
||
|
|
my @all_levels = (
|
||
|
|
["dleasy", "file"],
|
||
|
|
["dleasy"],
|
||
|
|
["dlhard"],
|
||
|
|
["dlhardest"],
|
||
|
|
["dleasy", "http","defaultsites"],
|
||
|
|
["dlhard", "http","defaultsites"],
|
||
|
|
["dleasy", "ftp", "defaultsites"],
|
||
|
|
["dlhard", "ftp", "defaultsites"],
|
||
|
|
["dlhardest","", "defaultsites"],
|
||
|
|
);
|
||
|
|
if ($Themethod) {
|
||
|
|
@levels = grep {$_->[0] eq $Themethod} @all_levels;
|
||
|
|
push @levels, grep {$_->[0] ne $Themethod} @all_levels;
|
||
|
|
} else {
|
||
|
|
@levels = @all_levels;
|
||
|
|
}
|
||
|
|
@levels = qw/dleasy/ if $^O eq 'MacOS';
|
||
|
|
my($levelno);
|
||
|
|
local $ENV{FTP_PASSIVE} =
|
||
|
|
exists $CPAN::Config->{ftp_passive} ?
|
||
|
|
$CPAN::Config->{ftp_passive} : 1;
|
||
|
|
my $ret;
|
||
|
|
my $stats = $self->_new_stats($file);
|
||
|
|
for ($CPAN::Config->{connect_to_internet_ok}) {
|
||
|
|
$connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
|
||
|
|
}
|
||
|
|
LEVEL: for $levelno (0..$#levels) {
|
||
|
|
my $level_tuple = $levels[$levelno];
|
||
|
|
my($level,$scheme,$sitetag) = @$level_tuple;
|
||
|
|
$self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
|
||
|
|
my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist;
|
||
|
|
my @urllist;
|
||
|
|
if ($defaultsites) {
|
||
|
|
unless (defined $connect_to_internet_ok) {
|
||
|
|
$CPAN::Frontend->myprint(sprintf qq{
|
||
|
|
I would like to connect to one of the following sites to get '%s':
|
||
|
|
|
||
|
|
%s
|
||
|
|
},
|
||
|
|
$file,
|
||
|
|
join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
|
||
|
|
);
|
||
|
|
my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
|
||
|
|
if ($answer =~ /^y/i) {
|
||
|
|
$connect_to_internet_ok = 1;
|
||
|
|
} else {
|
||
|
|
$connect_to_internet_ok = 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($connect_to_internet_ok) {
|
||
|
|
@urllist = @CPAN::Defaultsites;
|
||
|
|
} else {
|
||
|
|
my $sleep = 2;
|
||
|
|
# the tricky thing about dying here is that everybody
|
||
|
|
# believes that calls to exists() or all_objects() are
|
||
|
|
# safe.
|
||
|
|
require CPAN::Exception::blocked_urllist;
|
||
|
|
die CPAN::Exception::blocked_urllist->new;
|
||
|
|
}
|
||
|
|
} else { # ! $defaultsites
|
||
|
|
my @host_seq = $level =~ /dleasy/ ?
|
||
|
|
@reordered : 0..$last; # reordered has file and $Thesiteurl first
|
||
|
|
@urllist = map { $ccurllist->[$_] } @host_seq;
|
||
|
|
}
|
||
|
|
$self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
|
||
|
|
my $aslocal_tempfile = $aslocal . ".tmp" . $$;
|
||
|
|
if (my $recommend = $self->_recommend_url_for($file,\@urllist)) {
|
||
|
|
@urllist = grep { $_ ne $recommend } @urllist;
|
||
|
|
unshift @urllist, $recommend;
|
||
|
|
}
|
||
|
|
$self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
|
||
|
|
$ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
|
||
|
|
if ($ret) {
|
||
|
|
CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
|
||
|
|
if ($ret eq $aslocal_tempfile) {
|
||
|
|
# if we got it exactly as we asked for, only then we
|
||
|
|
# want to rename
|
||
|
|
rename $aslocal_tempfile, $aslocal
|
||
|
|
or $CPAN::Frontend->mydie("Error while trying to rename ".
|
||
|
|
"'$ret' to '$aslocal': $!");
|
||
|
|
$ret = $aslocal;
|
||
|
|
}
|
||
|
|
elsif (-f $ret && $scheme eq 'file' ) {
|
||
|
|
# it's a local file, so there's nothing left to do, we
|
||
|
|
# let them read from where it is
|
||
|
|
}
|
||
|
|
$Themethod = $level;
|
||
|
|
my $now = time;
|
||
|
|
# utime $now, $now, $aslocal; # too bad, if we do that, we
|
||
|
|
# might alter a local mirror
|
||
|
|
$self->debug("level[$level]") if $CPAN::DEBUG;
|
||
|
|
last LEVEL;
|
||
|
|
} else {
|
||
|
|
unlink $aslocal_tempfile;
|
||
|
|
last if $CPAN::Signal; # need to cleanup
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($ret) {
|
||
|
|
$stats->{filesize} = -s $ret;
|
||
|
|
}
|
||
|
|
$self->debug("before _add_to_statistics") if $CPAN::DEBUG;
|
||
|
|
$self->_add_to_statistics($stats);
|
||
|
|
$self->debug("after _add_to_statistics") if $CPAN::DEBUG;
|
||
|
|
if ($ret) {
|
||
|
|
unlink "$aslocal.bak$$";
|
||
|
|
return $ret;
|
||
|
|
}
|
||
|
|
unless ($CPAN::Signal) {
|
||
|
|
my(@mess);
|
||
|
|
local $" = " ";
|
||
|
|
if (@{$CPAN::Config->{urllist}}) {
|
||
|
|
push @mess,
|
||
|
|
qq{Please check, if the URLs I found in your configuration file \(}.
|
||
|
|
join(", ", @{$CPAN::Config->{urllist}}).
|
||
|
|
qq{\) are valid.};
|
||
|
|
} else {
|
||
|
|
push @mess, qq{Your urllist is empty!};
|
||
|
|
}
|
||
|
|
push @mess, qq{The urllist can be edited.},
|
||
|
|
qq{E.g. with 'o conf urllist push ftp://myurl/'};
|
||
|
|
$CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
|
||
|
|
$CPAN::Frontend->mydie("Could not fetch $file\n");
|
||
|
|
}
|
||
|
|
if ($maybe_restore) {
|
||
|
|
rename "$aslocal.bak$$", $aslocal;
|
||
|
|
$CPAN::Frontend->myprint("Trying to get away with old file:\n" .
|
||
|
|
$self->ls($aslocal) . "\n");
|
||
|
|
return $aslocal;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub mymkpath {
|
||
|
|
my($self, $aslocal_dir) = @_;
|
||
|
|
mkpath($aslocal_dir);
|
||
|
|
$CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
|
||
|
|
qq{directory "$aslocal_dir".
|
||
|
|
I\'ll continue, but if you encounter problems, they may be due
|
||
|
|
to insufficient permissions.\n}) unless -w $aslocal_dir;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub hostdlxxx {
|
||
|
|
my $self = shift;
|
||
|
|
my $level = shift;
|
||
|
|
my $scheme = shift;
|
||
|
|
my $h = shift;
|
||
|
|
$h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
|
||
|
|
my $method = "host$level";
|
||
|
|
$self->$method($h, @_);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _set_attempt {
|
||
|
|
my($self,$stats,$method,$url) = @_;
|
||
|
|
push @{$stats->{attempts}}, {
|
||
|
|
method => $method,
|
||
|
|
start => _mytime,
|
||
|
|
url => $url,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# package CPAN::FTP;
|
||
|
|
sub hostdleasy { #called from hostdlxxx
|
||
|
|
my($self,$host_seq,$file,$aslocal,$stats) = @_;
|
||
|
|
my($ro_url);
|
||
|
|
HOSTEASY: for $ro_url (@$host_seq) {
|
||
|
|
$self->_set_attempt($stats,"dleasy",$ro_url);
|
||
|
|
my $url = "$ro_url$file";
|
||
|
|
$self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
|
||
|
|
if ($url =~ /^file:/) {
|
||
|
|
my $l;
|
||
|
|
if ($CPAN::META->has_inst('URI::URL')) {
|
||
|
|
my $u = URI::URL->new($url);
|
||
|
|
$l = $u->file;
|
||
|
|
} else { # works only on Unix, is poorly constructed, but
|
||
|
|
# hopefully better than nothing.
|
||
|
|
# RFC 1738 says fileurl BNF is
|
||
|
|
# fileurl = "file://" [ host | "localhost" ] "/" fpath
|
||
|
|
# Thanks to "Mark D. Baushke" <mdb@cisco.com> for
|
||
|
|
# the code
|
||
|
|
($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
|
||
|
|
$l =~ s|^file:||; # assume they
|
||
|
|
# meant
|
||
|
|
# file://localhost
|
||
|
|
$l =~ s|^/||s
|
||
|
|
if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
|
||
|
|
}
|
||
|
|
$self->debug("local file[$l]") if $CPAN::DEBUG;
|
||
|
|
if ( -f $l && -r _) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $l;
|
||
|
|
}
|
||
|
|
# If request is for a compressed file and we can find the
|
||
|
|
# uncompressed file also, return the path of the uncompressed file
|
||
|
|
# otherwise, decompress it and return the resulting path
|
||
|
|
if ($l =~ /(.+)\.gz$/) {
|
||
|
|
my $ungz = $1;
|
||
|
|
if ( -f $ungz && -r _) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $ungz;
|
||
|
|
}
|
||
|
|
elsif (-f $l && -r _) {
|
||
|
|
eval { CPAN::Tarzip->new($l)->gunzip($aslocal) };
|
||
|
|
if ( -f $aslocal && -s _) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
}
|
||
|
|
elsif (! -s $aslocal) {
|
||
|
|
unlink $aslocal;
|
||
|
|
}
|
||
|
|
elsif (-f $l) {
|
||
|
|
$CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
|
||
|
|
if $@;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# Otherwise, return the local file path if it exists
|
||
|
|
elsif ( -f $l && -r _) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $l;
|
||
|
|
}
|
||
|
|
# If we can't find it, but there is a compressed version
|
||
|
|
# of it, then decompress it
|
||
|
|
elsif (-f "$l.gz") {
|
||
|
|
$self->debug("found compressed $l.gz") if $CPAN::DEBUG;
|
||
|
|
eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
|
||
|
|
if ( -f $aslocal) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
|
||
|
|
if $@;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$CPAN::Frontend->mywarn("Could not find '$l'\n");
|
||
|
|
}
|
||
|
|
$self->debug("it was not a file URL") if $CPAN::DEBUG;
|
||
|
|
if ($CPAN::META->has_usable('LWP')) {
|
||
|
|
$CPAN::Frontend->myprint("Fetching with LWP:\n$url\n");
|
||
|
|
unless ($Ua) {
|
||
|
|
CPAN::LWP::UserAgent->config;
|
||
|
|
eval { $Ua = CPAN::LWP::UserAgent->new; };
|
||
|
|
if ($@) {
|
||
|
|
$CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
my $res = $Ua->mirror($url, $aslocal);
|
||
|
|
if ($res->is_success) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
my $now = time;
|
||
|
|
utime $now, $now, $aslocal; # download time is more
|
||
|
|
# important than upload
|
||
|
|
# time
|
||
|
|
return $aslocal;
|
||
|
|
} elsif ($url !~ /\.gz(?!\n)\Z/) {
|
||
|
|
my $gzurl = "$url.gz";
|
||
|
|
$CPAN::Frontend->myprint("Fetching with LWP:\n$gzurl\n");
|
||
|
|
$res = $Ua->mirror($gzurl, "$aslocal.gz");
|
||
|
|
if ($res->is_success) {
|
||
|
|
if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->myprint(sprintf(
|
||
|
|
"LWP failed with code[%s] message[%s]\n",
|
||
|
|
$res->code,
|
||
|
|
$res->message,
|
||
|
|
));
|
||
|
|
# Alan Burlison informed me that in firewall environments
|
||
|
|
# Net::FTP can still succeed where LWP fails. So we do not
|
||
|
|
# skip Net::FTP anymore when LWP is available.
|
||
|
|
}
|
||
|
|
} elsif ($url =~ /^http:/i && $CPAN::META->has_usable('HTTP::Tiny')) {
|
||
|
|
require CPAN::HTTP::Client;
|
||
|
|
my $chc = CPAN::HTTP::Client->new(
|
||
|
|
proxy => $CPAN::Config->{http_proxy} || $ENV{http_proxy},
|
||
|
|
no_proxy => $CPAN::Config->{no_proxy} || $ENV{no_proxy},
|
||
|
|
);
|
||
|
|
for my $try ( $url, ( $url !~ /\.gz(?!\n)\Z/ ? "$url.gz" : () ) ) {
|
||
|
|
$CPAN::Frontend->myprint("Fetching with HTTP::Tiny:\n$try\n");
|
||
|
|
my $res = eval { $chc->mirror($try, $aslocal) };
|
||
|
|
if ( $res && $res->{success} ) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
my $now = time;
|
||
|
|
utime $now, $now, $aslocal; # download time is more
|
||
|
|
# important than upload
|
||
|
|
# time
|
||
|
|
return $aslocal;
|
||
|
|
}
|
||
|
|
elsif ( $res && $res->{status} ne '599') {
|
||
|
|
$CPAN::Frontend->myprint(sprintf(
|
||
|
|
"HTTP::Tiny failed with code[%s] message[%s]\n",
|
||
|
|
$res->{status},
|
||
|
|
$res->{reason},
|
||
|
|
)
|
||
|
|
);
|
||
|
|
}
|
||
|
|
elsif ( $res && $res->{status} eq '599') {
|
||
|
|
$CPAN::Frontend->myprint(sprintf(
|
||
|
|
"HTTP::Tiny failed with an internal error: %s\n",
|
||
|
|
$res->{content},
|
||
|
|
)
|
||
|
|
);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $err = $@ || 'Unknown error';
|
||
|
|
$CPAN::Frontend->myprint(sprintf(
|
||
|
|
"Error downloading with HTTP::Tiny: %s\n", $err
|
||
|
|
)
|
||
|
|
);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return if $CPAN::Signal;
|
||
|
|
if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
|
||
|
|
# that's the nice and easy way thanks to Graham
|
||
|
|
$self->debug("recognized ftp") if $CPAN::DEBUG;
|
||
|
|
my($host,$dir,$getfile) = ($1,$2,$3);
|
||
|
|
if ($CPAN::META->has_usable('Net::FTP')) {
|
||
|
|
$dir =~ s|/+|/|g;
|
||
|
|
$CPAN::Frontend->myprint("Fetching with Net::FTP:\n$url\n");
|
||
|
|
$self->debug("getfile[$getfile]dir[$dir]host[$host]" .
|
||
|
|
"aslocal[$aslocal]") if $CPAN::DEBUG;
|
||
|
|
if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
}
|
||
|
|
if ($aslocal !~ /\.gz(?!\n)\Z/) {
|
||
|
|
my $gz = "$aslocal.gz";
|
||
|
|
$CPAN::Frontend->myprint("Fetching with Net::FTP\n$url.gz\n");
|
||
|
|
if (CPAN::FTP->ftp_get($host,
|
||
|
|
$dir,
|
||
|
|
"$getfile.gz",
|
||
|
|
$gz) &&
|
||
|
|
eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
|
||
|
|
) {
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# next HOSTEASY;
|
||
|
|
} else {
|
||
|
|
CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if (
|
||
|
|
UNIVERSAL::can($ro_url,"text")
|
||
|
|
and
|
||
|
|
$ro_url->{FROM} eq "USER"
|
||
|
|
) {
|
||
|
|
##address #17973: default URLs should not try to override
|
||
|
|
##user-defined URLs just because LWP is not available
|
||
|
|
my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
|
||
|
|
return $ret if $ret;
|
||
|
|
}
|
||
|
|
return if $CPAN::Signal;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# package CPAN::FTP;
|
||
|
|
sub hostdlhard {
|
||
|
|
my($self,$host_seq,$file,$aslocal,$stats) = @_;
|
||
|
|
|
||
|
|
# Came back if Net::FTP couldn't establish connection (or
|
||
|
|
# failed otherwise) Maybe they are behind a firewall, but they
|
||
|
|
# gave us a socksified (or other) ftp program...
|
||
|
|
|
||
|
|
my($ro_url);
|
||
|
|
my($devnull) = $CPAN::Config->{devnull} || "";
|
||
|
|
# < /dev/null ";
|
||
|
|
my($aslocal_dir) = dirname($aslocal);
|
||
|
|
mkpath($aslocal_dir);
|
||
|
|
my $some_dl_success = 0;
|
||
|
|
my $any_attempt = 0;
|
||
|
|
HOSTHARD: for $ro_url (@$host_seq) {
|
||
|
|
$self->_set_attempt($stats,"dlhard",$ro_url);
|
||
|
|
my $url = "$ro_url$file";
|
||
|
|
my($proto,$host,$dir,$getfile);
|
||
|
|
|
||
|
|
# Courtesy Mark Conty mark_conty@cargill.com change from
|
||
|
|
# if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
|
||
|
|
# to
|
||
|
|
if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
|
||
|
|
# proto not yet used
|
||
|
|
($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
|
||
|
|
} else {
|
||
|
|
next HOSTHARD; # who said, we could ftp anything except ftp?
|
||
|
|
}
|
||
|
|
next HOSTHARD if $proto eq "file"; # file URLs would have had
|
||
|
|
# success above. Likely a bogus URL
|
||
|
|
|
||
|
|
# making at least one attempt against a host
|
||
|
|
$any_attempt++;
|
||
|
|
|
||
|
|
$self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
|
||
|
|
|
||
|
|
# Try the most capable first and leave ncftp* for last as it only
|
||
|
|
# does FTP.
|
||
|
|
my $proxy_vars = $self->_proxy_vars($ro_url);
|
||
|
|
DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
|
||
|
|
my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
|
||
|
|
next DLPRG unless defined $funkyftp;
|
||
|
|
next DLPRG if $funkyftp =~ /^\s*$/;
|
||
|
|
|
||
|
|
my($src_switch) = "";
|
||
|
|
my($chdir) = "";
|
||
|
|
my($stdout_redir) = " > \"$aslocal\"";
|
||
|
|
if ($f eq "lynx") {
|
||
|
|
$src_switch = " -source";
|
||
|
|
} elsif ($f eq "ncftp") {
|
||
|
|
next DLPRG unless $url =~ m{\Aftp://};
|
||
|
|
$src_switch = " -c";
|
||
|
|
} elsif ($f eq "wget") {
|
||
|
|
$src_switch = " -O \"$aslocal\"";
|
||
|
|
$stdout_redir = "";
|
||
|
|
} elsif ($f eq 'curl') {
|
||
|
|
$src_switch = ' -L -f -s -S --netrc-optional';
|
||
|
|
if ($proxy_vars->{http_proxy}) {
|
||
|
|
$src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
|
||
|
|
}
|
||
|
|
} elsif ($f eq "ncftpget") {
|
||
|
|
next DLPRG unless $url =~ m{\Aftp://};
|
||
|
|
$chdir = "cd $aslocal_dir && ";
|
||
|
|
$stdout_redir = "";
|
||
|
|
}
|
||
|
|
$CPAN::Frontend->myprint(
|
||
|
|
qq[
|
||
|
|
Trying with
|
||
|
|
$funkyftp$src_switch
|
||
|
|
to get
|
||
|
|
$url
|
||
|
|
]);
|
||
|
|
my($system) =
|
||
|
|
"$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
|
||
|
|
$self->debug("system[$system]") if $CPAN::DEBUG;
|
||
|
|
my($wstatus) = system($system);
|
||
|
|
if ($f eq "lynx") {
|
||
|
|
# lynx returns 0 when it fails somewhere
|
||
|
|
if (-s $aslocal) {
|
||
|
|
my $content = do { local *FH;
|
||
|
|
open FH, $aslocal or die;
|
||
|
|
local $/;
|
||
|
|
<FH> };
|
||
|
|
if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
|
||
|
|
$CPAN::Frontend->mywarn(qq{
|
||
|
|
No success, the file that lynx has downloaded looks like an error message:
|
||
|
|
$content
|
||
|
|
});
|
||
|
|
$CPAN::Frontend->mysleep(1);
|
||
|
|
next DLPRG;
|
||
|
|
}
|
||
|
|
$some_dl_success++;
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->myprint(qq{
|
||
|
|
No success, the file that lynx has downloaded is an empty file.
|
||
|
|
});
|
||
|
|
next DLPRG;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($wstatus == 0) {
|
||
|
|
if (-s $aslocal) {
|
||
|
|
# Looks good
|
||
|
|
$some_dl_success++;
|
||
|
|
}
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
} else {
|
||
|
|
my $estatus = $wstatus >> 8;
|
||
|
|
my $size = -f $aslocal ?
|
||
|
|
", left\n$aslocal with size ".-s _ :
|
||
|
|
"\nWarning: expected file [$aslocal] doesn't exist";
|
||
|
|
$CPAN::Frontend->myprint(qq{
|
||
|
|
Function system("$system")
|
||
|
|
returned status $estatus (wstat $wstatus)$size
|
||
|
|
});
|
||
|
|
}
|
||
|
|
return if $CPAN::Signal;
|
||
|
|
} # download/transfer programs (DLPRG)
|
||
|
|
} # host
|
||
|
|
return unless $any_attempt;
|
||
|
|
if ($some_dl_success) {
|
||
|
|
$CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n");
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n");
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
#-> CPAN::FTP::_proxy_vars
|
||
|
|
sub _proxy_vars {
|
||
|
|
my($self,$url) = @_;
|
||
|
|
my $ret = +{};
|
||
|
|
my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
|
||
|
|
if ($http_proxy) {
|
||
|
|
my($host) = $url =~ m|://([^/:]+)|;
|
||
|
|
my $want_proxy = 1;
|
||
|
|
my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
|
||
|
|
my @noproxy = split /\s*,\s*/, $noproxy;
|
||
|
|
if ($host) {
|
||
|
|
DOMAIN: for my $domain (@noproxy) {
|
||
|
|
if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
|
||
|
|
$want_proxy = 0;
|
||
|
|
last DOMAIN;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n");
|
||
|
|
}
|
||
|
|
if ($want_proxy) {
|
||
|
|
my($user, $pass) =
|
||
|
|
CPAN::HTTP::Credentials->get_proxy_credentials();
|
||
|
|
$ret = {
|
||
|
|
proxy_user => $user,
|
||
|
|
proxy_pass => $pass,
|
||
|
|
http_proxy => $http_proxy
|
||
|
|
};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $ret;
|
||
|
|
}
|
||
|
|
|
||
|
|
# package CPAN::FTP;
|
||
|
|
sub hostdlhardest {
|
||
|
|
my($self,$host_seq,$file,$aslocal,$stats) = @_;
|
||
|
|
|
||
|
|
return unless @$host_seq;
|
||
|
|
my($ro_url);
|
||
|
|
my($aslocal_dir) = dirname($aslocal);
|
||
|
|
mkpath($aslocal_dir);
|
||
|
|
my $ftpbin = $CPAN::Config->{ftp};
|
||
|
|
unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
|
||
|
|
$CPAN::Frontend->myprint("No external ftp command available\n\n");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$CPAN::Frontend->mywarn(qq{
|
||
|
|
As a last resort we now switch to the external ftp command '$ftpbin'
|
||
|
|
to get '$aslocal'.
|
||
|
|
|
||
|
|
Doing so often leads to problems that are hard to diagnose.
|
||
|
|
|
||
|
|
If you're the victim of such problems, please consider unsetting the
|
||
|
|
ftp config variable with
|
||
|
|
|
||
|
|
o conf ftp ""
|
||
|
|
o conf commit
|
||
|
|
|
||
|
|
});
|
||
|
|
$CPAN::Frontend->mysleep(2);
|
||
|
|
HOSTHARDEST: for $ro_url (@$host_seq) {
|
||
|
|
$self->_set_attempt($stats,"dlhardest",$ro_url);
|
||
|
|
my $url = "$ro_url$file";
|
||
|
|
$self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
|
||
|
|
unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
my($host,$dir,$getfile) = ($1,$2,$3);
|
||
|
|
my $timestamp = 0;
|
||
|
|
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
|
||
|
|
$ctime,$blksize,$blocks) = stat($aslocal);
|
||
|
|
$timestamp = $mtime ||= 0;
|
||
|
|
my($netrc) = CPAN::FTP::netrc->new;
|
||
|
|
my($netrcfile) = $netrc->netrc;
|
||
|
|
my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
|
||
|
|
my $targetfile = File::Basename::basename($aslocal);
|
||
|
|
my(@dialog);
|
||
|
|
push(
|
||
|
|
@dialog,
|
||
|
|
"lcd $aslocal_dir",
|
||
|
|
"cd /",
|
||
|
|
map("cd $_", split /\//, $dir), # RFC 1738
|
||
|
|
"bin",
|
||
|
|
"passive",
|
||
|
|
"get $getfile $targetfile",
|
||
|
|
"quit"
|
||
|
|
);
|
||
|
|
if (! $netrcfile) {
|
||
|
|
CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
|
||
|
|
} elsif ($netrc->hasdefault || $netrc->contains($host)) {
|
||
|
|
CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
|
||
|
|
$netrc->hasdefault,
|
||
|
|
$netrc->contains($host))) if $CPAN::DEBUG;
|
||
|
|
if ($netrc->protected) {
|
||
|
|
my $dialog = join "", map { " $_\n" } @dialog;
|
||
|
|
my $netrc_explain;
|
||
|
|
if ($netrc->contains($host)) {
|
||
|
|
$netrc_explain = "Relying that your .netrc entry for '$host' ".
|
||
|
|
"manages the login";
|
||
|
|
} else {
|
||
|
|
$netrc_explain = "Relying that your default .netrc entry ".
|
||
|
|
"manages the login";
|
||
|
|
}
|
||
|
|
$CPAN::Frontend->myprint(qq{
|
||
|
|
Trying with external ftp to get
|
||
|
|
'$url'
|
||
|
|
$netrc_explain
|
||
|
|
Sending the dialog
|
||
|
|
$dialog
|
||
|
|
}
|
||
|
|
);
|
||
|
|
$self->talk_ftp("$ftpbin$verbose $host",
|
||
|
|
@dialog);
|
||
|
|
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
|
||
|
|
$atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
|
||
|
|
$mtime ||= 0;
|
||
|
|
if ($mtime > $timestamp) {
|
||
|
|
$CPAN::Frontend->myprint("GOT $aslocal\n");
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->myprint("Hmm... Still failed!\n");
|
||
|
|
}
|
||
|
|
return if $CPAN::Signal;
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
|
||
|
|
qq{correctly protected.\n});
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
|
||
|
|
nor does it have a default entry\n");
|
||
|
|
}
|
||
|
|
|
||
|
|
# OK, they don't have a valid ~/.netrc. Use 'ftp -n'
|
||
|
|
# then and login manually to host, using e-mail as
|
||
|
|
# password.
|
||
|
|
$CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
|
||
|
|
unshift(
|
||
|
|
@dialog,
|
||
|
|
"open $host",
|
||
|
|
"user anonymous $Config::Config{'cf_email'}"
|
||
|
|
);
|
||
|
|
my $dialog = join "", map { " $_\n" } @dialog;
|
||
|
|
$CPAN::Frontend->myprint(qq{
|
||
|
|
Trying with external ftp to get
|
||
|
|
$url
|
||
|
|
Sending the dialog
|
||
|
|
$dialog
|
||
|
|
}
|
||
|
|
);
|
||
|
|
$self->talk_ftp("$ftpbin$verbose -n", @dialog);
|
||
|
|
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
|
||
|
|
$atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
|
||
|
|
$mtime ||= 0;
|
||
|
|
if ($mtime > $timestamp) {
|
||
|
|
$CPAN::Frontend->myprint("GOT $aslocal\n");
|
||
|
|
$ThesiteURL = $ro_url;
|
||
|
|
return $aslocal;
|
||
|
|
} else {
|
||
|
|
$CPAN::Frontend->myprint("Bad luck... Still failed!\n");
|
||
|
|
}
|
||
|
|
return if $CPAN::Signal;
|
||
|
|
$CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
|
||
|
|
$CPAN::Frontend->mysleep(2);
|
||
|
|
} # host
|
||
|
|
}
|
||
|
|
|
||
|
|
# package CPAN::FTP;
|
||
|
|
sub talk_ftp {
|
||
|
|
my($self,$command,@dialog) = @_;
|
||
|
|
my $fh = FileHandle->new;
|
||
|
|
$fh->open("|$command") or die "Couldn't open ftp: $!";
|
||
|
|
foreach (@dialog) { $fh->print("$_\n") }
|
||
|
|
$fh->close; # Wait for process to complete
|
||
|
|
my $wstatus = $?;
|
||
|
|
my $estatus = $wstatus >> 8;
|
||
|
|
$CPAN::Frontend->myprint(qq{
|
||
|
|
Subprocess "|$command"
|
||
|
|
returned status $estatus (wstat $wstatus)
|
||
|
|
}) if $wstatus;
|
||
|
|
}
|
||
|
|
|
||
|
|
# find2perl needs modularization, too, all the following is stolen
|
||
|
|
# from there
|
||
|
|
# CPAN::FTP::ls
|
||
|
|
sub ls {
|
||
|
|
my($self,$name) = @_;
|
||
|
|
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
|
||
|
|
$atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
|
||
|
|
|
||
|
|
my($perms,%user,%group);
|
||
|
|
my $pname = $name;
|
||
|
|
|
||
|
|
if ($blocks) {
|
||
|
|
$blocks = int(($blocks + 1) / 2);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$blocks = int(($sizemm + 1023) / 1024);
|
||
|
|
}
|
||
|
|
|
||
|
|
if (-f _) { $perms = '-'; }
|
||
|
|
elsif (-d _) { $perms = 'd'; }
|
||
|
|
elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
|
||
|
|
elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
|
||
|
|
elsif (-p _) { $perms = 'p'; }
|
||
|
|
elsif (-S _) { $perms = 's'; }
|
||
|
|
else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
|
||
|
|
|
||
|
|
my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
|
||
|
|
my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
||
|
|
my $tmpmode = $mode;
|
||
|
|
my $tmp = $rwx[$tmpmode & 7];
|
||
|
|
$tmpmode >>= 3;
|
||
|
|
$tmp = $rwx[$tmpmode & 7] . $tmp;
|
||
|
|
$tmpmode >>= 3;
|
||
|
|
$tmp = $rwx[$tmpmode & 7] . $tmp;
|
||
|
|
substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
|
||
|
|
substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
|
||
|
|
substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
|
||
|
|
$perms .= $tmp;
|
||
|
|
|
||
|
|
my $user = $user{$uid} || $uid; # too lazy to implement lookup
|
||
|
|
my $group = $group{$gid} || $gid;
|
||
|
|
|
||
|
|
my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
|
||
|
|
my($timeyear);
|
||
|
|
my($moname) = $moname[$mon];
|
||
|
|
if (-M _ > 365.25 / 2) {
|
||
|
|
$timeyear = $year + 1900;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$timeyear = sprintf("%02d:%02d", $hour, $min);
|
||
|
|
}
|
||
|
|
|
||
|
|
sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
|
||
|
|
$ino,
|
||
|
|
$blocks,
|
||
|
|
$perms,
|
||
|
|
$nlink,
|
||
|
|
$user,
|
||
|
|
$group,
|
||
|
|
$sizemm,
|
||
|
|
$moname,
|
||
|
|
$mday,
|
||
|
|
$timeyear,
|
||
|
|
$pname;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|