Spaces:
Running
Running
| # -*- 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" <[email protected]> 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 [email protected] 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; | |