lib/CPAN/FTP.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 # vim: ts=4 sts=4 sw=4:
   3 package CPAN::FTP;
   4 use strict;
   5
   6 use Fcntl qw(:flock);
   7 use File::Basename qw(dirname);
   8 use File::Path qw(mkpath);
   9 use CPAN::FTP::netrc;
  10 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
  11 @CPAN::FTP::ISA = qw(CPAN::Debug);
  12
  13 use vars qw(
  14             $VERSION
  15 );
  16 $VERSION = "5.5";
  17
  18 #-> sub CPAN::FTP::ftp_statistics
  19 # if they want to rewrite, they need to pass in a filehandle
  20 sub _ftp_statistics {
  21     my($self,$fh) = @_;
  22     my $locktype = $fh ? LOCK_EX : LOCK_SH;
  23     $fh ||= FileHandle->new;
  24     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
  25     mkpath dirname $file;
  26     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
  27     my $sleep = 1;
  28     my $waitstart;
  29     while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
  30         $waitstart ||= localtime();
  31         if ($sleep>3) {
  32             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
  33         }
  34         $CPAN::Frontend->mysleep($sleep);
  35         if ($sleep <= 3) {
  36             $sleep+=0.33;
  37         } elsif ($sleep <=6) {
  38             $sleep+=0.11;
  39         }
  40     }
  41     my $stats = eval { CPAN->_yaml_loadfile($file); };
  42     if ($@) {
  43         if (ref $@) {
  44             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
  45                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
  46                 return;
  47             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
  48                 $CPAN::Frontend->mydie($@);
  49             }
  50         } else {
  51             $CPAN::Frontend->mydie($@);
  52         }
  53     }
  54     return $stats->[0];
  55 }
  56
  57 #-> sub CPAN::FTP::_mytime
  58 sub _mytime () {
  59     if (CPAN->has_inst("Time::HiRes")) {
  60         return Time::HiRes::time();
  61     } else {
  62         return time;
  63     }
  64 }
  65
  66 #-> sub CPAN::FTP::_new_stats
  67 sub _new_stats {
  68     my($self,$file) = @_;
  69     my $ret = {
  70                file => $file,
  71                attempts => [],
  72                start => _mytime,
  73               };
  74     $ret;
  75 }
  76
  77 #-> sub CPAN::FTP::_add_to_statistics
  78 sub _add_to_statistics {
  79     my($self,$stats) = @_;
  80     my $yaml_module = CPAN::_yaml_module();
  81     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
  82     if ($CPAN::META->has_inst($yaml_module)) {
  83         $stats->{thesiteurl} = $ThesiteURL;
  84         $stats->{end} = CPAN::FTP::_mytime();
  85         my $fh = FileHandle->new;
  86         my $time = time;
  87         my $sdebug = 0;
  88         my @debug;
  89         @debug = $time if $sdebug;
  90         my $fullstats = $self->_ftp_statistics($fh);
  91         close $fh;
  92         $fullstats->{history} ||= [];
  93         push @debug, scalar @{$fullstats->{history}} if $sdebug;
  94         push @debug, time if $sdebug;
  95         push @{$fullstats->{history}}, $stats;
  96         # YAML.pm 0.62 is unacceptably slow with 999;
  97         # YAML::Syck 0.82 has no noticable performance problem with 999;
  98         my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
  99         my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
 100         while (
 101                @{$fullstats->{history}} > $ftpstats_size
 102                || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
 103               ) {
 104             shift @{$fullstats->{history}}
 105         }
 106         push @debug, scalar @{$fullstats->{history}} if $sdebug;
 107         push @debug, time if $sdebug;
 108         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
 109         # need no eval because if this fails, it is serious
 110         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
 111         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
 112         if ( $sdebug ) {
 113             local $CPAN::DEBUG = 512; # FTP
 114             push @debug, time;
 115             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
 116                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
 117                                 @debug,
 118                                ));
 119         }
 120         # Win32 cannot rename a file to an existing filename
 121         unlink($sfile) if ($^O eq 'MSWin32');
 122         _copy_stat($sfile, "$sfile.$$") if -e $sfile;
 123         rename "$sfile.$$", $sfile
 124             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
 125     }
 126 }
 127
 128 # Copy some stat information (owner, group, mode and) from one file to
 129 # another.
 130 # This is a utility function which might be moved to a utility repository.
 131 #-> sub CPAN::FTP::_copy_stat
 132 sub _copy_stat {
 133     my($src, $dest) = @_;
 134     my @stat = stat($src);
 135     if (!@stat) {
 136         $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
 137         return;
 138     }
 139
 140     eval {
 141         chmod $stat[2], $dest
 142             or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
 143     };
 144     warn $@ if $@;
 145     eval {
 146         chown $stat[4], $stat[5], $dest
 147             or do {
 148                 my $save_err = $!; # otherwise it's lost in the get... calls
 149                 $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
 150                                         (getpwuid($stat[4]))[0] . "/" .
 151                                         (getgrgid($stat[5]))[0] . ": $save_err\n"
 152                                        );
 153             };
 154     };
 155     warn $@ if $@;
 156 }
 157
 158 # if file is CHECKSUMS, suggest the place where we got the file to be
 159 # checked from, maybe only for young files?
 160 #-> sub CPAN::FTP::_recommend_url_for
 161 sub _recommend_url_for {
 162     my($self, $file) = @_;
 163     my $urllist = $self->_get_urllist;
 164     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
 165         my $fullstats = $self->_ftp_statistics();
 166         my $history = $fullstats->{history} || [];
 167         while (my $last = pop @$history) {
 168             last if $last->{end} - time > 3600; # only young results are interesting
 169             next unless $last->{file}; # dirname of nothing dies!
 170             next unless $file eq dirname($last->{file});
 171             return $last->{thesiteurl};
 172         }
 173     }
 174     if ($CPAN::Config->{randomize_urllist}
 175         &&
 176         rand(1) < $CPAN::Config->{randomize_urllist}
 177        ) {
 178         $urllist->[int rand scalar @$urllist];
 179     } else {
 180         return ();
 181     }
 182 }
 183
 184 #-> sub CPAN::FTP::_get_urllist
 185 sub _get_urllist {
 186     my($self) = @_;
 187     $CPAN::Config->{urllist} ||= [];
 188     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
 189         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
 190         $CPAN::Config->{urllist} = [];
 191     }
 192     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
 193     for my $u (@urllist) {
 194         CPAN->debug("u[$u]") if $CPAN::DEBUG;
 195         if (UNIVERSAL::can($u,"text")) {
 196             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
 197         } else {
 198             $u .= "/" unless substr($u,-1) eq "/";
 199             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
 200         }
 201     }
 202     \@urllist;
 203 }
 204
 205 #-> sub CPAN::FTP::ftp_get ;
 206 sub ftp_get {
 207     my($class,$host,$dir,$file,$target) = @_;
 208     $class->debug(
 209                   qq[Going to fetch file [$file] from dir [$dir]
 210         on host [$host] as local [$target]\n]
 211                  ) if $CPAN::DEBUG;
 212     my $ftp = Net::FTP->new($host);
 213     unless ($ftp) {
 214         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
 215         return;
 216     }
 217     return 0 unless defined $ftp;
 218     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
 219     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
 220     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
 221         my $msg = $ftp->message;
 222         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
 223         return;
 224     }
 225     unless ( $ftp->cwd($dir) ) {
 226         my $msg = $ftp->message;
 227         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
 228         return;
 229     }
 230     $ftp->binary;
 231     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
 232     unless ( $ftp->get($file,$target) ) {
 233         my $msg = $ftp->message;
 234         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
 235         return;
 236     }
 237     $ftp->quit; # it's ok if this fails
 238     return 1;
 239 }
 240
 241 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
 242
 243  # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
 244  # > --- /tmp/cp Wed Sep 24 13:26:40 1997
 245  # > ***************
 246  # > *** 1562,1567 ****
 247  # > --- 1562,1580 ----
 248  # >       return 1 if substr($url,0,4) eq "file";
 249  # >       return 1 unless $url =~ m|://([^/]+)|;
 250  # >       my $host = $1;
 251  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
 252  # > +     if ($proxy) {
 253  # > +         $proxy =~ m|://([^/:]+)|;
 254  # > +         $proxy = $1;
 255  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
 256  # > +         if ($noproxy) {
 257  # > +             if ($host !~ /$noproxy$/) {
 258  # > +                 $host = $proxy;
 259  # > +             }
 260  # > +         } else {
 261  # > +             $host = $proxy;
 262  # > +         }
 263  # > +     }
 264  # >       require Net::Ping;
 265  # >       return 1 unless $Net::Ping::VERSION >= 2;
 266  # >       my $p;
 267
 268
 269 #-> sub CPAN::FTP::localize ;
 270 sub localize {
 271     my($self,$file,$aslocal,$force) = @_;
 272     $force ||= 0;
 273     Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,$force])" )
 274         unless defined $aslocal;
 275     if ($CPAN::DEBUG){
 276         require Carp;
 277         my $longmess = Carp::longmess();
 278         $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
 279     }
 280     if ($^O eq 'MacOS') {
 281         # Comment by AK on 2000-09-03: Uniq short filenames would be
 282         # available in CHECKSUMS file
 283         my($name, $path) = File::Basename::fileparse($aslocal, '');
 284         if (length($name) > 31) {
 285             $name =~ s/(
 286                         \.(
 287                            readme(\.(gz|Z))? |
 288                            (tar\.)?(gz|Z) |
 289                            tgz |
 290                            zip |
 291                            pm\.(gz|Z)
 292                           )
 293                        )$//x;
 294             my $suf = $1;
 295             my $size = 31 - length($suf);
 296             while (length($name) > $size) {
 297                 chop $name;
 298             }
 299             $name .= $suf;
 300             $aslocal = File::Spec->catfile($path, $name);
 301         }
 302     }
 303
 304     if (-f $aslocal && -r _ && !($force & 1)) {
 305         my $size;
 306         if ($size = -s $aslocal) {
 307             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
 308             return $aslocal;
 309         } else {
 310             # empty file from a previous unsuccessful attempt to download it
 311             unlink $aslocal or
 312                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
 313                                        "could not remove.");
 314         }
 315     }
 316     my($maybe_restore) = 0;
 317     if (-f $aslocal) {
 318         rename $aslocal, "$aslocal.bak$$";
 319         $maybe_restore++;
 320     }
 321
 322     my($aslocal_dir) = dirname($aslocal);
 323     # Inheritance is not easier to manage than a few if/else branches
 324     if ($CPAN::META->has_usable('LWP::UserAgent')) {
 325         unless ($Ua) {
 326             CPAN::LWP::UserAgent->config;
 327             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
 328             if ($@) {
 329                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
 330                     if $CPAN::DEBUG;
 331             } else {
 332                 my($var);
 333                 $Ua->proxy('ftp',  $var)
 334                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
 335                 $Ua->proxy('http', $var)
 336                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
 337                 $Ua->no_proxy($var)
 338                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
 339             }
 340         }
 341     }
 342     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
 343         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
 344     }
 345
 346     # Try the list of urls for each single object. We keep a record
 347     # where we did get a file from
 348     my(@reordered,$last);
 349     my $ccurllist = $self->_get_urllist;
 350     $last = $#$ccurllist;
 351     if ($force & 2) { # local cpans probably out of date, don't reorder
 352         @reordered = (0..$last);
 353     } else {
 354         @reordered =
 355             sort {
 356                 (substr($ccurllist->[$b],0,4) eq "file")
 357                     <=>
 358                 (substr($ccurllist->[$a],0,4) eq "file")
 359                     or
 360                 defined($ThesiteURL)
 361                     and
 362                 ($ccurllist->[$b] eq $ThesiteURL)
 363                     <=>
 364                 ($ccurllist->[$a] eq $ThesiteURL)
 365             } 0..$last;
 366     }
 367     my(@levels);
 368     $Themethod ||= "";
 369     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
 370     my @all_levels = (
 371                       ["dleasy",   "file"],
 372                       ["dleasy"],
 373                       ["dlhard"],
 374                       ["dlhardest"],
 375                       ["dleasy",   "http","defaultsites"],
 376                       ["dlhard",   "http","defaultsites"],
 377                       ["dleasy",   "ftp", "defaultsites"],
 378                       ["dlhard",   "ftp", "defaultsites"],
 379                       ["dlhardest","",    "defaultsites"],
 380                      );
 381     if ($Themethod) {
 382         @levels = grep {$_->[0] eq $Themethod} @all_levels;
 383         push @levels, grep {$_->[0] ne $Themethod} @all_levels;
 384     } else {
 385         @levels = @all_levels;
 386     }
 387     @levels = qw/dleasy/ if $^O eq 'MacOS';
 388     my($levelno);
 389     local $ENV{FTP_PASSIVE} =
 390         exists $CPAN::Config->{ftp_passive} ?
 391         $CPAN::Config->{ftp_passive} : 1;
 392     my $ret;
 393     my $stats = $self->_new_stats($file);
 394     for ($CPAN::Config->{connect_to_internet_ok}) {
 395         $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
 396     }
 397   LEVEL: for $levelno (0..$#levels) {
 398         my $level_tuple = $levels[$levelno];
 399         my($level,$scheme,$sitetag) = @$level_tuple;
 400         $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
 401         my $defaultsites = $sitetag && $sitetag eq "defaultsites";
 402         my @urllist;
 403         if ($defaultsites) {
 404             unless (defined $connect_to_internet_ok) {
 405                 $CPAN::Frontend->myprint(sprintf qq{
 406 I would like to connect to one of the following sites to get '%s':
 407
 408 %s
 409 },
 410                                          $file,
 411                                          join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
 412                                         );
 413                 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
 414                 if ($answer =~ /^y/i) {
 415                     $connect_to_internet_ok = 1;
 416                 } else {
 417                     $connect_to_internet_ok = 0;
 418                 }
 419             }
 420             if ($connect_to_internet_ok) {
 421                 @urllist = @CPAN::Defaultsites;
 422             } else {
 423                 my $sleep = 2;
 424                 # the tricky thing about dying here is that everybody
 425                 # believes that calls to exists() or all_objects() are
 426                 # safe.
 427                 require CPAN::Exception::blocked_urllist;
 428                 die CPAN::Exception::blocked_urllist->new;
 429             }
 430         } else {
 431             my @host_seq = $level =~ /dleasy/ ?
 432                 @reordered : 0..$last;  # reordered has file and $Thesiteurl first
 433             @urllist = map { $ccurllist->[$_] } @host_seq;
 434         }
 435         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
 436         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
 437         if (my $recommend = $self->_recommend_url_for($file)) {
 438             @urllist = grep { $_ ne $recommend } @urllist;
 439             unshift @urllist, $recommend;
 440         }
 441         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
 442         $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
 443         if ($ret) {
 444             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
 445             if ($ret eq $aslocal_tempfile) {
 446                 # if we got it exactly as we asked for, only then we
 447                 # want to rename
 448                 rename $aslocal_tempfile, $aslocal
 449                     or $CPAN::Frontend->mydie("Error while trying to rename ".
 450                                               "'$ret' to '$aslocal': $!");
 451                 $ret = $aslocal;
 452             }
 453             $Themethod = $level;
 454             my $now = time;
 455             # utime $now, $now, $aslocal; # too bad, if we do that, we
 456                                           # might alter a local mirror
 457             $self->debug("level[$level]") if $CPAN::DEBUG;
 458             last LEVEL;
 459         } else {
 460             unlink $aslocal_tempfile;
 461             last if $CPAN::Signal; # need to cleanup
 462         }
 463     }
 464     if ($ret) {
 465         $stats->{filesize} = -s $ret;
 466     }
 467     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
 468     $self->_add_to_statistics($stats);
 469     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
 470     if ($ret) {
 471         unlink "$aslocal.bak$$";
 472         return $ret;
 473     }
 474     unless ($CPAN::Signal) {
 475         my(@mess);
 476         local $" = " ";
 477         if (@{$CPAN::Config->{urllist}}) {
 478             push @mess,
 479                 qq{Please check, if the URLs I found in your configuration file \(}.
 480                     join(", ", @{$CPAN::Config->{urllist}}).
 481                         qq{\) are valid.};
 482         } else {
 483             push @mess, qq{Your urllist is empty!};
 484         }
 485         push @mess, qq{The urllist can be edited.},
 486             qq{E.g. with 'o conf urllist push ftp://myurl/'};
 487         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
 488         $CPAN::Frontend->mydie("Could not fetch $file\n");
 489     }
 490     if ($maybe_restore) {
 491         rename "$aslocal.bak$$", $aslocal;
 492         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
 493                                  $self->ls($aslocal));
 494         return $aslocal;
 495     }
 496     return;
 497 }
 498
 499 sub mymkpath {
 500     my($self, $aslocal_dir) = @_;
 501     mkpath($aslocal_dir);
 502     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
 503                             qq{directory "$aslocal_dir".
 504     I\'ll continue, but if you encounter problems, they may be due
 505     to insufficient permissions.\n}) unless -w $aslocal_dir;
 506 }
 507
 508 sub hostdlxxx {
 509     my $self = shift;
 510     my $level = shift;
 511     my $scheme = shift;
 512     my $h = shift;
 513     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
 514     my $method = "host$level";
 515     $self->$method($h, @_);
 516 }
 517
 518 sub _set_attempt {
 519     my($self,$stats,$method,$url) = @_;
 520     push @{$stats->{attempts}}, {
 521                                  method => $method,
 522                                  start => _mytime,
 523                                  url => $url,
 524                                 };
 525 }
 526
 527 # package CPAN::FTP;
 528 sub hostdleasy { #called from hostdlxxx
 529     my($self,$host_seq,$file,$aslocal,$stats) = @_;
 530     my($ro_url);
 531   HOSTEASY: for $ro_url (@$host_seq) {
 532         $self->_set_attempt($stats,"dleasy",$ro_url);
 533         my $url .= "$ro_url$file";
 534         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
 535         if ($url =~ /^file:/) {
 536             my $l;
 537             if ($CPAN::META->has_inst('URI::URL')) {
 538                 my $u =  URI::URL->new($url);
 539                 $l = $u->path;
 540             } else { # works only on Unix, is poorly constructed, but
 541                 # hopefully better than nothing.
 542                 # RFC 1738 says fileurl BNF is
 543                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
 544                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
 545                 # the code
 546                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
 547                 $l =~ s|^file:||;                   # assume they
 548                                                     # meant
 549                                                     # file://localhost
 550                 $l =~ s|^/||s
 551                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
 552             }
 553             $self->debug("local file[$l]") if $CPAN::DEBUG;
 554             if ( -f $l && -r _) {
 555                 $ThesiteURL = $ro_url;
 556                 return $l;
 557             }
 558             if ($l =~ /(.+)\.gz$/) {
 559                 my $ungz = $1;
 560                 if ( -f $ungz && -r _) {
 561                     $ThesiteURL = $ro_url;
 562                     return $ungz;
 563                 }
 564             }
 565             # Maybe mirror has compressed it?
 566             if (-f "$l.gz") {
 567                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
 568                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
 569                 if ( -f $aslocal) {
 570                     $ThesiteURL = $ro_url;
 571                     return $aslocal;
 572                 }
 573             }
 574             $CPAN::Frontend->mywarn("Could not find '$l'\n");
 575         }
 576         $self->debug("it was not a file URL") if $CPAN::DEBUG;
 577         if ($CPAN::META->has_usable('LWP')) {
 578             $CPAN::Frontend->myprint("Fetching with LWP:
 579   $url
 580 ");
 581             unless ($Ua) {
 582                 CPAN::LWP::UserAgent->config;
 583                 eval { $Ua = CPAN::LWP::UserAgent->new; };
 584                 if ($@) {
 585                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
 586                 }
 587             }
 588             my $res = $Ua->mirror($url, $aslocal);
 589             if ($res->is_success) {
 590                 $ThesiteURL = $ro_url;
 591                 my $now = time;
 592                 utime $now, $now, $aslocal; # download time is more
 593                                             # important than upload
 594                                             # time
 595                 return $aslocal;
 596             } elsif ($url !~ /\.gz(?!\n)\Z/) {
 597                 my $gzurl = "$url.gz";
 598                 $CPAN::Frontend->myprint("Fetching with LWP:
 599   $gzurl
 600 ");
 601                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
 602                 if ($res->is_success) {
 603                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
 604                         $ThesiteURL = $ro_url;
 605                         return $aslocal;
 606                     }
 607                 }
 608             } else {
 609                 $CPAN::Frontend->myprint(sprintf(
 610                                                  "LWP failed with code[%s] message[%s]\n",
 611                                                  $res->code,
 612                                                  $res->message,
 613                                                 ));
 614                 # Alan Burlison informed me that in firewall environments
 615                 # Net::FTP can still succeed where LWP fails. So we do not
 616                 # skip Net::FTP anymore when LWP is available.
 617             }
 618         } else {
 619             $CPAN::Frontend->mywarn("  LWP not available\n");
 620         }
 621         return if $CPAN::Signal;
 622         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
 623             # that's the nice and easy way thanks to Graham
 624             $self->debug("recognized ftp") if $CPAN::DEBUG;
 625             my($host,$dir,$getfile) = ($1,$2,$3);
 626             if ($CPAN::META->has_usable('Net::FTP')) {
 627                 $dir =~ s|/+|/|g;
 628                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
 629   $url
 630 ");
 631                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
 632                              "aslocal[$aslocal]") if $CPAN::DEBUG;
 633                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
 634                     $ThesiteURL = $ro_url;
 635                     return $aslocal;
 636                 }
 637                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
 638                     my $gz = "$aslocal.gz";
 639                     $CPAN::Frontend->myprint("Fetching with Net::FTP
 640   $url.gz
 641 ");
 642                     if (CPAN::FTP->ftp_get($host,
 643                                            $dir,
 644                                            "$getfile.gz",
 645                                            $gz) &&
 646                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
 647                     ) {
 648                         $ThesiteURL = $ro_url;
 649                         return $aslocal;
 650                     }
 651                 }
 652                 # next HOSTEASY;
 653             } else {
 654                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
 655             }
 656         }
 657         if (
 658             UNIVERSAL::can($ro_url,"text")
 659             and
 660             $ro_url->{FROM} eq "USER"
 661            ) {
 662             ##address #17973: default URLs should not try to override
 663             ##user-defined URLs just because LWP is not available
 664             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
 665             return $ret if $ret;
 666         }
 667         return if $CPAN::Signal;
 668     }
 669 }
 670
 671 # package CPAN::FTP;
 672 sub hostdlhard {
 673     my($self,$host_seq,$file,$aslocal,$stats) = @_;
 674
 675     # Came back if Net::FTP couldn't establish connection (or
 676     # failed otherwise) Maybe they are behind a firewall, but they
 677     # gave us a socksified (or other) ftp program...
 678
 679     my($ro_url);
 680     my($devnull) = $CPAN::Config->{devnull} || "";
 681     # < /dev/null ";
 682     my($aslocal_dir) = dirname($aslocal);
 683     mkpath($aslocal_dir);
 684     my $some_dl_success = 0;
 685  HOSTHARD: for $ro_url (@$host_seq) {
 686         $self->_set_attempt($stats,"dlhard",$ro_url);
 687         my $url = "$ro_url$file";
 688         my($proto,$host,$dir,$getfile);
 689
 690         # Courtesy Mark Conty mark_conty@cargill.com change from
 691         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
 692         # to
 693         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
 694             # proto not yet used
 695             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
 696         } else {
 697             next HOSTHARD; # who said, we could ftp anything except ftp?
 698         }
 699         next HOSTHARD if $proto eq "file"; # file URLs would have had
 700                                            # success above. Likely a bogus URL
 701
 702         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
 703
 704         # Try the most capable first and leave ncftp* for last as it only
 705         # does FTP.
 706         my $proxy_vars = $self->_proxy_vars($ro_url);
 707       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
 708             my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
 709             next DLPRG unless defined $funkyftp;
 710             next DLPRG if $funkyftp =~ /^\s*$/;
 711
 712             my($asl_ungz, $asl_gz);
 713             ($asl_ungz = $aslocal) =~ s/\.gz//;
 714                 $asl_gz = "$asl_ungz.gz";
 715
 716             my($src_switch) = "";
 717             my($chdir) = "";
 718             my($stdout_redir) = " > $asl_ungz";
 719             if ($f eq "lynx") {
 720                 $src_switch = " -source";
 721             } elsif ($f eq "ncftp") {
 722                 $src_switch = " -c";
 723             } elsif ($f eq "wget") {
 724                 $src_switch = " -O $asl_ungz";
 725                 $stdout_redir = "";
 726             } elsif ($f eq 'curl') {
 727                 $src_switch = ' -L -f -s -S --netrc-optional';
 728                 if ($proxy_vars->{http_proxy}) {
 729                     $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
 730                 }
 731             }
 732
 733             if ($f eq "ncftpget") {
 734                 $chdir = "cd $aslocal_dir && ";
 735                 $stdout_redir = "";
 736             }
 737             $CPAN::Frontend->myprint(
 738                                      qq[
 739 Trying with "$funkyftp$src_switch" to get
 740     "$url"
 741 ]);
 742             my($system) =
 743                 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
 744             $self->debug("system[$system]") if $CPAN::DEBUG;
 745             my($wstatus) = system($system);
 746             if ($f eq "lynx") {
 747                 # lynx returns 0 when it fails somewhere
 748                 if (-s $asl_ungz) {
 749                     my $content = do { local *FH;
 750                                        open FH, $asl_ungz or die;
 751                                        local $/;
 752                                        <FH> };
 753                     if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
 754                         $CPAN::Frontend->mywarn(qq{
 755 No success, the file that lynx has downloaded looks like an error message:
 756 $content
 757 });
 758                         $CPAN::Frontend->mysleep(1);
 759                         next DLPRG;
 760                     }
 761                     $some_dl_success++;
 762                 } else {
 763                     $CPAN::Frontend->myprint(qq{
 764 No success, the file that lynx has downloaded is an empty file.
 765 });
 766                     next DLPRG;
 767                 }
 768             }
 769             if ($wstatus == 0) {
 770                 if (-s $aslocal) {
 771                     # Looks good
 772                     $some_dl_success++;
 773                 } elsif ($asl_ungz ne $aslocal) {
 774                     # test gzip integrity
 775                     if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
 776                         # e.g. foo.tar is gzipped --> foo.tar.gz
 777                         rename $asl_ungz, $aslocal;
 778                         $some_dl_success++;
 779                     } else {
 780                         eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
 781                         if ($@) {
 782                             warn "Warning: $@";
 783                         } else {
 784                             $some_dl_success++;
 785                         }
 786                     }
 787                 }
 788                 $ThesiteURL = $ro_url;
 789                 return $aslocal;
 790             } elsif ($url !~ /\.gz(?!\n)\Z/) {
 791                 unlink $asl_ungz if
 792                     -f $asl_ungz && -s _ == 0;
 793                 my $gz = "$aslocal.gz";
 794                 my $gzurl = "$url.gz";
 795                 $CPAN::Frontend->myprint(
 796                                         qq[
 797     Trying with "$funkyftp$src_switch" to get
 798     "$url.gz"
 799     ]);
 800                 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
 801                 $self->debug("system[$system]") if $CPAN::DEBUG;
 802                 my($wstatus);
 803                 if (($wstatus = system($system)) == 0
 804                     &&
 805                     -s $asl_gz
 806                 ) {
 807                     # test gzip integrity
 808                     my $ct = eval{CPAN::Tarzip->new($asl_gz)};
 809                     if ($ct && $ct->gtest) {
 810                         $ct->gunzip($aslocal);
 811                     } else {
 812                         # somebody uncompressed file for us?
 813                         rename $asl_ungz, $aslocal;
 814                     }
 815                     $ThesiteURL = $ro_url;
 816                     return $aslocal;
 817                 } else {
 818                     unlink $asl_gz if -f $asl_gz;
 819                 }
 820             } else {
 821                 my $estatus = $wstatus >> 8;
 822                 my $size = -f $aslocal ?
 823                     ", left\n$aslocal with size ".-s _ :
 824                     "\nWarning: expected file [$aslocal] doesn't exist";
 825                 $CPAN::Frontend->myprint(qq{
 826     Function system("$system")
 827     returned status $estatus (wstat $wstatus)$size
 828     });
 829             }
 830             return if $CPAN::Signal;
 831         } # download/transfer programs (DLPRG)
 832     } # host
 833     require Carp;
 834     if ($some_dl_success) {
 835         Carp::cluck("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.");
 836     } else {
 837         Carp::cluck("Warning: no success downloading '$aslocal'. Giving up on it.");
 838     }
 839     $CPAN::Frontend->mysleep(5);
 840     return;
 841 }
 842
 843 #-> CPAN::FTP::_proxy_vars
 844 sub _proxy_vars {
 845     my($self,$url) = @_;
 846     my $ret = +{};
 847     my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
 848     if ($http_proxy) {
 849         my($host) = $url =~ m|://([^/:]+)|;
 850         my $want_proxy = 1;
 851         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
 852         my @noproxy = split /\s*,\s*/, $noproxy;
 853         if ($host) {
 854           DOMAIN: for my $domain (@noproxy) {
 855                 if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
 856                     $want_proxy = 0;
 857                     last DOMAIN;
 858                 }
 859             }
 860         } else {
 861             $CPAN::Frontend->mywarn("  Could not determine host from http_proxy '$http_proxy'\n");
 862         }
 863         if ($want_proxy) {
 864             my($user, $pass) =
 865                 &CPAN::LWP::UserAgent::get_proxy_credentials();
 866             $ret = {
 867                     proxy_user => $user,
 868                     proxy_pass => $pass,
 869                     http_proxy => $http_proxy
 870                   };
 871         }
 872     }
 873     return $ret;
 874 }
 875
 876 # package CPAN::FTP;
 877 sub hostdlhardest {
 878     my($self,$host_seq,$file,$aslocal,$stats) = @_;
 879
 880     return unless @$host_seq;
 881     my($ro_url);
 882     my($aslocal_dir) = dirname($aslocal);
 883     mkpath($aslocal_dir);
 884     my $ftpbin = $CPAN::Config->{ftp};
 885     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
 886         $CPAN::Frontend->myprint("No external ftp command available\n\n");
 887         return;
 888     }
 889     $CPAN::Frontend->mywarn(qq{
 890 As a last resort we now switch to the external ftp command '$ftpbin'
 891 to get '$aslocal'.
 892
 893 Doing so often leads to problems that are hard to diagnose.
 894
 895 If you're the victim of such problems, please consider unsetting the
 896 ftp config variable with
 897
 898     o conf ftp ""
 899     o conf commit
 900
 901 });
 902     $CPAN::Frontend->mysleep(2);
 903   HOSTHARDEST: for $ro_url (@$host_seq) {
 904         $self->_set_attempt($stats,"dlhardest",$ro_url);
 905         my $url = "$ro_url$file";
 906         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
 907         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
 908             next;
 909         }
 910         my($host,$dir,$getfile) = ($1,$2,$3);
 911         my $timestamp = 0;
 912         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
 913             $ctime,$blksize,$blocks) = stat($aslocal);
 914         $timestamp = $mtime ||= 0;
 915         my($netrc) = CPAN::FTP::netrc->new;
 916         my($netrcfile) = $netrc->netrc;
 917         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
 918         my $targetfile = File::Basename::basename($aslocal);
 919         my(@dialog);
 920         push(
 921              @dialog,
 922              "lcd $aslocal_dir",
 923              "cd /",
 924              map("cd $_", split /\//, $dir), # RFC 1738
 925              "bin",
 926              "get $getfile $targetfile",
 927              "quit"
 928         );
 929         if (! $netrcfile) {
 930             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
 931         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
 932             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
 933                                 $netrc->hasdefault,
 934                                 $netrc->contains($host))) if $CPAN::DEBUG;
 935             if ($netrc->protected) {
 936                 my $dialog = join "", map { "    $_\n" } @dialog;
 937                 my $netrc_explain;
 938                 if ($netrc->contains($host)) {
 939                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
 940                         "manages the login";
 941                 } else {
 942                     $netrc_explain = "Relying that your default .netrc entry ".
 943                         "manages the login";
 944                 }
 945                 $CPAN::Frontend->myprint(qq{
 946   Trying with external ftp to get
 947     '$url'
 948   $netrc_explain
 949   Going to send the dialog
 950 $dialog
 951 }
 952                 );
 953                 $self->talk_ftp("$ftpbin$verbose $host",
 954                                 @dialog);
 955                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 956                     $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
 957                 $mtime ||= 0;
 958                 if ($mtime > $timestamp) {
 959                     $CPAN::Frontend->myprint("GOT $aslocal\n");
 960                     $ThesiteURL = $ro_url;
 961                     return $aslocal;
 962                 } else {
 963                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
 964                 }
 965                     return if $CPAN::Signal;
 966             } else {
 967                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
 968                                         qq{correctly protected.\n});
 969             }
 970         } else {
 971             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
 972   nor does it have a default entry\n");
 973         }
 974
 975         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
 976         # then and login manually to host, using e-mail as
 977         # password.
 978         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
 979         unshift(
 980                 @dialog,
 981                 "open $host",
 982                 "user anonymous $Config::Config{'cf_email'}"
 983         );
 984         my $dialog = join "", map { "    $_\n" } @dialog;
 985         $CPAN::Frontend->myprint(qq{
 986   Trying with external ftp to get
 987     $url
 988   Going to send the dialog
 989 $dialog
 990 }
 991         );
 992         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
 993         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 994             $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
 995         $mtime ||= 0;
 996         if ($mtime > $timestamp) {
 997             $CPAN::Frontend->myprint("GOT $aslocal\n");
 998             $ThesiteURL = $ro_url;
 999             return $aslocal;
1000         } else {
1001             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
1002         }
1003         return if $CPAN::Signal;
1004         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
1005         $CPAN::Frontend->mysleep(2);
1006     } # host
1007 }
1008
1009 # package CPAN::FTP;
1010 sub talk_ftp {
1011     my($self,$command,@dialog) = @_;
1012     my $fh = FileHandle->new;
1013     $fh->open("|$command") or die "Couldn't open ftp: $!";
1014     foreach (@dialog) { $fh->print("$_\n") }
1015     $fh->close; # Wait for process to complete
1016     my $wstatus = $?;
1017     my $estatus = $wstatus >> 8;
1018     $CPAN::Frontend->myprint(qq{
1019 Subprocess "|$command"
1020   returned status $estatus (wstat $wstatus)
1021 }) if $wstatus;
1022 }
1023
1024 # find2perl needs modularization, too, all the following is stolen
1025 # from there
1026 # CPAN::FTP::ls
1027 sub ls {
1028     my($self,$name) = @_;
1029     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
1030      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
1031
1032     my($perms,%user,%group);
1033     my $pname = $name;
1034
1035     if ($blocks) {
1036         $blocks = int(($blocks + 1) / 2);
1037     }
1038     else {
1039         $blocks = int(($sizemm + 1023) / 1024);
1040     }
1041
1042     if    (-f _) { $perms = '-'; }
1043     elsif (-d _) { $perms = 'd'; }
1044     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
1045     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
1046     elsif (-p _) { $perms = 'p'; }
1047     elsif (-S _) { $perms = 's'; }
1048     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
1049
1050     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
1051     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
1052     my $tmpmode = $mode;
1053     my $tmp = $rwx[$tmpmode & 7];
1054     $tmpmode >>= 3;
1055     $tmp = $rwx[$tmpmode & 7] . $tmp;
1056     $tmpmode >>= 3;
1057     $tmp = $rwx[$tmpmode & 7] . $tmp;
1058     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
1059     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
1060     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
1061     $perms .= $tmp;
1062
1063     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
1064     my $group = $group{$gid} || $gid;
1065
1066     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
1067     my($timeyear);
1068     my($moname) = $moname[$mon];
1069     if (-M _ > 365.25 / 2) {
1070         $timeyear = $year + 1900;
1071     }
1072     else {
1073         $timeyear = sprintf("%02d:%02d", $hour, $min);
1074     }
1075
1076     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
1077              $ino,
1078                   $blocks,
1079                        $perms,
1080                              $nlink,
1081                                  $user,
1082                                       $group,
1083                                            $sizemm,
1084                                                $moname,
1085                                                   $mday,
1086                                                       $timeyear,
1087                                                           $pname;
1088 }
1089
1090 1;