From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm | 1146 ++++++++++++++++++++ 1 file changed, 1146 insertions(+) create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm') diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm new file mode 100644 index 0000000000..6d9800e31b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm @@ -0,0 +1,1146 @@ +# -*- 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.5011"; + +sub _plus_append_open { + my($fh, $file) = @_; + my $parent_dir = dirname $file; + mkpath $parent_dir; + my($cnt); + until (open $fh, "+>>$file") { + next if $! == 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 $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"); + _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; + $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->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" 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 $/; + }; + if ($content =~ /^<.*([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; -- cgit v1.2.3