← Index
NYTProf Performance Profile   « line view »
For /Users/brian/bin/perls/cpan5.26.1
  Run on Sat Dec 30 01:41:10 2017
Reported on Sat Dec 30 01:44:14 2017

Filename/usr/local/perls/perl-5.26.1/lib/5.26.1/CPAN/FTP.pm
StatementsExecuted 242 statements in 10.3ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
8418.47ms8.47msCPAN::FTP::::CORE:ftfileCPAN::FTP::CORE:ftfile (opcode)
221454µs51.9msCPAN::FTP::::localizeCPAN::FTP::localize
111402µs402µsCPAN::FTP::::CORE:openCPAN::FTP::CORE:open (opcode)
211222µs37.1msCPAN::FTP::::hostdleasyCPAN::FTP::hostdleasy
111166µs1.11msCPAN::FTP::::_ftp_statisticsCPAN::FTP::_ftp_statistics
21196µs96µsCPAN::FTP::::CORE:unlinkCPAN::FTP::CORE:unlink (opcode)
63189µs128µsCPAN::FTP::::CORE:matchCPAN::FTP::CORE:match (opcode)
21186µs37.3msCPAN::FTP::::hostdlxxxCPAN::FTP::hostdlxxx
21174µs117µsCPAN::FTP::::_get_urllistCPAN::FTP::_get_urllist
42163µs9.37msCPAN::FTP::::_mytimeCPAN::FTP::_mytime
21145µs1.16msCPAN::FTP::::_recommend_url_forCPAN::FTP::_recommend_url_for
21136µs9.32msCPAN::FTP::::_new_statsCPAN::FTP::_new_stats
21133µs121µsCPAN::FTP::::_set_attemptCPAN::FTP::_set_attempt
21128µs28µsCPAN::FTP::::CORE:regcompCPAN::FTP::CORE:regcomp (opcode)
21128µs346µsCPAN::FTP::::_add_to_statisticsCPAN::FTP::_add_to_statistics
21114µs14µsCPAN::FTP::::CORE:ftsizeCPAN::FTP::CORE:ftsize (opcode)
2117µs7µsCPAN::FTP::::CORE:substCPAN::FTP::CORE:subst (opcode)
2116µs6µsCPAN::FTP::::CORE:ftereadCPAN::FTP::CORE:fteread (opcode)
2113µs3µsCPAN::FTP::::CORE:sortCPAN::FTP::CORE:sort (opcode)
0000s0sCPAN::FTP::::BEGINCPAN::FTP::BEGIN
0000s0sCPAN::FTP::::_copy_statCPAN::FTP::_copy_stat
0000s0sCPAN::FTP::::_proxy_varsCPAN::FTP::_proxy_vars
0000s0sCPAN::FTP::::ftp_getCPAN::FTP::ftp_get
0000s0sCPAN::FTP::::hostdlhardCPAN::FTP::hostdlhard
0000s0sCPAN::FTP::::hostdlhardestCPAN::FTP::hostdlhardest
0000s0sCPAN::FTP::::lsCPAN::FTP::ls
0000s0sCPAN::FTP::::mymkpathCPAN::FTP::mymkpath
0000s0sCPAN::FTP::::talk_ftpCPAN::FTP::talk_ftp
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
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 Fcntl qw(:flock);
7use File::Basename qw(dirname);
8use File::Path qw(mkpath);
9use CPAN::FTP::netrc;
10use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
11
12@CPAN::FTP::ISA = qw(CPAN::Debug);
13
14use 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
# spent 1.11ms (166µs+943µs) within CPAN::FTP::_ftp_statistics which was called: # once (166µs+943µs) by CPAN::FTP::_recommend_url_for at line 182
sub _ftp_statistics {
2211µs my($self,$fh) = @_;
2311µs 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.
2711µs $locktype = LOCK_SH if $^O eq "MSWin32";
28
29118µs169µs $fh ||= FileHandle->new;
# spent 69µs making 1 call to IO::File::new
30128µs431µs my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
# spent 22µs making 1 call to File::Spec::Unix::catfile # spent 7µs making 1 call to File::Spec::Unix::catdir # spent 2µs making 2 calls to File::Spec::Unix::canonpath, avg 1µs/call
3117µs2106µs mkpath dirname $file;
# spent 72µs making 1 call to File::Path::mkpath # spent 34µs making 1 call to File::Basename::dirname
321421µs1402µs open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
# spent 402µs making 1 call to CPAN::FTP::CORE:open
3311µs my $sleep = 1;
3411µs my $waitstart;
35111µs136µs while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
# spent 36µs making 1 call to CPAN::_flock
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 }
5327µs1240µs my $stats = eval { CPAN->_yaml_loadfile($file); };
# spent 240µs making 1 call to CPAN::_yaml_loadfile
54134µs16µs if ($@) {
# spent 6µs making 1 call to CPAN::Exception::yaml_not_installed::as_string
5511µs if (ref $@) {
5611µs if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
57115µs26µs chomp $@;
# spent 6µs making 2 calls to CPAN::Exception::yaml_not_installed::as_string, avg 3µs/call
5817µs156µs $CPAN::Frontend->myprintonce("Warning (usually harmless): $@\n");
# spent 56µs making 1 call to CPAN::Shell::myprintonce
59122µs 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
# spent 9.37ms (63µs+9.31) within CPAN::FTP::_mytime which was called 4 times, avg 2.34ms/call: # 2 times (42µs+9.24ms) by CPAN::FTP::_new_stats at line 87, avg 4.64ms/call # 2 times (21µs+67µs) by CPAN::FTP::_set_attempt at line 545, avg 44µs/call
sub _mytime () {
77498µs89.31ms if (CPAN->has_inst("Time::HiRes")) {
# spent 9.28ms making 4 calls to CPAN::has_inst, avg 2.32ms/call # spent 29µs making 4 calls to Time::HiRes::time, avg 7µs/call
78 return Time::HiRes::time();
79 } else {
80 return time;
81 }
82}
83
84#-> sub CPAN::FTP::_new_stats
85
# spent 9.32ms (36µs+9.29) within CPAN::FTP::_new_stats which was called 2 times, avg 4.66ms/call: # 2 times (36µs+9.29ms) by CPAN::FTP::localize at line 414, avg 4.66ms/call
sub _new_stats {
8621µs my($self,$file) = @_;
87217µs29.29ms my $ret = {
# spent 9.29ms making 2 calls to CPAN::FTP::_mytime, avg 4.64ms/call
88 file => $file,
89 attempts => [],
90 start => _mytime,
91 };
92216µs $ret;
93}
94
95#-> sub CPAN::FTP::_add_to_statistics
96
# spent 346µs (28+318) within CPAN::FTP::_add_to_statistics which was called 2 times, avg 173µs/call: # 2 times (28µs+318µs) by CPAN::FTP::localize at line 493, avg 173µs/call
sub _add_to_statistics {
9722µs my($self,$stats) = @_;
98212µs2210µs my $yaml_module = CPAN::_yaml_module();
# spent 210µs making 2 calls to CPAN::_yaml_module, avg 105µs/call
9921µs $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
100213µs2108µs if ($CPAN::META->has_inst($yaml_module)) {
# spent 108µs making 2 calls to CPAN::has_inst, avg 54µs/call
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
150sub _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
# spent 1.16ms (45µs+1.12) within CPAN::FTP::_recommend_url_for which was called 2 times, avg 580µs/call: # 2 times (45µs+1.12ms) by CPAN::FTP::localize at line 458, avg 580µs/call
sub _recommend_url_for {
18022µs my($self, $file, $urllist) = @_;
181229µs27µs if ($file =~ s|/CHECKSUMS(.gz)?$||) {
# spent 7µs making 2 calls to CPAN::FTP::CORE:subst, avg 4µs/call
182111µs11.11ms my $fullstats = $self->_ftp_statistics();
# spent 1.11ms making 1 call to CPAN::FTP::_ftp_statistics
18311µs my $history = $fullstats->{history} || [];
18411µs 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 }
19122µs if ($CPAN::Config->{randomize_urllist}
192 &&
193 rand(1) < $CPAN::Config->{randomize_urllist}
194 ) {
195 $urllist->[int rand scalar @$urllist];
196 } else {
197218µs return ();
198 }
199}
200
201#-> sub CPAN::FTP::_get_urllist
202
# spent 117µs (74+43) within CPAN::FTP::_get_urllist which was called 2 times, avg 58µs/call: # 2 times (74µs+43µs) by CPAN::FTP::localize at line 370, avg 58µs/call
sub _get_urllist {
20321µs my($self, $with_defaults) = @_;
20421µs $with_defaults ||= 0;
20521µs CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;
206
20722µs $CPAN::Config->{urllist} ||= [];
20824µs unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
209 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
210 $CPAN::Config->{urllist} = [];
211 }
212211µs my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
21320s push @urllist, @CPAN::Defaultsites if $with_defaults;
21423µs for my $u (@urllist) {
21520s CPAN->debug("u[$u]") if $CPAN::DEBUG;
216237µs217µs if (UNIVERSAL::can($u,"text")) {
# spent 17µs making 2 calls to UNIVERSAL::can, avg 8µs/call
217 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
218 } else {
21925µs $u .= "/" unless substr($u,-1) eq "/";
220216µs226µs $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
# spent 26µs making 2 calls to CPAN::URL::new, avg 13µs/call
221 }
222 }
22329µs \@urllist;
224}
225
226#-> sub CPAN::FTP::ftp_get ;
227sub 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
# spent 51.9ms (454µs+51.5) within CPAN::FTP::localize which was called 2 times, avg 26.0ms/call: # once (326µs+48.5ms) by CPAN::Distribution::get_file_onto_local_disk at line 436 of CPAN/Distribution.pm # once (128µs+2.98ms) by CPAN::Distribution::verifyCHECKSUM at line 1422 of CPAN/Distribution.pm
sub localize {
29223µs my($self,$file,$aslocal,$force,$with_defaults) = @_;
29322µs $force ||= 0;
29421µs Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" )
295 unless defined $aslocal;
29622µs if ($CPAN::DEBUG){
297 require Carp;
298 my $longmess = Carp::longmess();
299 $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
300 }
30127µs 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
32522.09ms22.06ms if (-f $aslocal && -r _ && !($force & 1)) {
# spent 2.06ms making 2 calls to CPAN::FTP::CORE:ftfile, avg 1.03ms/call
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 }
33724µs my($maybe_restore) = 0;
338222µs213µs if (-f $aslocal) {
# spent 13µs making 2 calls to CPAN::FTP::CORE:ftfile, avg 6µs/call
339 rename $aslocal, "$aslocal.bak$$";
340 $maybe_restore++;
341 }
342
343215µs2205µs my($aslocal_dir) = dirname($aslocal);
# spent 205µs making 2 calls to File::Basename::dirname, avg 102µs/call
344 # Inheritance is not easier to manage than a few if/else branches
345214µs2799µs if ($CPAN::META->has_usable('LWP::UserAgent')) {
# spent 799µs making 2 calls to CPAN::has_usable, avg 400µs/call
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 }
36323µs for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
36466µs $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
36921µs my(@reordered,$last);
370212µs2117µs my $ccurllist = $self->_get_urllist($with_defaults);
# spent 117µs making 2 calls to CPAN::FTP::_get_urllist, avg 58µs/call
37122µs $last = $#$ccurllist;
37222µs if ($force & 2) { # local cpans probably out of date, don't reorder
373 @reordered = (0..$last);
374 } else {
375 @reordered =
376 sort {
377220µs23µs (substr($ccurllist->[$b],0,4) eq "file")
# spent 3µs making 2 calls to CPAN::FTP::CORE:sort, avg 2µs/call
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 }
38820s my(@levels);
38925µs $Themethod ||= "";
39021µs $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
391221µs 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 );
40220s if ($Themethod) {
40313µs @levels = grep {$_->[0] eq $Themethod} @all_levels;
40412µs push @levels, grep {$_->[0] ne $Themethod} @all_levels;
405 } else {
40611µs @levels = @all_levels;
407 }
40823µs @levels = qw/dleasy/ if $^O eq 'MacOS';
40920s my($levelno);
410 local $ENV{FTP_PASSIVE} =
411 exists $CPAN::Config->{ftp_passive} ?
412217µs $CPAN::Config->{ftp_passive} : 1;
41321µs my $ret;
414211µs29.32ms my $stats = $self->_new_stats($file);
# spent 9.32ms making 2 calls to CPAN::FTP::_new_stats, avg 4.66ms/call
41525µs for ($CPAN::Config->{connect_to_internet_ok}) {
41626µs $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
417 }
41826µs LEVEL: for $levelno (0..$#levels) {
41923µs my $level_tuple = $levels[$levelno];
42023µs my($level,$scheme,$sitetag) = @$level_tuple;
42121µs $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
42221µs my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist;
42321µs my @urllist;
42421µs if ($defaultsites) {
425 unless (defined $connect_to_internet_ok) {
426 $CPAN::Frontend->myprint(sprintf qq{
427I 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
452235µs212µs my @host_seq = $level =~ /dleasy/ ?
# spent 12µs making 2 calls to CPAN::FTP::CORE:match, avg 6µs/call
453 @reordered : 0..$last; # reordered has file and $Thesiteurl first
45428µs @urllist = map { $ccurllist->[$_] } @host_seq;
455 }
45620s $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
457211µs my $aslocal_tempfile = $aslocal . ".tmp" . $$;
458211µs21.16ms if (my $recommend = $self->_recommend_url_for($file,\@urllist)) {
# spent 1.16ms making 2 calls to CPAN::FTP::_recommend_url_for, avg 580µs/call
459 @urllist = grep { $_ ne $recommend } @urllist;
460 unshift @urllist, $recommend;
461 }
46222µs $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
463215µs237.3ms $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
# spent 37.3ms making 2 calls to CPAN::FTP::hostdlxxx, avg 18.6ms/call
46421µs if ($ret) {
46521µs CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
466234µs223µs if ($ret eq $aslocal_tempfile) {
# spent 23µs making 2 calls to CPAN::FTP::CORE:ftfile, avg 12µs/call
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 }
47822µs $Themethod = $level;
47927µs my $now = time;
480 # utime $now, $now, $aslocal; # too bad, if we do that, we
481 # might alter a local mirror
48220s $self->debug("level[$level]") if $CPAN::DEBUG;
48326µs last LEVEL;
484 } else {
485 unlink $aslocal_tempfile;
486 last if $CPAN::Signal; # need to cleanup
487 }
488 }
489233µs214µs if ($ret) {
# spent 14µs making 2 calls to CPAN::FTP::CORE:ftsize, avg 7µs/call
490 $stats->{filesize} = -s $ret;
491 }
49221µs $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
493210µs2346µs $self->_add_to_statistics($stats);
# spent 346µs making 2 calls to CPAN::FTP::_add_to_statistics, avg 173µs/call
49420s $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
49521µs if ($ret) {
4962121µs296µs unlink "$aslocal.bak$$";
# spent 96µs making 2 calls to CPAN::FTP::CORE:unlink, avg 48µs/call
497253µs 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
524sub 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
# spent 37.3ms (86µs+37.2) within CPAN::FTP::hostdlxxx which was called 2 times, avg 18.6ms/call: # 2 times (86µs+37.2ms) by CPAN::FTP::localize at line 463, avg 18.6ms/call
sub hostdlxxx {
534216µs my $self = shift;
53523µs my $level = shift;
53620s my $scheme = shift;
53721µs my $h = shift;
5382127µs6174µs $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
# spent 107µs making 2 calls to CPAN::FTP::CORE:match, avg 54µs/call # spent 39µs making 2 calls to CPAN::URL::as_string, avg 20µs/call # spent 28µs making 2 calls to CPAN::FTP::CORE:regcomp, avg 14µs/call
53923µs my $method = "host$level";
540226µs237.1ms $self->$method($h, @_);
# spent 37.1ms making 2 calls to CPAN::FTP::hostdleasy, avg 18.5ms/call
541}
542
543
# spent 121µs (33+88) within CPAN::FTP::_set_attempt which was called 2 times, avg 60µs/call: # 2 times (33µs+88µs) by CPAN::FTP::hostdleasy at line 557, avg 60µs/call
sub _set_attempt {
54422µs my($self,$stats,$method,$url) = @_;
545227µs288µs push @{$stats->{attempts}}, {
# spent 88µs making 2 calls to CPAN::FTP::_mytime, avg 44µs/call
546 method => $method,
547 start => _mytime,
548 url => $url,
549 };
550}
551
552# package CPAN::FTP;
553
# spent 37.1ms (222µs+36.9) within CPAN::FTP::hostdleasy which was called 2 times, avg 18.5ms/call: # 2 times (222µs+36.9ms) by CPAN::FTP::hostdlxxx at line 540, avg 18.5ms/call
sub hostdleasy { #called from hostdlxxx
55424µs my($self,$host_seq,$file,$aslocal,$stats) = @_;
55521µs my($ro_url);
55624µs HOSTEASY: for $ro_url (@$host_seq) {
55726µs2121µs $self->_set_attempt($stats,"dleasy",$ro_url);
# spent 121µs making 2 calls to CPAN::FTP::_set_attempt, avg 60µs/call
558214µs217µs my $url .= "$ro_url$file";
# spent 17µs making 2 calls to CPAN::URL::as_string, avg 8µs/call
55921µs $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
560220µs29µs if ($url =~ /^file:/) {
# spent 9µs making 2 calls to CPAN::FTP::CORE:match, avg 4µs/call
56121µs my $l;
56228µs217.0ms if ($CPAN::META->has_inst('URI::URL')) {
# spent 17.0ms making 2 calls to CPAN::has_inst, avg 8.49ms/call
563211µs29.53ms my $u = URI::URL->new($url);
# spent 9.53ms making 2 calls to URI::URL::new, avg 4.76ms/call
564250µs43.82ms $l = $u->file;
# spent 3.82ms making 4 calls to URI::WithBase::AUTOLOAD, avg 955µs/call
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" <[email protected]> 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 }
57821µs $self->debug("local file[$l]") if $CPAN::DEBUG;
57926.42ms46.38ms if ( -f $l && -r _) {
# spent 6.38ms making 2 calls to CPAN::FTP::CORE:ftfile, avg 3.19ms/call # spent 6µs making 2 calls to CPAN::FTP::CORE:fteread, avg 3µs/call
580218µs $ThesiteURL = $ro_url;
581218µs 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;
756sub 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 [email protected] 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[
823Trying with
824 $funkyftp$src_switch
825to 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{
841No 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{
850No 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
885sub _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;
918sub 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{
931As a last resort we now switch to the external ftp command '$ftpbin'
932to get '$aslocal'.
933
934Doing so often leads to problems that are hard to diagnose.
935
936If you're the victim of such problems, please consider unsetting the
937ftp 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;
1052sub 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{
1061Subprocess "|$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
1069sub 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
11321;
 
# spent 6µs within CPAN::FTP::CORE:fteread which was called 2 times, avg 3µs/call: # 2 times (6µs+0s) by CPAN::FTP::hostdleasy at line 579, avg 3µs/call
sub CPAN::FTP::CORE:fteread; # opcode
# spent 8.47ms within CPAN::FTP::CORE:ftfile which was called 8 times, avg 1.06ms/call: # 2 times (6.38ms+0s) by CPAN::FTP::hostdleasy at line 579, avg 3.19ms/call # 2 times (2.06ms+0s) by CPAN::FTP::localize at line 325, avg 1.03ms/call # 2 times (23µs+0s) by CPAN::FTP::localize at line 466, avg 12µs/call # 2 times (13µs+0s) by CPAN::FTP::localize at line 338, avg 6µs/call
sub CPAN::FTP::CORE:ftfile; # opcode
# spent 14µs within CPAN::FTP::CORE:ftsize which was called 2 times, avg 7µs/call: # 2 times (14µs+0s) by CPAN::FTP::localize at line 489, avg 7µs/call
sub CPAN::FTP::CORE:ftsize; # opcode
# spent 128µs (89+39) within CPAN::FTP::CORE:match which was called 6 times, avg 21µs/call: # 2 times (68µs+39µs) by CPAN::FTP::hostdlxxx at line 538, avg 54µs/call # 2 times (12µs+0s) by CPAN::FTP::localize at line 452, avg 6µs/call # 2 times (9µs+0s) by CPAN::FTP::hostdleasy at line 560, avg 4µs/call
sub CPAN::FTP::CORE:match; # opcode
# spent 402µs within CPAN::FTP::CORE:open which was called: # once (402µs+0s) by CPAN::FTP::_ftp_statistics at line 32
sub CPAN::FTP::CORE:open; # opcode
# spent 28µs within CPAN::FTP::CORE:regcomp which was called 2 times, avg 14µs/call: # 2 times (28µs+0s) by CPAN::FTP::hostdlxxx at line 538, avg 14µs/call
sub CPAN::FTP::CORE:regcomp; # opcode
# spent 3µs within CPAN::FTP::CORE:sort which was called 2 times, avg 2µs/call: # 2 times (3µs+0s) by CPAN::FTP::localize at line 377, avg 2µs/call
sub CPAN::FTP::CORE:sort; # opcode
# spent 7µs within CPAN::FTP::CORE:subst which was called 2 times, avg 4µs/call: # 2 times (7µs+0s) by CPAN::FTP::_recommend_url_for at line 181, avg 4µs/call
sub CPAN::FTP::CORE:subst; # opcode
# spent 96µs within CPAN::FTP::CORE:unlink which was called 2 times, avg 48µs/call: # 2 times (96µs+0s) by CPAN::FTP::localize at line 496, avg 48µs/call
sub CPAN::FTP::CORE:unlink; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.