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