#$@%#$%!

Ngiler SH3LL 360
: / usr / share / perl5 / vendor_perl / CPAN /

Information Server
MySQL : OFF Perl : OFF CURL : ON WGET : OFF PKEXEC : OFF

Directive	Local Value
IP Address	162.0.209.101
System	Linux premium169.web-hosting.com 4.18.0-553.50.1.lve.el8.x86_64 #1 SMP Thu Apr 17 19:10:24 UTC 2025 x86_64
User	luxeelil
PHP Version	8.0.30
Software	LiteSpeed
Doc root	Writable

Edit File : FTP.pm \| Size : 41.63 KB
# -- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -- # vim: ts=4 sts=4 sw=4: package CPAN::FTP; use strict; 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.5008"; #-> sub CPAN::FTP::ftp_statistics # if they want to rewrite, they need to pass in a filehandle sub _ftp_statistics { my($self,$fh) = @_; 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_load_file() 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"); mkpath dirname $file; open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$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 <= 3) { $sleep+=0.33; } elsif ($sleep <= 6) { $sleep+=0.11; } else { # retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$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->myprint("Error reading '$file': $@\nStashing away as '$to' to prevent further interruptions. You may want to remove that file later.\n"); rename $file, $to or $CPAN::Frontend->mydie("Could not rename: $!"); 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; $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} \|\| 99; my $ftpstats_period = $CPAN::Config->{ftpstats_period} \|\| 14; while ( @{$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->mydie("Could not rename '$sfile.$$' to '$sfile': $!\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; Back

Edit File : FTP.pm | Size : 41.63 KB

# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::FTP;
use strict;

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.5008";

#-> sub CPAN::FTP::ftp_statistics
# if they want to rewrite, they need to pass in a filehandle
sub _ftp_statistics {
    my($self,$fh) = @_;
    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_load_file() 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");
    mkpath dirname $file;
    open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$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 <= 3) {
            $sleep+=0.33;
        } elsif ($sleep <= 6) {
            $sleep+=0.11;
        } else {
            # retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock
            open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$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->myprint("Error reading '$file': $@\nStashing away as '$to' to prevent further interruptions. You may want to remove that file later.\n");
                rename $file, $to or $CPAN::Frontend->mydie("Could not rename: $!");
                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;
        $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} || 99;
        my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
        while (
               @{$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->mydie("Could not rename '$sfile.$$' to '$sfile': $!\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;
}

Back