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