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