1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 # vim: ts=4 sts=4 sw=4:
7 use File::Basename qw(dirname);
8 use File::Path qw(mkpath);
10 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
11 @CPAN::FTP::ISA = qw(CPAN::Debug);
18 #-> sub CPAN::FTP::ftp_statistics
19 # if they want to rewrite, they need to pass in a filehandle
22 my $locktype = $fh ? LOCK_EX : LOCK_SH;
23 $fh ||= FileHandle->new;
24 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
26 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
29 while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
30 $waitstart ||= localtime();
32 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
34 $CPAN::Frontend->mysleep($sleep);
37 } elsif ($sleep <=6) {
41 my $stats = eval { CPAN->_yaml_loadfile($file); };
44 if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
45 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
47 } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
48 $CPAN::Frontend->mydie($@);
51 $CPAN::Frontend->mydie($@);
57 #-> sub CPAN::FTP::_mytime
59 if (CPAN->has_inst("Time::HiRes")) {
60 return Time::HiRes::time();
66 #-> sub CPAN::FTP::_new_stats
77 #-> sub CPAN::FTP::_add_to_statistics
78 sub _add_to_statistics {
79 my($self,$stats) = @_;
80 my $yaml_module = CPAN::_yaml_module();
81 $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
82 if ($CPAN::META->has_inst($yaml_module)) {
83 $stats->{thesiteurl} = $ThesiteURL;
84 $stats->{end} = CPAN::FTP::_mytime();
85 my $fh = FileHandle->new;
89 @debug = $time if $sdebug;
90 my $fullstats = $self->_ftp_statistics($fh);
92 $fullstats->{history} ||= [];
93 push @debug, scalar @{$fullstats->{history}} if $sdebug;
94 push @debug, time if $sdebug;
95 push @{$fullstats->{history}}, $stats;
96 # YAML.pm 0.62 is unacceptably slow with 999;
97 # YAML::Syck 0.82 has no noticable performance problem with 999;
98 my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
99 my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
101 @{$fullstats->{history}} > $ftpstats_size
102 || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
104 shift @{$fullstats->{history}}
106 push @debug, scalar @{$fullstats->{history}} if $sdebug;
107 push @debug, time if $sdebug;
108 push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
109 # need no eval because if this fails, it is serious
110 my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
111 CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
113 local $CPAN::DEBUG = 512; # FTP
115 CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
116 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
120 # Win32 cannot rename a file to an existing filename
121 unlink($sfile) if ($^O eq 'MSWin32');
122 _copy_stat($sfile, "$sfile.$$") if -e $sfile;
123 rename "$sfile.$$", $sfile
124 or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
128 # Copy some stat information (owner, group, mode and) from one file to
130 # This is a utility function which might be moved to a utility repository.
131 #-> sub CPAN::FTP::_copy_stat
133 my($src, $dest) = @_;
134 my @stat = stat($src);
136 $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
141 chmod $stat[2], $dest
142 or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
146 chown $stat[4], $stat[5], $dest
148 my $save_err = $!; # otherwise it's lost in the get... calls
149 $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
150 (getpwuid($stat[4]))[0] . "/" .
151 (getgrgid($stat[5]))[0] . ": $save_err\n"
158 # if file is CHECKSUMS, suggest the place where we got the file to be
159 # checked from, maybe only for young files?
160 #-> sub CPAN::FTP::_recommend_url_for
161 sub _recommend_url_for {
162 my($self, $file) = @_;
163 my $urllist = $self->_get_urllist;
164 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
165 my $fullstats = $self->_ftp_statistics();
166 my $history = $fullstats->{history} || [];
167 while (my $last = pop @$history) {
168 last if $last->{end} - time > 3600; # only young results are interesting
169 next unless $last->{file}; # dirname of nothing dies!
170 next unless $file eq dirname($last->{file});
171 return $last->{thesiteurl};
174 if ($CPAN::Config->{randomize_urllist}
176 rand(1) < $CPAN::Config->{randomize_urllist}
178 $urllist->[int rand scalar @$urllist];
184 #-> sub CPAN::FTP::_get_urllist
187 $CPAN::Config->{urllist} ||= [];
188 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
189 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
190 $CPAN::Config->{urllist} = [];
192 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
193 for my $u (@urllist) {
194 CPAN->debug("u[$u]") if $CPAN::DEBUG;
195 if (UNIVERSAL::can($u,"text")) {
196 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
198 $u .= "/" unless substr($u,-1) eq "/";
199 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
205 #-> sub CPAN::FTP::ftp_get ;
207 my($class,$host,$dir,$file,$target) = @_;
209 qq[Going to fetch file [$file] from dir [$dir]
210 on host [$host] as local [$target]\n]
212 my $ftp = Net::FTP->new($host);
214 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
217 return 0 unless defined $ftp;
218 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
219 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
220 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
221 my $msg = $ftp->message;
222 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
225 unless ( $ftp->cwd($dir) ) {
226 my $msg = $ftp->message;
227 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
231 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
232 unless ( $ftp->get($file,$target) ) {
233 my $msg = $ftp->message;
234 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
237 $ftp->quit; # it's ok if this fails
241 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
243 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
244 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
246 # > *** 1562,1567 ****
247 # > --- 1562,1580 ----
248 # > return 1 if substr($url,0,4) eq "file";
249 # > return 1 unless $url =~ m|://([^/]+)|;
251 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
253 # > + $proxy =~ m|://([^/:]+)|;
255 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
256 # > + if ($noproxy) {
257 # > + if ($host !~ /$noproxy$/) {
258 # > + $host = $proxy;
261 # > + $host = $proxy;
264 # > require Net::Ping;
265 # > return 1 unless $Net::Ping::VERSION >= 2;
269 #-> sub CPAN::FTP::localize ;
271 my($self,$file,$aslocal,$force) = @_;
273 Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,$force])" )
274 unless defined $aslocal;
277 my $longmess = Carp::longmess();
278 $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
280 if ($^O eq 'MacOS') {
281 # Comment by AK on 2000-09-03: Uniq short filenames would be
282 # available in CHECKSUMS file
283 my($name, $path) = File::Basename::fileparse($aslocal, '');
284 if (length($name) > 31) {
295 my $size = 31 - length($suf);
296 while (length($name) > $size) {
300 $aslocal = File::Spec->catfile($path, $name);
304 if (-f $aslocal && -r _ && !($force & 1)) {
306 if ($size = -s $aslocal) {
307 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
310 # empty file from a previous unsuccessful attempt to download it
312 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
313 "could not remove.");
316 my($maybe_restore) = 0;
318 rename $aslocal, "$aslocal.bak$$";
322 my($aslocal_dir) = dirname($aslocal);
323 # Inheritance is not easier to manage than a few if/else branches
324 if ($CPAN::META->has_usable('LWP::UserAgent')) {
326 CPAN::LWP::UserAgent->config;
327 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
329 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
333 $Ua->proxy('ftp', $var)
334 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
335 $Ua->proxy('http', $var)
336 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
338 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
342 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
343 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
346 # Try the list of urls for each single object. We keep a record
347 # where we did get a file from
348 my(@reordered,$last);
349 my $ccurllist = $self->_get_urllist;
350 $last = $#$ccurllist;
351 if ($force & 2) { # local cpans probably out of date, don't reorder
352 @reordered = (0..$last);
356 (substr($ccurllist->[$b],0,4) eq "file")
358 (substr($ccurllist->[$a],0,4) eq "file")
362 ($ccurllist->[$b] eq $ThesiteURL)
364 ($ccurllist->[$a] eq $ThesiteURL)
369 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
375 ["dleasy", "http","defaultsites"],
376 ["dlhard", "http","defaultsites"],
377 ["dleasy", "ftp", "defaultsites"],
378 ["dlhard", "ftp", "defaultsites"],
379 ["dlhardest","", "defaultsites"],
382 @levels = grep {$_->[0] eq $Themethod} @all_levels;
383 push @levels, grep {$_->[0] ne $Themethod} @all_levels;
385 @levels = @all_levels;
387 @levels = qw/dleasy/ if $^O eq 'MacOS';
389 local $ENV{FTP_PASSIVE} =
390 exists $CPAN::Config->{ftp_passive} ?
391 $CPAN::Config->{ftp_passive} : 1;
393 my $stats = $self->_new_stats($file);
394 for ($CPAN::Config->{connect_to_internet_ok}) {
395 $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
397 LEVEL: for $levelno (0..$#levels) {
398 my $level_tuple = $levels[$levelno];
399 my($level,$scheme,$sitetag) = @$level_tuple;
400 $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
401 my $defaultsites = $sitetag && $sitetag eq "defaultsites";
404 unless (defined $connect_to_internet_ok) {
405 $CPAN::Frontend->myprint(sprintf qq{
406 I would like to connect to one of the following sites to get '%s':
411 join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
413 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
414 if ($answer =~ /^y/i) {
415 $connect_to_internet_ok = 1;
417 $connect_to_internet_ok = 0;
420 if ($connect_to_internet_ok) {
421 @urllist = @CPAN::Defaultsites;
424 # the tricky thing about dying here is that everybody
425 # believes that calls to exists() or all_objects() are
427 require CPAN::Exception::blocked_urllist;
428 die CPAN::Exception::blocked_urllist->new;
431 my @host_seq = $level =~ /dleasy/ ?
432 @reordered : 0..$last; # reordered has file and $Thesiteurl first
433 @urllist = map { $ccurllist->[$_] } @host_seq;
435 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
436 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
437 if (my $recommend = $self->_recommend_url_for($file)) {
438 @urllist = grep { $_ ne $recommend } @urllist;
439 unshift @urllist, $recommend;
441 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
442 $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
444 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
445 if ($ret eq $aslocal_tempfile) {
446 # if we got it exactly as we asked for, only then we
448 rename $aslocal_tempfile, $aslocal
449 or $CPAN::Frontend->mydie("Error while trying to rename ".
450 "'$ret' to '$aslocal': $!");
455 # utime $now, $now, $aslocal; # too bad, if we do that, we
456 # might alter a local mirror
457 $self->debug("level[$level]") if $CPAN::DEBUG;
460 unlink $aslocal_tempfile;
461 last if $CPAN::Signal; # need to cleanup
465 $stats->{filesize} = -s $ret;
467 $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
468 $self->_add_to_statistics($stats);
469 $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
471 unlink "$aslocal.bak$$";
474 unless ($CPAN::Signal) {
477 if (@{$CPAN::Config->{urllist}}) {
479 qq{Please check, if the URLs I found in your configuration file \(}.
480 join(", ", @{$CPAN::Config->{urllist}}).
483 push @mess, qq{Your urllist is empty!};
485 push @mess, qq{The urllist can be edited.},
486 qq{E.g. with 'o conf urllist push ftp://myurl/'};
487 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
488 $CPAN::Frontend->mywarn("Could not fetch $file\n");
489 $CPAN::Frontend->mysleep(2);
491 if ($maybe_restore) {
492 rename "$aslocal.bak$$", $aslocal;
493 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
494 $self->ls($aslocal));
501 my($self, $aslocal_dir) = @_;
502 mkpath($aslocal_dir);
503 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
504 qq{directory "$aslocal_dir".
505 I\'ll continue, but if you encounter problems, they may be due
506 to insufficient permissions.\n}) unless -w $aslocal_dir;
514 $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
515 my $method = "host$level";
516 $self->$method($h, @_);
520 my($self,$stats,$method,$url) = @_;
521 push @{$stats->{attempts}}, {
529 sub hostdleasy { #called from hostdlxxx
530 my($self,$host_seq,$file,$aslocal,$stats) = @_;
532 HOSTEASY: for $ro_url (@$host_seq) {
533 $self->_set_attempt($stats,"dleasy",$ro_url);
534 my $url .= "$ro_url$file";
535 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
536 if ($url =~ /^file:/) {
538 if ($CPAN::META->has_inst('URI::URL')) {
539 my $u = URI::URL->new($url);
541 } else { # works only on Unix, is poorly constructed, but
542 # hopefully better than nothing.
543 # RFC 1738 says fileurl BNF is
544 # fileurl = "file://" [ host | "localhost" ] "/" fpath
545 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
547 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
548 $l =~ s|^file:||; # assume they
552 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
554 $self->debug("local file[$l]") if $CPAN::DEBUG;
555 if ( -f $l && -r _) {
556 $ThesiteURL = $ro_url;
559 if ($l =~ /(.+)\.gz$/) {
561 if ( -f $ungz && -r _) {
562 $ThesiteURL = $ro_url;
566 # Maybe mirror has compressed it?
568 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
569 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
571 $ThesiteURL = $ro_url;
575 $CPAN::Frontend->mywarn("Could not find '$l'\n");
577 $self->debug("it was not a file URL") if $CPAN::DEBUG;
578 if ($CPAN::META->has_usable('LWP')) {
579 $CPAN::Frontend->myprint("Fetching with LWP:
583 CPAN::LWP::UserAgent->config;
584 eval { $Ua = CPAN::LWP::UserAgent->new; };
586 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
589 my $res = $Ua->mirror($url, $aslocal);
590 if ($res->is_success) {
591 $ThesiteURL = $ro_url;
593 utime $now, $now, $aslocal; # download time is more
594 # important than upload
597 } elsif ($url !~ /\.gz(?!\n)\Z/) {
598 my $gzurl = "$url.gz";
599 $CPAN::Frontend->myprint("Fetching with LWP:
602 $res = $Ua->mirror($gzurl, "$aslocal.gz");
603 if ($res->is_success) {
604 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
605 $ThesiteURL = $ro_url;
610 $CPAN::Frontend->myprint(sprintf(
611 "LWP failed with code[%s] message[%s]\n",
615 # Alan Burlison informed me that in firewall environments
616 # Net::FTP can still succeed where LWP fails. So we do not
617 # skip Net::FTP anymore when LWP is available.
620 $CPAN::Frontend->mywarn(" LWP not available\n");
622 return if $CPAN::Signal;
623 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
624 # that's the nice and easy way thanks to Graham
625 $self->debug("recognized ftp") if $CPAN::DEBUG;
626 my($host,$dir,$getfile) = ($1,$2,$3);
627 if ($CPAN::META->has_usable('Net::FTP')) {
629 $CPAN::Frontend->myprint("Fetching with Net::FTP:
632 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
633 "aslocal[$aslocal]") if $CPAN::DEBUG;
634 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
635 $ThesiteURL = $ro_url;
638 if ($aslocal !~ /\.gz(?!\n)\Z/) {
639 my $gz = "$aslocal.gz";
640 $CPAN::Frontend->myprint("Fetching with Net::FTP
643 if (CPAN::FTP->ftp_get($host,
647 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
649 $ThesiteURL = $ro_url;
655 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
659 UNIVERSAL::can($ro_url,"text")
661 $ro_url->{FROM} eq "USER"
663 ##address #17973: default URLs should not try to override
664 ##user-defined URLs just because LWP is not available
665 my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
668 return if $CPAN::Signal;
674 my($self,$host_seq,$file,$aslocal,$stats) = @_;
676 # Came back if Net::FTP couldn't establish connection (or
677 # failed otherwise) Maybe they are behind a firewall, but they
678 # gave us a socksified (or other) ftp program...
681 my($devnull) = $CPAN::Config->{devnull} || "";
683 my($aslocal_dir) = dirname($aslocal);
684 mkpath($aslocal_dir);
685 HOSTHARD: for $ro_url (@$host_seq) {
686 $self->_set_attempt($stats,"dlhard",$ro_url);
687 my $url = "$ro_url$file";
688 my($proto,$host,$dir,$getfile);
690 # Courtesy Mark Conty mark_conty@cargill.com change from
691 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
693 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
695 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
697 next HOSTHARD; # who said, we could ftp anything except ftp?
699 next HOSTHARD if $proto eq "file"; # file URLs would have had
700 # success above. Likely a bogus URL
702 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
704 # Try the most capable first and leave ncftp* for last as it only
706 my $proxy_vars = $self->_proxy_vars($ro_url);
707 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
708 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
709 next unless defined $funkyftp;
710 next if $funkyftp =~ /^\s*$/;
712 my($asl_ungz, $asl_gz);
713 ($asl_ungz = $aslocal) =~ s/\.gz//;
714 $asl_gz = "$asl_ungz.gz";
716 my($src_switch) = "";
718 my($stdout_redir) = " > $asl_ungz";
720 $src_switch = " -source";
721 } elsif ($f eq "ncftp") {
723 } elsif ($f eq "wget") {
724 $src_switch = " -O $asl_ungz";
726 } elsif ($f eq 'curl') {
727 $src_switch = ' -L -f -s -S --netrc-optional';
728 if ($proxy_vars->{http_proxy}) {
729 $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
733 if ($f eq "ncftpget") {
734 $chdir = "cd $aslocal_dir && ";
737 $CPAN::Frontend->myprint(
739 Trying with "$funkyftp$src_switch" to get
743 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
744 $self->debug("system[$system]") if $CPAN::DEBUG;
745 my($wstatus) = system($system);
747 # lynx returns 0 when it fails somewhere
749 my $content = do { local *FH;
750 open FH, $asl_ungz or die;
753 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
754 $CPAN::Frontend->mywarn(qq{
755 No success, the file that lynx has downloaded looks like an error message:
758 $CPAN::Frontend->mysleep(1);
762 $CPAN::Frontend->myprint(qq{
763 No success, the file that lynx has downloaded is an empty file.
771 } elsif ($asl_ungz ne $aslocal) {
772 # test gzip integrity
773 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
774 # e.g. foo.tar is gzipped --> foo.tar.gz
775 rename $asl_ungz, $aslocal;
777 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
780 $ThesiteURL = $ro_url;
782 } elsif ($url !~ /\.gz(?!\n)\Z/) {
784 -f $asl_ungz && -s _ == 0;
785 my $gz = "$aslocal.gz";
786 my $gzurl = "$url.gz";
787 $CPAN::Frontend->myprint(
789 Trying with "$funkyftp$src_switch" to get
792 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
793 $self->debug("system[$system]") if $CPAN::DEBUG;
795 if (($wstatus = system($system)) == 0
799 # test gzip integrity
800 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
801 if ($ct && $ct->gtest) {
802 $ct->gunzip($aslocal);
804 # somebody uncompressed file for us?
805 rename $asl_ungz, $aslocal;
807 $ThesiteURL = $ro_url;
810 unlink $asl_gz if -f $asl_gz;
813 my $estatus = $wstatus >> 8;
814 my $size = -f $aslocal ?
815 ", left\n$aslocal with size ".-s _ :
816 "\nWarning: expected file [$aslocal] doesn't exist";
817 $CPAN::Frontend->myprint(qq{
818 Function system("$system")
819 returned status $estatus (wstat $wstatus)$size
822 return if $CPAN::Signal;
823 } # transfer programs
827 #-> CPAN::FTP::_proxy_vars
831 my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
833 my($host) = $url =~ m|://([^/:]+)|;
835 my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
836 my @noproxy = split /\s*,\s*/, $noproxy;
838 DOMAIN: for my $domain (@noproxy) {
839 if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
845 $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n");
849 &CPAN::LWP::UserAgent::get_proxy_credentials();
853 http_proxy => $http_proxy
862 my($self,$host_seq,$file,$aslocal,$stats) = @_;
864 return unless @$host_seq;
866 my($aslocal_dir) = dirname($aslocal);
867 mkpath($aslocal_dir);
868 my $ftpbin = $CPAN::Config->{ftp};
869 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
870 $CPAN::Frontend->myprint("No external ftp command available\n\n");
873 $CPAN::Frontend->mywarn(qq{
874 As a last resort we now switch to the external ftp command '$ftpbin'
877 Doing so often leads to problems that are hard to diagnose.
879 If you're the victim of such problems, please consider unsetting the
880 ftp config variable with
886 $CPAN::Frontend->mysleep(2);
887 HOSTHARDEST: for $ro_url (@$host_seq) {
888 $self->_set_attempt($stats,"dlhardest",$ro_url);
889 my $url = "$ro_url$file";
890 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
891 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
894 my($host,$dir,$getfile) = ($1,$2,$3);
896 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
897 $ctime,$blksize,$blocks) = stat($aslocal);
898 $timestamp = $mtime ||= 0;
899 my($netrc) = CPAN::FTP::netrc->new;
900 my($netrcfile) = $netrc->netrc;
901 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
902 my $targetfile = File::Basename::basename($aslocal);
908 map("cd $_", split /\//, $dir), # RFC 1738
910 "get $getfile $targetfile",
914 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
915 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
916 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
918 $netrc->contains($host))) if $CPAN::DEBUG;
919 if ($netrc->protected) {
920 my $dialog = join "", map { " $_\n" } @dialog;
922 if ($netrc->contains($host)) {
923 $netrc_explain = "Relying that your .netrc entry for '$host' ".
926 $netrc_explain = "Relying that your default .netrc entry ".
929 $CPAN::Frontend->myprint(qq{
930 Trying with external ftp to get
933 Going to send the dialog
937 $self->talk_ftp("$ftpbin$verbose $host",
939 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
940 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
942 if ($mtime > $timestamp) {
943 $CPAN::Frontend->myprint("GOT $aslocal\n");
944 $ThesiteURL = $ro_url;
947 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
949 return if $CPAN::Signal;
951 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
952 qq{correctly protected.\n});
955 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
956 nor does it have a default entry\n");
959 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
960 # then and login manually to host, using e-mail as
962 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
966 "user anonymous $Config::Config{'cf_email'}"
968 my $dialog = join "", map { " $_\n" } @dialog;
969 $CPAN::Frontend->myprint(qq{
970 Trying with external ftp to get
972 Going to send the dialog
976 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
977 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
978 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
980 if ($mtime > $timestamp) {
981 $CPAN::Frontend->myprint("GOT $aslocal\n");
982 $ThesiteURL = $ro_url;
985 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
987 return if $CPAN::Signal;
988 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
989 $CPAN::Frontend->mysleep(2);
995 my($self,$command,@dialog) = @_;
996 my $fh = FileHandle->new;
997 $fh->open("|$command") or die "Couldn't open ftp: $!";
998 foreach (@dialog) { $fh->print("$_\n") }
999 $fh->close; # Wait for process to complete
1001 my $estatus = $wstatus >> 8;
1002 $CPAN::Frontend->myprint(qq{
1003 Subprocess "|$command"
1004 returned status $estatus (wstat $wstatus)
1008 # find2perl needs modularization, too, all the following is stolen
1012 my($self,$name) = @_;
1013 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
1014 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
1016 my($perms,%user,%group);
1020 $blocks = int(($blocks + 1) / 2);
1023 $blocks = int(($sizemm + 1023) / 1024);
1026 if (-f _) { $perms = '-'; }
1027 elsif (-d _) { $perms = 'd'; }
1028 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
1029 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
1030 elsif (-p _) { $perms = 'p'; }
1031 elsif (-S _) { $perms = 's'; }
1032 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
1034 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
1035 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
1036 my $tmpmode = $mode;
1037 my $tmp = $rwx[$tmpmode & 7];
1039 $tmp = $rwx[$tmpmode & 7] . $tmp;
1041 $tmp = $rwx[$tmpmode & 7] . $tmp;
1042 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
1043 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
1044 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
1047 my $user = $user{$uid} || $uid; # too lazy to implement lookup
1048 my $group = $group{$gid} || $gid;
1050 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
1052 my($moname) = $moname[$mon];
1053 if (-M _ > 365.25 / 2) {
1054 $timeyear = $year + 1900;
1057 $timeyear = sprintf("%02d:%02d", $hour, $min);
1060 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",