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->mywarn("Could not fetch $file\n");
 489         $CPAN::Frontend->mysleep(2);
 490     }
 491     if ($maybe_restore) {
 492         rename "$aslocal.bak$$", $aslocal;
 493         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
 494                                  $self->ls($aslocal));
 495         return $aslocal;
 496     }
 497     return;
 498 }
 499
 500 sub mymkpath {
 501     my($self, $aslocal_dir) = @_;
 502     mkpath($aslocal_dir);
 503     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
 504                             qq{directory "$aslocal_dir".
 505     I\'ll continue, but if you encounter problems, they may be due
 506     to insufficient permissions.\n}) unless -w $aslocal_dir;
 507 }
 508
 509 sub hostdlxxx {
 510     my $self = shift;
 511     my $level = shift;
 512     my $scheme = shift;
 513     my $h = shift;
 514     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
 515     my $method = "host$level";
 516     $self->$method($h, @_);
 517 }
 518
 519 sub _set_attempt {
 520     my($self,$stats,$method,$url) = @_;
 521     push @{$stats->{attempts}}, {
 522                                  method => $method,
 523                                  start => _mytime,
 524                                  url => $url,
 525                                 };
 526 }
 527
 528 # package CPAN::FTP;
 529 sub hostdleasy {
 530     my($self,$host_seq,$file,$aslocal,$stats) = @_;
 531     my($ro_url);
 532   HOSTEASY: for $ro_url (@$host_seq) {
 533         $self->_set_attempt($stats,"dleasy",$ro_url);
 534         my $url .= "$ro_url$file";
 535         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
 536         if ($url =~ /^file:/) {
 537             my $l;
 538             if ($CPAN::META->has_inst('URI::URL')) {
 539                 my $u =  URI::URL->new($url);
 540                 $l = $u->path;
 541             } else { # works only on Unix, is poorly constructed, but
 542                 # hopefully better than nothing.
 543                 # RFC 1738 says fileurl BNF is
 544                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
 545                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
 546                 # the code
 547                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
 548                 $l =~ s|^file:||;                   # assume they
 549                                                     # meant
 550                                                     # file://localhost
 551                 $l =~ s|^/||s
 552                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
 553             }
 554             $self->debug("local file[$l]") if $CPAN::DEBUG;
 555             if ( -f $l && -r _) {
 556                 $ThesiteURL = $ro_url;
 557                 return $l;
 558             }
 559             if ($l =~ /(.+)\.gz$/) {
 560                 my $ungz = $1;
 561                 if ( -f $ungz && -r _) {
 562                     $ThesiteURL = $ro_url;
 563                     return $ungz;
 564                 }
 565             }
 566             # Maybe mirror has compressed it?
 567             if (-f "$l.gz") {
 568                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
 569                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
 570                 if ( -f $aslocal) {
 571                     $ThesiteURL = $ro_url;
 572                     return $aslocal;
 573                 }
 574             }
 575             $CPAN::Frontend->mywarn("Could not find '$l'\n");
 576         }
 577         $self->debug("it was not a file URL") if $CPAN::DEBUG;
 578         if ($CPAN::META->has_usable('LWP')) {
 579             $CPAN::Frontend->myprint("Fetching with LWP:
 580   $url
 581 ");
 582             unless ($Ua) {
 583                 CPAN::LWP::UserAgent->config;
 584                 eval { $Ua = CPAN::LWP::UserAgent->new; };
 585                 if ($@) {
 586                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
 587                 }
 588             }
 589             my $res = $Ua->mirror($url, $aslocal);
 590             if ($res->is_success) {
 591                 $ThesiteURL = $ro_url;
 592                 my $now = time;
 593                 utime $now, $now, $aslocal; # download time is more
 594                                             # important than upload
 595                                             # time
 596                 return $aslocal;
 597             } elsif ($url !~ /\.gz(?!\n)\Z/) {
 598                 my $gzurl = "$url.gz";
 599                 $CPAN::Frontend->myprint("Fetching with LWP:
 600   $gzurl
 601 ");
 602                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
 603                 if ($res->is_success) {
 604                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
 605                         $ThesiteURL = $ro_url;
 606                         return $aslocal;
 607                     }
 608                 }
 609             } else {
 610                 $CPAN::Frontend->myprint(sprintf(
 611                                                  "LWP failed with code[%s] message[%s]\n",
 612                                                  $res->code,
 613                                                  $res->message,
 614                                                 ));
 615                 # Alan Burlison informed me that in firewall environments
 616                 # Net::FTP can still succeed where LWP fails. So we do not
 617                 # skip Net::FTP anymore when LWP is available.
 618             }
 619         } else {
 620             $CPAN::Frontend->mywarn("  LWP not available\n");
 621         }
 622         return if $CPAN::Signal;
 623         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
 624             # that's the nice and easy way thanks to Graham
 625             $self->debug("recognized ftp") if $CPAN::DEBUG;
 626             my($host,$dir,$getfile) = ($1,$2,$3);
 627             if ($CPAN::META->has_usable('Net::FTP')) {
 628                 $dir =~ s|/+|/|g;
 629                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
 630   $url
 631 ");
 632                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
 633                              "aslocal[$aslocal]") if $CPAN::DEBUG;
 634                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
 635                     $ThesiteURL = $ro_url;
 636                     return $aslocal;
 637                 }
 638                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
 639                     my $gz = "$aslocal.gz";
 640                     $CPAN::Frontend->myprint("Fetching with Net::FTP
 641   $url.gz
 642 ");
 643                     if (CPAN::FTP->ftp_get($host,
 644                                            $dir,
 645                                            "$getfile.gz",
 646                                            $gz) &&
 647                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
 648                     ) {
 649                         $ThesiteURL = $ro_url;
 650                         return $aslocal;
 651                     }
 652                 }
 653                 # next HOSTEASY;
 654             } else {
 655                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
 656             }
 657         }
 658         if (
 659             UNIVERSAL::can($ro_url,"text")
 660             and
 661             $ro_url->{FROM} eq "USER"
 662            ) {
 663             ##address #17973: default URLs should not try to override
 664             ##user-defined URLs just because LWP is not available
 665             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
 666             return $ret if $ret;
 667         }
 668         return if $CPAN::Signal;
 669     }
 670 }
 671
 672 # package CPAN::FTP;
 673 sub hostdlhard {
 674     my($self,$host_seq,$file,$aslocal,$stats) = @_;
 675
 676     # Came back if Net::FTP couldn't establish connection (or
 677     # failed otherwise) Maybe they are behind a firewall, but they
 678     # gave us a socksified (or other) ftp program...
 679
 680     my($ro_url);
 681     my($devnull) = $CPAN::Config->{devnull} || "";
 682     # < /dev/null ";
 683     my($aslocal_dir) = dirname($aslocal);
 684     mkpath($aslocal_dir);
 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 unless defined $funkyftp;
 710             next 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                 } else {
 762                     $CPAN::Frontend->myprint(qq{
 763 No success, the file that lynx has downloaded is an empty file.
 764 });
 765                     next DLPRG;
 766                 }
 767             }
 768             if ($wstatus == 0) {
 769                 if (-s $aslocal) {
 770                     # Looks good
 771                 } elsif ($asl_ungz ne $aslocal) {
 772                     # test gzip integrity
 773                     if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
 774                         # e.g. foo.tar is gzipped --> foo.tar.gz
 775                         rename $asl_ungz, $aslocal;
 776                     } else {
 777                         eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
 778                     }
 779                 }
 780                 $ThesiteURL = $ro_url;
 781                 return $aslocal;
 782             } elsif ($url !~ /\.gz(?!\n)\Z/) {
 783                 unlink $asl_ungz if
 784                     -f $asl_ungz && -s _ == 0;
 785                 my $gz = "$aslocal.gz";
 786                 my $gzurl = "$url.gz";
 787                 $CPAN::Frontend->myprint(
 788                                         qq[
 789     Trying with "$funkyftp$src_switch" to get
 790     "$url.gz"
 791     ]);
 792                 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
 793                 $self->debug("system[$system]") if $CPAN::DEBUG;
 794                 my($wstatus);
 795                 if (($wstatus = system($system)) == 0
 796                     &&
 797                     -s $asl_gz
 798                 ) {
 799                     # test gzip integrity
 800                     my $ct = eval{CPAN::Tarzip->new($asl_gz)};
 801                     if ($ct && $ct->gtest) {
 802                         $ct->gunzip($aslocal);
 803                     } else {
 804                         # somebody uncompressed file for us?
 805                         rename $asl_ungz, $aslocal;
 806                     }
 807                     $ThesiteURL = $ro_url;
 808                     return $aslocal;
 809                 } else {
 810                     unlink $asl_gz if -f $asl_gz;
 811                 }
 812             } else {
 813                 my $estatus = $wstatus >> 8;
 814                 my $size = -f $aslocal ?
 815                     ", left\n$aslocal with size ".-s _ :
 816                     "\nWarning: expected file [$aslocal] doesn't exist";
 817                 $CPAN::Frontend->myprint(qq{
 818     Function system("$system")
 819     returned status $estatus (wstat $wstatus)$size
 820     });
 821             }
 822             return if $CPAN::Signal;
 823         } # transfer programs
 824     } # host
 825 }
 826
 827 #-> CPAN::FTP::_proxy_vars
 828 sub _proxy_vars {
 829     my($self,$url) = @_;
 830     my $ret = +{};
 831     my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
 832     if ($http_proxy) {
 833         my($host) = $url =~ m|://([^/:]+)|;
 834         my $want_proxy = 1;
 835         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
 836         my @noproxy = split /\s*,\s*/, $noproxy;
 837         if ($host) {
 838           DOMAIN: for my $domain (@noproxy) {
 839                 if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
 840                     $want_proxy = 0;
 841                     last DOMAIN;
 842                 }
 843             }
 844         } else {
 845             $CPAN::Frontend->mywarn("  Could not determine host from http_proxy '$http_proxy'\n");
 846         }
 847         if ($want_proxy) {
 848             my($user, $pass) =
 849                 &CPAN::LWP::UserAgent::get_proxy_credentials();
 850             $ret = {
 851                     proxy_user => $user,
 852                     proxy_pass => $pass,
 853                     http_proxy => $http_proxy
 854                   };
 855         }
 856     }
 857     return $ret;
 858 }
 859
 860 # package CPAN::FTP;
 861 sub hostdlhardest {
 862     my($self,$host_seq,$file,$aslocal,$stats) = @_;
 863
 864     return unless @$host_seq;
 865     my($ro_url);
 866     my($aslocal_dir) = dirname($aslocal);
 867     mkpath($aslocal_dir);
 868     my $ftpbin = $CPAN::Config->{ftp};
 869     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
 870         $CPAN::Frontend->myprint("No external ftp command available\n\n");
 871         return;
 872     }
 873     $CPAN::Frontend->mywarn(qq{
 874 As a last ressort we now switch to the external ftp command '$ftpbin'
 875 to get '$aslocal'.
 876
 877 Doing so often leads to problems that are hard to diagnose.
 878
 879 If you're the victim of such problems, please consider unsetting the
 880 ftp config variable with
 881
 882     o conf ftp ""
 883     o conf commit
 884
 885 });
 886     $CPAN::Frontend->mysleep(2);
 887   HOSTHARDEST: for $ro_url (@$host_seq) {
 888         $self->_set_attempt($stats,"dlhardest",$ro_url);
 889         my $url = "$ro_url$file";
 890         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
 891         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
 892             next;
 893         }
 894         my($host,$dir,$getfile) = ($1,$2,$3);
 895         my $timestamp = 0;
 896         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
 897             $ctime,$blksize,$blocks) = stat($aslocal);
 898         $timestamp = $mtime ||= 0;
 899         my($netrc) = CPAN::FTP::netrc->new;
 900         my($netrcfile) = $netrc->netrc;
 901         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
 902         my $targetfile = File::Basename::basename($aslocal);
 903         my(@dialog);
 904         push(
 905              @dialog,
 906              "lcd $aslocal_dir",
 907              "cd /",
 908              map("cd $_", split /\//, $dir), # RFC 1738
 909              "bin",
 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;