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