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