This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to CPAN-1.88_62
[perl5.git] / lib / CPAN.pm
CommitLineData
44d21104 1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
e82b9348 2use strict;
8962fc49 3package CPAN;
05bab18e 4$CPAN::VERSION = '1.88_62';
8962fc49 5$CPAN::VERSION = eval $CPAN::VERSION;
5f05dabc 6
e82b9348 7use CPAN::HandleConfig;
554a9ef5 8use CPAN::Version;
e82b9348 9use CPAN::Debug;
135a59c2 10use CPAN::Queue;
e82b9348 11use CPAN::Tarzip;
5f05dabc
PP
12use Carp ();
13use Config ();
14use Cwd ();
0cf35e6a 15use DirHandle ();
5f05dabc 16use Exporter ();
b96578bb
SP
17use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
18 # 5.005_04 does not work without
19 # this
5f05dabc 20use File::Basename ();
10b2abe6 21use File::Copy ();
5f05dabc
PP
22use File::Find;
23use File::Path ();
0cf35e6a 24use File::Spec ();
da199366 25use FileHandle ();
05bab18e 26use Fcntl qw(:flock);
5f05dabc 27use Safe ();
0cf35e6a 28use Sys::Hostname qw(hostname);
10b2abe6 29use Text::ParseWords ();
0cf35e6a 30use Text::Wrap ();
8962fc49
SP
31
32# we need to run chdir all over and we would get at wrong libraries
33# there
34BEGIN {
35 if (File::Spec->can("rel2abs")) {
36 for my $inc (@INC) {
37 $inc = File::Spec->rel2abs($inc);
38 }
39 }
40}
41no lib ".";
5f05dabc 42
be708cc0
JH
43require Mac::BuildTools if $^O eq 'MacOS';
44
e82b9348
SP
45END { $CPAN::End++; &cleanup; }
46
da199366 47$CPAN::Signal ||= 0;
c356248b 48$CPAN::Frontend ||= "CPAN::Shell";
7fefbd44
RGS
49unless (@CPAN::Defaultsites){
50 @CPAN::Defaultsites = map {
51 CPAN::URL->new(TEXT => $_, FROM => "DEF")
52 }
53 "http://www.perl.org/CPAN/",
54 "ftp://ftp.perl.org/pub/CPAN/";
55}
0cf35e6a 56# $CPAN::iCwd (i for initial) is going to be initialized during find_perl
607a774b 57$CPAN::Perl ||= CPAN::find_perl();
554a9ef5
SP
58$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
59$CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
607a774b 60
05bab18e 61# our globals are getting a mess
6658a91b
SP
62use vars qw(
63 $AUTOLOAD
135a59c2 64 $Be_Silent
6658a91b
SP
65 $CONFIG_DIRTY
66 $DEBUG
67 $Defaultdocs
68 $Defaultrecent
69 $Frontend
70 $GOTOSHELL
71 $HAS_USABLE
72 $Have_warned
73 $META
05bab18e 74 $RUN_DEGRADED
6658a91b
SP
75 $Signal
76 $Suppress_readline
77 $VERSION
135a59c2 78 $autoload_recursion
6658a91b
SP
79 $term
80 @Defaultsites
81 @EXPORT
135a59c2 82 );
6d29edf5 83
2e2b7522 84@CPAN::ISA = qw(CPAN::Debug Exporter);
5f05dabc 85
44d21104
A
86# note that these functions live in CPAN::Shell and get executed via
87# AUTOLOAD when called directly
55e314ee 88@EXPORT = qw(
44d21104
A
89 autobundle
90 bundle
91 clean
92 cvs_import
93 expand
94 force
95 get
96 install
05bab18e 97 install_tested
44d21104
A
98 make
99 mkmyconfig
100 notest
101 perldoc
102 readme
103 recent
104 recompile
8fc516fe 105 report
44d21104
A
106 shell
107 test
ed84aac9 108 upgrade
da199366 109 );
5f05dabc 110
0cf35e6a
SP
111sub soft_chdir_with_alternatives ($);
112
135a59c2
A
113{
114 $autoload_recursion ||= 0;
115
116 #-> sub CPAN::AUTOLOAD ;
117 sub AUTOLOAD {
118 $autoload_recursion++;
119 my($l) = $AUTOLOAD;
120 $l =~ s/.*:://;
121 if ($CPAN::Signal) {
122 warn "Refusing to autoload '$l' while signal pending";
123 $autoload_recursion--;
124 return;
125 }
126 if ($autoload_recursion > 1) {
127 my $fullcommand = join " ", map { "'$_'" } $l, @_;
128 warn "Refusing to autoload $fullcommand in recursion\n";
129 $autoload_recursion--;
130 return;
131 }
132 my(%export);
133 @export{@EXPORT} = '';
134 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
135 if (exists $export{$l}){
136 CPAN::Shell->$l(@_);
137 } else {
138 die(qq{Unknown CPAN command "$AUTOLOAD". }.
139 qq{Type ? for help.\n});
140 }
141 $autoload_recursion--;
55e314ee
AK
142 }
143}
144
145#-> sub CPAN::shell ;
146sub shell {
36263cb3 147 my($self) = @_;
911a92db 148 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
e82b9348 149 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
55e314ee 150
9ddc4ed0 151 my $oprompt = shift || CPAN::Prompt->new;
9d61fa1d
A
152 my $prompt = $oprompt;
153 my $commandline = shift || "";
9ddc4ed0 154 $CPAN::CurrentCommandId ||= 1;
5e05dca5 155
55e314ee
AK
156 local($^W) = 1;
157 unless ($Suppress_readline) {
158 require Term::ReadLine;
9d61fa1d
A
159 if (! $term
160 or
161 $term->ReadLine eq "Term::ReadLine::Stub"
162 ) {
163 $term = Term::ReadLine->new('CPAN Monitor');
164 }
36263cb3
GS
165 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
166 my $attribs = $term->Attribs;
36263cb3
GS
167 $attribs->{attempted_completion_function} = sub {
168 &CPAN::Complete::gnu_cpl;
169 }
36263cb3
GS
170 } else {
171 $readline::rl_completion_function =
172 $readline::rl_completion_function = 'CPAN::Complete::cpl';
173 }
5fc0f0f6
JH
174 if (my $histfile = $CPAN::Config->{'histfile'}) {{
175 unless ($term->can("AddHistory")) {
176 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
177 last;
178 }
179 my($fh) = FileHandle->new;
180 open $fh, "<$histfile" or last;
181 local $/ = "\n";
182 while (<$fh>) {
183 chomp;
184 $term->AddHistory($_);
185 }
186 close $fh;
187 }}
8962fc49
SP
188 for ($CPAN::Config->{term_ornaments}) { # alias
189 local $Term::ReadLine::termcap_nowarn = 1;
ed84aac9
A
190 $term->ornaments($_) if defined;
191 }
8962fc49 192 # $term->OUT is autoflushed anyway
911a92db
GS
193 my $odef = select STDERR;
194 $| = 1;
195 select STDOUT;
196 $| = 1;
197 select $odef;
55e314ee
AK
198 }
199
6d29edf5 200 # no strict; # I do not recall why no strict was here (2000-09-03)
55e314ee 201 $META->checklock();
135a59c2
A
202 my @cwd = grep { defined $_ and length $_ }
203 CPAN::anycwd(),
204 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
205 File::Spec->rootdir();
911a92db
GS
206 my $try_detect_readline;
207 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
55e314ee
AK
208 my $rl_avail = $Suppress_readline ? "suppressed" :
209 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
c4d24d4c 210 "available (try 'install Bundle::CPAN')";
55e314ee 211
8962fc49
SP
212 unless ($CPAN::Config->{'inhibit_startup_message'}){
213 $CPAN::Frontend->myprint(
214 sprintf qq{
554a9ef5 215cpan shell -- CPAN exploration and modules installation (v%s)
6d29edf5 216ReadLine support %s
55e314ee 217
6d29edf5 218},
8962fc49
SP
219 $CPAN::VERSION,
220 $rl_avail
221 )
222 }
c356248b 223 my($continuation) = "";
8962fc49 224 my $last_term_ornaments;
8d97e4a1 225 SHELLCOMMAND: while () {
55e314ee
AK
226 if ($Suppress_readline) {
227 print $prompt;
8d97e4a1 228 last SHELLCOMMAND unless defined ($_ = <> );
55e314ee
AK
229 chomp;
230 } else {
8d97e4a1
JH
231 last SHELLCOMMAND unless
232 defined ($_ = $term->readline($prompt, $commandline));
55e314ee 233 }
c356248b 234 $_ = "$continuation$_" if $continuation;
55e314ee 235 s/^\s+//;
8d97e4a1 236 next SHELLCOMMAND if /^$/;
2e2b7522 237 $_ = 'h' if /^\s*\?/;
09d9d230 238 if (/^(?:q(?:uit)?|bye|exit)$/i) {
8d97e4a1 239 last SHELLCOMMAND;
c356248b
AK
240 } elsif (s/\\$//s) {
241 chomp;
242 $continuation = $_;
243 $prompt = " > ";
244 } elsif (/^\!/) {
55e314ee
AK
245 s/^\!//;
246 my($eval) = $_;
247 package CPAN::Eval;
e82b9348 248 use strict;
55e314ee
AK
249 use vars qw($import_done);
250 CPAN->import(':DEFAULT') unless $import_done++;
251 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
252 eval($eval);
253 warn $@ if $@;
c356248b 254 $continuation = "";
9d61fa1d 255 $prompt = $oprompt;
55e314ee
AK
256 } elsif (/./) {
257 my(@line);
6a935156
SP
258 eval { @line = Text::ParseWords::shellwords($_) };
259 warn($@), next SHELLCOMMAND if $@;
260 warn("Text::Parsewords could not parse the line [$_]"),
261 next SHELLCOMMAND unless @line;
55e314ee
AK
262 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
263 my $command = shift @line;
264 eval { CPAN::Shell->$command(@line) };
6658a91b
SP
265 if ($@){
266 require Carp;
267 Carp::cluck($@);
268 }
8fc516fe 269 if ($command =~ /^(make|test|install|force|notest|clean|report|upgrade)$/) {
9ddc4ed0
A
270 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
271 }
0cf35e6a 272 soft_chdir_with_alternatives(\@cwd);
c356248b
AK
273 $CPAN::Frontend->myprint("\n");
274 $continuation = "";
9ddc4ed0 275 $CPAN::CurrentCommandId++;
9d61fa1d 276 $prompt = $oprompt;
55e314ee
AK
277 }
278 } continue {
9d61fa1d
A
279 $commandline = ""; # I do want to be able to pass a default to
280 # shell, but on the second command I see no
281 # use in that
09d9d230 282 $Signal=0;
36263cb3
GS
283 CPAN::Queue->nullify_queue;
284 if ($try_detect_readline) {
285 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
286 ||
287 $CPAN::META->has_inst("Term::ReadLine::Perl")
288 ) {
289 delete $INC{"Term/ReadLine.pm"};
6d29edf5
JH
290 my $redef = 0;
291 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
36263cb3 292 require Term::ReadLine;
911a92db
GS
293 $CPAN::Frontend->myprint("\n$redef subroutines in ".
294 "Term::ReadLine redefined\n");
6a935156 295 $GOTOSHELL = 1;
36263cb3
GS
296 }
297 }
2ccf00a7
SP
298 if ($term and $term->can("ornaments")) {
299 for ($CPAN::Config->{term_ornaments}) { # alias
300 if (defined $_) {
301 if (not defined $last_term_ornaments
302 or $_ != $last_term_ornaments
303 ) {
304 local $Term::ReadLine::termcap_nowarn = 1;
305 $term->ornaments($_);
306 $last_term_ornaments = $_;
307 }
308 } else {
309 undef $last_term_ornaments;
8962fc49 310 }
8962fc49
SP
311 }
312 }
6658a91b
SP
313 for my $class (qw(Module Distribution)) {
314 # again unsafe meta access?
315 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
316 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
317 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
318 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
6a935156
SP
319 }
320 }
321 if ($GOTOSHELL) {
322 $GOTOSHELL = 0; # not too often
323 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
324 @_ = ($oprompt,"");
325 goto &shell;
326 }
55e314ee 327 }
0cf35e6a 328 soft_chdir_with_alternatives(\@cwd);
55e314ee
AK
329}
330
0cf35e6a
SP
331sub soft_chdir_with_alternatives ($) {
332 my($cwd) = @_;
135a59c2
A
333 unless (@$cwd) {
334 my $root = File::Spec->rootdir();
335 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
336Trying '$root' as temporary haven.
0cf35e6a 337});
135a59c2
A
338 push @$cwd, $root;
339 }
340 while () {
341 if (chdir $cwd->[0]) {
342 return;
0cf35e6a 343 } else {
135a59c2
A
344 if (@$cwd>1) {
345 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
346Trying to chdir to "$cwd->[1]" instead.
347});
348 shift @$cwd;
349 } else {
350 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
351 }
0cf35e6a
SP
352 }
353 }
354}
44d21104 355
05bab18e
SP
356sub _yaml_module {
357 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
358 if (
359 $yaml_module ne "YAML"
360 &&
361 !$CPAN::META->has_inst($yaml_module)
362 ) {
363 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
364 $yaml_module = "YAML";
365 }
366 return $yaml_module;
367}
368
1e8f9a0a
SP
369# CPAN::_yaml_loadfile
370sub _yaml_loadfile {
371 my($self,$local_file) = @_;
05bab18e
SP
372 return +[] unless -s $local_file;
373 my $yaml_module = $self->_yaml_module;
1e8f9a0a
SP
374 if ($CPAN::META->has_inst($yaml_module)) {
375 my $code = UNIVERSAL::can($yaml_module, "LoadFile");
6658a91b
SP
376 my @yaml;
377 eval { @yaml = $code->($local_file); };
1e8f9a0a
SP
378 if ($@) {
379 $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
380 " $local_file\n".
381 "with $yaml_module the following error was encountered:\n".
382 " $@\n"
383 );
384 }
6658a91b 385 return \@yaml;
1e8f9a0a
SP
386 } else {
387 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
388 }
6658a91b 389 return +[];
1e8f9a0a
SP
390}
391
05bab18e
SP
392# CPAN::_yaml_dumpfile
393sub _yaml_dumpfile {
394 my($self,$to_local_file,@what) = @_;
395 my $yaml_module = $self->_yaml_module;
396 if ($CPAN::META->has_inst($yaml_module)) {
397 if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
398 my $code = UNIVERSAL::can($yaml_module, "Dump");
399 eval { print $to_local_file $code->(@what) };
400 } else {
401 my $code = UNIVERSAL::can($yaml_module, "DumpFile");
402 eval { $code->($to_local_file,@what); };
403 }
404 if ($@) {
405 $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n".
406 " $to_local_file\n".
407 "with $yaml_module the following error was encountered:\n".
408 " $@\n"
409 );
410 }
411 } else {
412 $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' not installed, not dumping to '$to_local_file'\n");
413 }
414}
415
55e314ee 416package CPAN::CacheMgr;
e82b9348 417use strict;
c356248b 418@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
55e314ee
AK
419use File::Find;
420
55e314ee 421package CPAN::FTP;
e82b9348 422use strict;
05bab18e 423use Fcntl qw(:flock);
44d21104 424use vars qw($Ua $Thesite $ThesiteURL $Themethod);
55e314ee
AK
425@CPAN::FTP::ISA = qw(CPAN::Debug);
426
c049f953 427package CPAN::LWP::UserAgent;
e82b9348 428use strict;
c049f953 429use vars qw(@ISA $USER $PASSWD $SETUPDONE);
3c4b39be 430# we delay requiring LWP::UserAgent and setting up inheritance until we need it
c049f953 431
55e314ee 432package CPAN::Complete;
e82b9348 433use strict;
55e314ee 434@CPAN::Complete::ISA = qw(CPAN::Debug);
05bab18e
SP
435# Q: where is the "How do I add a new command" HOWTO?
436# A: svn diff -r 1048:1049 where andk added the report command
9d61fa1d 437@CPAN::Complete::COMMANDS = sort qw(
0cf35e6a
SP
438 ! a b d h i m o q r u
439 autobundle
440 clean
441 cvs_import
442 dump
443 force
05bab18e 444 hosts
0cf35e6a 445 install
05bab18e 446 install_tested
0cf35e6a
SP
447 look
448 ls
44d21104
A
449 make
450 mkmyconfig
0cf35e6a
SP
451 notest
452 perldoc
453 readme
454 recent
44d21104 455 recompile
0cf35e6a 456 reload
8fc516fe 457 report
ed84aac9 458 scripts
44d21104 459 test
ed84aac9 460 upgrade
0cf35e6a 461);
55e314ee
AK
462
463package CPAN::Index;
e82b9348 464use strict;
05bab18e 465use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
55e314ee 466@CPAN::Index::ISA = qw(CPAN::Debug);
c049f953
JH
467$LAST_TIME ||= 0;
468$DATE_OF_03 ||= 0;
6d29edf5
JH
469# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
470sub PROTOCOL { 2.0 }
55e314ee
AK
471
472package CPAN::InfoObj;
e82b9348 473use strict;
55e314ee
AK
474@CPAN::InfoObj::ISA = qw(CPAN::Debug);
475
476package CPAN::Author;
e82b9348 477use strict;
55e314ee
AK
478@CPAN::Author::ISA = qw(CPAN::InfoObj);
479
480package CPAN::Distribution;
e82b9348 481use strict;
55e314ee
AK
482@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
483
484package CPAN::Bundle;
e82b9348 485use strict;
55e314ee
AK
486@CPAN::Bundle::ISA = qw(CPAN::Module);
487
488package CPAN::Module;
e82b9348 489use strict;
55e314ee 490@CPAN::Module::ISA = qw(CPAN::InfoObj);
10b2abe6 491
35576f8c 492package CPAN::Exception::RecursiveDependency;
e82b9348 493use strict;
35576f8c
A
494use overload '""' => "as_string";
495
496sub new {
497 my($class) = shift;
498 my($deps) = shift;
499 my @deps;
500 my %seen;
501 for my $dep (@$deps) {
502 push @deps, $dep;
503 last if $seen{$dep}++;
504 }
505 bless { deps => \@deps }, $class;
506}
507
508sub as_string {
509 my($self) = shift;
510 "\nRecursive dependency detected:\n " .
511 join("\n => ", @{$self->{deps}}) .
512 ".\nCannot continue.\n";
513}
514
9ddc4ed0 515package CPAN::Prompt; use overload '""' => "as_string";
4d1321a7
A
516use vars qw($prompt);
517$prompt = "cpan> ";
9ddc4ed0 518$CPAN::CurrentCommandId ||= 0;
9ddc4ed0
A
519sub new {
520 bless {}, shift;
521}
522sub as_string {
05bab18e
SP
523 my $word = "cpan";
524 unless ($CPAN::META->{LOCK}) {
525 $word = "nolock_cpan";
526 }
9ddc4ed0 527 if ($CPAN::Config->{commandnumber_in_prompt}) {
05bab18e 528 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
9ddc4ed0 529 } else {
05bab18e 530 "$word> ";
9ddc4ed0
A
531 }
532}
533
7fefbd44
RGS
534package CPAN::URL; use overload '""' => "as_string", fallback => 1;
535# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
536# planned are things like age or quality
537sub new {
538 my($class,%args) = @_;
539 bless {
540 %args
541 }, $class;
542}
543sub as_string {
544 my($self) = @_;
545 $self->text;
546}
547sub text {
548 my($self,$set) = @_;
549 if (defined $set) {
550 $self->{TEXT} = $set;
551 }
552 $self->{TEXT};
553}
554
9ddc4ed0
A
555package CPAN::Distrostatus;
556use overload '""' => "as_string",
557 fallback => 1;
558sub new {
559 my($class,$arg) = @_;
560 bless {
561 TEXT => $arg,
562 FAILED => substr($arg,0,2) eq "NO",
563 COMMANDID => $CPAN::CurrentCommandId,
564 }, $class;
565}
566sub commandid { shift->{COMMANDID} }
567sub failed { shift->{FAILED} }
568sub text {
569 my($self,$set) = @_;
570 if (defined $set) {
571 $self->{TEXT} = $set;
572 }
573 $self->{TEXT};
574}
575sub as_string {
576 my($self) = @_;
4d1321a7 577 $self->text;
9ddc4ed0
A
578}
579
55e314ee 580package CPAN::Shell;
e82b9348 581use strict;
6a935156
SP
582use vars qw(
583 $ADVANCED_QUERY
584 $AUTOLOAD
585 $COLOR_REGISTERED
135a59c2 586 $autoload_recursion
6a935156
SP
587 $reload
588 @ISA
135a59c2 589 );
55e314ee 590@CPAN::Shell::ISA = qw(CPAN::Debug);
9d61fa1d 591$COLOR_REGISTERED ||= 0;
55e314ee 592
135a59c2 593{
135a59c2
A
594 $autoload_recursion ||= 0;
595
596 #-> sub CPAN::Shell::AUTOLOAD ;
597 sub AUTOLOAD {
598 $autoload_recursion++;
599 my($l) = $AUTOLOAD;
600 my $class = shift(@_);
601 # warn "autoload[$l] class[$class]";
602 $l =~ s/.*:://;
603 if ($CPAN::Signal) {
604 warn "Refusing to autoload '$l' while signal pending";
605 $autoload_recursion--;
606 return;
607 }
608 if ($autoload_recursion > 1) {
609 my $fullcommand = join " ", map { "'$_'" } $l, @_;
610 warn "Refusing to autoload $fullcommand in recursion\n";
611 $autoload_recursion--;
612 return;
613 }
614 if ($l =~ /^w/) {
615 # XXX needs to be reconsidered
616 if ($CPAN::META->has_inst('CPAN::WAIT')) {
617 CPAN::WAIT->$l(@_);
618 } else {
619 $CPAN::Frontend->mywarn(qq{
55e314ee
AK
620Commands starting with "w" require CPAN::WAIT to be installed.
621Please consider installing CPAN::WAIT to use the fulltext index.
f610777f 622For this you just need to type
55e314ee 623 install CPAN::WAIT
c356248b 624});
6d29edf5 625 }
135a59c2
A
626 } else {
627 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
628 qq{Type ? for help.
629});
6d29edf5 630 }
135a59c2 631 $autoload_recursion--;
f610777f 632 }
36263cb3
GS
633}
634
55e314ee 635package CPAN;
e82b9348 636use strict;
55e314ee 637
2e2b7522 638$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
55e314ee 639
6d29edf5
JH
640# from here on only subs.
641################################################################################
55e314ee 642
05bab18e
SP
643sub _perl_fingerprint {
644 my($self,$other_fingerprint) = @_;
645 my $dll = eval {OS2::DLLname()};
646 my $mtime_dll = 0;
647 if (defined $dll) {
648 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
649 }
650 my $this_fingerprint = {
651 '$^X' => $^X,
652 sitearchexp => $Config::Config{sitearchexp},
653 'mtime_$^X' => (stat $^X)[9],
654 'mtime_dll' => $mtime_dll,
655 };
656 if ($other_fingerprint) {
657 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
658 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
659 }
660 # mandatory keys since 1.88_57
661 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
662 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
663 }
664 return 1;
665 } else {
666 return $this_fingerprint;
667 }
668}
669
ed84aac9
A
670sub suggest_myconfig () {
671 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
672 $CPAN::Frontend->myprint("You don't seem to have a user ".
673 "configuration (MyConfig.pm) yet.\n");
8962fc49 674 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
ed84aac9
A
675 "user configuration now? (Y/n)",
676 "yes");
677 if($new =~ m{^y}i) {
678 CPAN::Shell->mkmyconfig();
679 return &checklock;
680 } else {
681 $CPAN::Frontend->mydie("OK, giving up.");
682 }
683 }
684}
685
6d29edf5 686#-> sub CPAN::all_objects ;
36263cb3 687sub all_objects {
5f05dabc 688 my($mgr,$class) = @_;
e82b9348 689 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
5f05dabc
PP
690 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
691 CPAN::Index->reload;
6d29edf5 692 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
5f05dabc
PP
693}
694
c4d24d4c
A
695# Called by shell, not in batch mode. In batch mode I see no risk in
696# having many processes updating something as installations are
697# continually checked at runtime. In shell mode I suspect it is
698# unintentional to open more than one shell at a time
699
10b2abe6 700#-> sub CPAN::checklock ;
5f05dabc
PP
701sub checklock {
702 my($self) = @_;
5de3f0da 703 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
5f05dabc 704 if (-f $lockfile && -M _ > 0) {
6d29edf5 705 my $fh = FileHandle->new($lockfile) or
9ddc4ed0 706 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
0dfa0441
JH
707 my $otherpid = <$fh>;
708 my $otherhost = <$fh>;
5f05dabc 709 $fh->close;
0dfa0441
JH
710 if (defined $otherpid && $otherpid) {
711 chomp $otherpid;
712 }
713 if (defined $otherhost && $otherhost) {
714 chomp $otherhost;
715 }
716 my $thishost = hostname();
717 if (defined $otherhost && defined $thishost &&
718 $otherhost ne '' && $thishost ne '' &&
719 $otherhost ne $thishost) {
9ddc4ed0 720 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
c9869e1c
SP
721 "reports other host $otherhost and other ".
722 "process $otherpid.\n".
0dfa0441 723 "Cannot proceed.\n"));
05bab18e
SP
724 } elsif ($RUN_DEGRADED) {
725 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
726 } elsif (defined $otherpid && $otherpid) {
0dfa0441 727 return if $$ == $otherpid; # should never happen
c356248b
AK
728 $CPAN::Frontend->mywarn(
729 qq{
0dfa0441 730There seems to be running another CPAN process (pid $otherpid). Contacting...
c356248b 731});
0dfa0441 732 if (kill 0, $otherpid) {
05bab18e
SP
733 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
734 my($ans) =
735 CPAN::Shell::colorable_makemaker_prompt
736 (qq{Shall I try to run in degraded }.
737 qq{mode? (Y/n)},"y");
738 if ($ans =~ /^y/i) {
739 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
740Please report if something unexpected happens\n");
741 $RUN_DEGRADED = 1;
742 for ($CPAN::Config) {
743 $_->{build_dir_reuse} = 0;
744 $_->{commandnumber_in_prompt} = 0;
745 $_->{histfile} = "";
746 $_->{cache_metadata} = 0;
747 }
748 } else {
749 $CPAN::Frontend->mydie("
750You may want to kill the other job and delete the lockfile. On UNIX try:
0dfa0441 751 kill $otherpid
c356248b 752 rm $lockfile
05bab18e
SP
753");
754 }
5f05dabc 755 } elsif (-w $lockfile) {
e50380aa 756 my($ans) =
8962fc49 757 CPAN::Shell::colorable_makemaker_prompt
05454584 758 (qq{Other job not responding. Shall I overwrite }.
9ddc4ed0 759 qq{the lockfile '$lockfile'? (Y/n)},"y");
c356248b
AK
760 $CPAN::Frontend->myexit("Ok, bye\n")
761 unless $ans =~ /^y/i;
5f05dabc
PP
762 } else {
763 Carp::croak(
9ddc4ed0 764 qq{Lockfile '$lockfile' not writeable by you. }.
05454584 765 qq{Cannot proceed.\n}.
5f05dabc 766 qq{ On UNIX try:\n}.
9ddc4ed0 767 qq{ rm '$lockfile'\n}.
5f05dabc
PP
768 qq{ and then rerun us.\n}
769 );
770 }
6d29edf5 771 } else {
05bab18e
SP
772 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
773 "'$lockfile', please remove. Cannot proceed.\n"));
6d29edf5 774 }
5f05dabc 775 }
36263cb3
GS
776 my $dotcpan = $CPAN::Config->{cpan_home};
777 eval { File::Path::mkpath($dotcpan);};
778 if ($@) {
ed84aac9
A
779 # A special case at least for Jarkko.
780 my $firsterror = $@;
781 my $seconderror;
782 my $symlinkcpan;
783 if (-l $dotcpan) {
784 $symlinkcpan = readlink $dotcpan;
785 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
786 eval { File::Path::mkpath($symlinkcpan); };
787 if ($@) {
788 $seconderror = $@;
789 } else {
790 $CPAN::Frontend->mywarn(qq{
36263cb3
GS
791Working directory $symlinkcpan created.
792});
ed84aac9
A
793 }
794 }
795 unless (-d $dotcpan) {
796 my $mess = qq{
36263cb3
GS
797Your configuration suggests "$dotcpan" as your
798CPAN.pm working directory. I could not create this directory due
799to this error: $firsterror\n};
ed84aac9 800 $mess .= qq{
36263cb3
GS
801As "$dotcpan" is a symlink to "$symlinkcpan",
802I tried to create that, but I failed with this error: $seconderror
803} if $seconderror;
ed84aac9 804 $mess .= qq{
36263cb3
GS
805Please make sure the directory exists and is writable.
806};
ed84aac9
A
807 $CPAN::Frontend->myprint($mess);
808 return suggest_myconfig;
809 }
44d21104 810 } # $@ after eval mkpath $dotcpan
05bab18e
SP
811 if (0) { # to test what happens when a race condition occurs
812 for (reverse 1..10) {
813 print $_, "\n";
814 sleep 1;
815 }
816 }
817 # locking
818 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
819 my $fh;
820 unless ($fh = FileHandle->new("+>>$lockfile")) {
821 if ($! =~ /Permission/) {
822 $CPAN::Frontend->myprint(qq{
5f05dabc
PP
823
824Your configuration suggests that CPAN.pm should use a working
825directory of
826 $CPAN::Config->{cpan_home}
827Unfortunately we could not create the lock file
828 $lockfile
829due to permission problems.
830
831Please make sure that the configuration variable
832 \$CPAN::Config->{cpan_home}
833points to a directory where you can write a .lock file. You can set
87892b73
RGS
834this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
835\@INC path;
c356248b 836});
05bab18e
SP
837 return suggest_myconfig;
838 }
839 }
840 my $sleep = 1;
841 while (!flock $fh, LOCK_EX|LOCK_NB) {
842 if ($sleep>10) {
843 $CPAN::Frontend->mydie("Giving up\n");
844 }
845 $CPAN::Frontend->mysleep($sleep++);
846 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
847 }
848
849 seek $fh, 0, 0;
850 truncate $fh, 0;
851 $fh->print($$, "\n");
852 $fh->print(hostname(), "\n");
853 $self->{LOCK} = $lockfile;
854 $self->{LOCKFH} = $fh;
5f05dabc 855 }
6d29edf5 856 $SIG{TERM} = sub {
135a59c2
A
857 my $sig = shift;
858 &cleanup;
859 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
c356248b 860 };
6d29edf5 861 $SIG{INT} = sub {
09d9d230 862 # no blocks!!!
135a59c2
A
863 my $sig = shift;
864 &cleanup if $Signal;
865 die "Got yet another signal" if $Signal > 1;
866 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
867 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
868 $Signal++;
da199366 869 };
911a92db
GS
870
871# From: Larry Wall <larry@wall.org>
872# Subject: Re: deprecating SIGDIE
873# To: perl5-porters@perl.org
874# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
875#
876# The original intent of __DIE__ was only to allow you to substitute one
877# kind of death for another on an application-wide basis without respect
878# to whether you were in an eval or not. As a global backstop, it should
879# not be used any more lightly (or any more heavily :-) than class
880# UNIVERSAL. Any attempt to build a general exception model on it should
881# be politely squashed. Any bug that causes every eval {} to have to be
882# modified should be not so politely squashed.
883#
884# Those are my current opinions. It is also my optinion that polite
885# arguments degenerate to personal arguments far too frequently, and that
886# when they do, it's because both people wanted it to, or at least didn't
887# sufficiently want it not to.
888#
889# Larry
890
6d29edf5
JH
891 # global backstop to cleanup if we should really die
892 $SIG{__DIE__} = \&cleanup;
e50380aa 893 $self->debug("Signal handler set.") if $CPAN::DEBUG;
5f05dabc
PP
894}
895
10b2abe6 896#-> sub CPAN::DESTROY ;
5f05dabc
PP
897sub DESTROY {
898 &cleanup; # need an eval?
899}
900
9d61fa1d
A
901#-> sub CPAN::anycwd ;
902sub anycwd () {
903 my $getcwd;
904 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
905 CPAN->$getcwd();
906}
907
55e314ee
AK
908#-> sub CPAN::cwd ;
909sub cwd {Cwd::cwd();}
910
911#-> sub CPAN::getcwd ;
912sub getcwd {Cwd::getcwd();}
913
ca79d794
SP
914#-> sub CPAN::fastcwd ;
915sub fastcwd {Cwd::fastcwd();}
916
917#-> sub CPAN::backtickcwd ;
918sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
919
607a774b
MS
920#-> sub CPAN::find_perl ;
921sub find_perl {
922 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
0cf35e6a 923 my $pwd = $CPAN::iCwd = CPAN::anycwd();
607a774b
MS
924 my $candidate = File::Spec->catfile($pwd,$^X);
925 $perl ||= $candidate if MM->maybe_command($candidate);
926
927 unless ($perl) {
928 my ($component,$perl_name);
929 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
930 PATH_COMPONENT: foreach $component (File::Spec->path(),
931 $Config::Config{'binexp'}) {
932 next unless defined($component) && $component;
933 my($abs) = File::Spec->catfile($component,$perl_name);
934 if (MM->maybe_command($abs)) {
935 $perl = $abs;
936 last DIST_PERLNAME;
937 }
938 }
939 }
940 }
941
942 return $perl;
943}
944
945
10b2abe6 946#-> sub CPAN::exists ;
5f05dabc
PP
947sub exists {
948 my($mgr,$class,$id) = @_;
e82b9348 949 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
5f05dabc 950 CPAN::Index->reload;
e50380aa 951 ### Carp::croak "exists called without class argument" unless $class;
5f05dabc 952 $id ||= "";
e82b9348 953 $id =~ s/:+/::/g if $class eq "CPAN::Module";
6d29edf5
JH
954 exists $META->{readonly}{$class}{$id} or
955 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
5f05dabc
PP
956}
957
09d9d230
A
958#-> sub CPAN::delete ;
959sub delete {
960 my($mgr,$class,$id) = @_;
6d29edf5
JH
961 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
962 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
09d9d230
A
963}
964
de34a54b
JH
965#-> sub CPAN::has_usable
966# has_inst is sometimes too optimistic, we should replace it with this
967# has_usable whenever a case is given
968sub has_usable {
969 my($self,$mod,$message) = @_;
970 return 1 if $HAS_USABLE->{$mod};
971 my $has_inst = $self->has_inst($mod,$message);
972 return unless $has_inst;
6d29edf5
JH
973 my $usable;
974 $usable = {
975 LWP => [ # we frequently had "Can't locate object
976 # method "new" via package "LWP::UserAgent" at
977 # (eval 69) line 2006
978 sub {require LWP},
979 sub {require LWP::UserAgent},
980 sub {require HTTP::Request},
981 sub {require URI::URL},
982 ],
ec5fee46 983 'Net::FTP' => [
6d29edf5
JH
984 sub {require Net::FTP},
985 sub {require Net::Config},
87892b73
RGS
986 ],
987 'File::HomeDir' => [
988 sub {require File::HomeDir;
6658a91b 989 unless (File::HomeDir::->VERSION >= 0.52){
87892b73 990 for ("Will not use File::HomeDir, need 0.52\n") {
ed84aac9 991 $CPAN::Frontend->mywarn($_);
87892b73
RGS
992 die $_;
993 }
994 }
995 },
996 ],
6d29edf5
JH
997 };
998 if ($usable->{$mod}) {
87892b73
RGS
999 for my $c (0..$#{$usable->{$mod}}) {
1000 my $code = $usable->{$mod}[$c];
1001 my $ret = eval { &$code() };
1002 $ret = "" unless defined $ret;
1003 if ($@) {
1004 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1005 return;
1006 }
de34a54b 1007 }
de34a54b
JH
1008 }
1009 return $HAS_USABLE->{$mod} = 1;
1010}
1011
55e314ee
AK
1012#-> sub CPAN::has_inst
1013sub has_inst {
1014 my($self,$mod,$message) = @_;
1015 Carp::croak("CPAN->has_inst() called without an argument")
1016 unless defined $mod;
4d1321a7
A
1017 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1018 keys %{$CPAN::Config->{dontload_hash}||{}},
1019 @{$CPAN::Config->{dontload_list}||[]};
1020 if (defined $message && $message eq "no" # afair only used by Nox
de34a54b 1021 ||
4d1321a7 1022 $dont{$mod}
de34a54b 1023 ) {
6d29edf5 1024 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
de34a54b 1025 return 0;
55e314ee
AK
1026 }
1027 my $file = $mod;
c356248b 1028 my $obj;
55e314ee 1029 $file =~ s|::|/|g;
55e314ee 1030 $file .= ".pm";
c356248b 1031 if ($INC{$file}) {
f14b5cec
JH
1032 # checking %INC is wrong, because $INC{LWP} may be true
1033 # although $INC{"URI/URL.pm"} may have failed. But as
1034 # I really want to say "bla loaded OK", I have to somehow
1035 # cache results.
1036 ### warn "$file in %INC"; #debug
55e314ee 1037 return 1;
55e314ee 1038 } elsif (eval { require $file }) {
c356248b
AK
1039 # eval is good: if we haven't yet read the database it's
1040 # perfect and if we have installed the module in the meantime,
1041 # it tries again. The second require is only a NOOP returning
1042 # 1 if we had success, otherwise it's retrying
f14b5cec 1043
6a935156
SP
1044 my $v = eval "\$$mod\::VERSION";
1045 $v = $v ? " (v$v)" : "";
1046 $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
c356248b 1047 if ($mod eq "CPAN::WAIT") {
ec5fee46 1048 push @CPAN::Shell::ISA, 'CPAN::WAIT';
c356248b 1049 }
55e314ee
AK
1050 return 1;
1051 } elsif ($mod eq "Net::FTP") {
6d29edf5 1052 $CPAN::Frontend->mywarn(qq{
55e314ee
AK
1053 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1054 if you just type
1055 install Bundle::libnet
5f05dabc 1056
5a5fac02 1057}) unless $Have_warned->{"Net::FTP"}++;
8962fc49 1058 $CPAN::Frontend->mysleep(3);
e82b9348 1059 } elsif ($mod eq "Digest::SHA"){
4d1321a7
A
1060 if ($Have_warned->{"Digest::SHA"}++) {
1061 $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1062 qq{because Digest::SHA not installed.\n});
1063 } else {
8962fc49 1064 $CPAN::Frontend->mywarn(qq{
e82b9348
SP
1065 CPAN: checksum security checks disabled because Digest::SHA not installed.
1066 Please consider installing the Digest::SHA module.
c356248b
AK
1067
1068});
8962fc49 1069 $CPAN::Frontend->mysleep(2);
4d1321a7 1070 }
554a9ef5 1071 } elsif ($mod eq "Module::Signature"){
ed84aac9
A
1072 if (not $CPAN::Config->{check_sigs}) {
1073 # they do not want us:-(
1074 } elsif (not $Have_warned->{"Module::Signature"}++) {
554a9ef5
SP
1075 # No point in complaining unless the user can
1076 # reasonably install and use it.
1077 if (eval { require Crypt::OpenPGP; 1 } ||
ed84aac9
A
1078 (
1079 defined $CPAN::Config->{'gpg'}
1080 &&
1081 $CPAN::Config->{'gpg'} =~ /\S/
1082 )
1083 ) {
8962fc49 1084 $CPAN::Frontend->mywarn(qq{
554a9ef5
SP
1085 CPAN: Module::Signature security checks disabled because Module::Signature
1086 not installed. Please consider installing the Module::Signature module.
1087 You may also need to be able to connect over the Internet to the public
1088 keyservers like pgp.mit.edu (port 11371).
1089
1090});
8962fc49 1091 $CPAN::Frontend->mysleep(2);
554a9ef5
SP
1092 }
1093 }
f14b5cec
JH
1094 } else {
1095 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
05454584 1096 }
55e314ee 1097 return 0;
05454584
AK
1098}
1099
10b2abe6 1100#-> sub CPAN::instance ;
5f05dabc
PP
1101sub instance {
1102 my($mgr,$class,$id) = @_;
1103 CPAN::Index->reload;
5f05dabc 1104 $id ||= "";
6d29edf5
JH
1105 # unsafe meta access, ok?
1106 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1107 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
5f05dabc
PP
1108}
1109
10b2abe6 1110#-> sub CPAN::new ;
5f05dabc
PP
1111sub new {
1112 bless {}, shift;
1113}
1114
10b2abe6 1115#-> sub CPAN::cleanup ;
5f05dabc 1116sub cleanup {
e82b9348 1117 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
2e2b7522
GS
1118 local $SIG{__DIE__} = '';
1119 my($message) = @_;
1120 my $i = 0;
1121 my $ineval = 0;
5fc0f0f6
JH
1122 my($subroutine);
1123 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
2e2b7522
GS
1124 $ineval = 1, last if
1125 $subroutine eq '(eval)';
2e2b7522 1126 }
e82b9348 1127 return if $ineval && !$CPAN::End;
5fc0f0f6
JH
1128 return unless defined $META->{LOCK};
1129 return unless -f $META->{LOCK};
1130 $META->savehist;
1131 unlink $META->{LOCK};
2e2b7522
GS
1132 # require Carp;
1133 # Carp::cluck("DEBUGGING");
6658a91b
SP
1134 if ( $CPAN::CONFIG_DIRTY ) {
1135 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1136 }
8962fc49 1137 $CPAN::Frontend->myprint("Lockfile removed.\n");
5f05dabc
PP
1138}
1139
5fc0f0f6
JH
1140#-> sub CPAN::savehist
1141sub savehist {
1142 my($self) = @_;
1143 my($histfile,$histsize);
1144 unless ($histfile = $CPAN::Config->{'histfile'}){
1145 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1146 return;
1147 }
1148 $histsize = $CPAN::Config->{'histsize'} || 100;
35576f8c
A
1149 if ($CPAN::term){
1150 unless ($CPAN::term->can("GetHistory")) {
1151 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1152 return;
1153 }
1154 } else {
5fc0f0f6
JH
1155 return;
1156 }
1157 my @h = $CPAN::term->GetHistory;
1158 splice @h, 0, @h-$histsize if @h>$histsize;
1159 my($fh) = FileHandle->new;
35576f8c 1160 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
5fc0f0f6
JH
1161 local $\ = local $, = "\n";
1162 print $fh @h;
1163 close $fh;
1164}
1165
6658a91b 1166#-> sub CPAN::is_tested
4c070e31
IZ
1167sub is_tested {
1168 my($self,$what) = @_;
1169 $self->{is_tested}{$what} = 1;
1170}
1171
6658a91b 1172#-> sub CPAN::is_installed
135a59c2
A
1173# unsets the is_tested flag: as soon as the thing is installed, it is
1174# not needed in set_perl5lib anymore
4c070e31
IZ
1175sub is_installed {
1176 my($self,$what) = @_;
1177 delete $self->{is_tested}{$what};
1178}
1179
6658a91b 1180#-> sub CPAN::set_perl5lib
4c070e31 1181sub set_perl5lib {
6658a91b
SP
1182 my($self,$for) = @_;
1183 unless ($for) {
1184 (undef,undef,undef,$for) = caller(1);
1185 $for =~ s/.*://;
1186 }
0362b508 1187 $self->{is_tested} ||= {};
4c070e31
IZ
1188 return unless %{$self->{is_tested}};
1189 my $env = $ENV{PERL5LIB};
1190 $env = $ENV{PERLLIB} unless defined $env;
1191 my @env;
1192 push @env, $env if defined $env and length $env;
6658a91b
SP
1193 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1194 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1195 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}};
1196 if (@dirs < 15) {
1197 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\n");
1198 } else {
1199 my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
1200 sort keys %{$self->{is_tested}};
1201 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ".
1202 "@d to PERL5LIB; ".
1203 "%BUILDDIR%=$CPAN::Config->{'build_dir'} ".
1204 "for $for\n"
1205 );
1206 }
1207
4c070e31
IZ
1208 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1209}
1210
05454584 1211package CPAN::CacheMgr;
e82b9348 1212use strict;
5f05dabc 1213
05454584
AK
1214#-> sub CPAN::CacheMgr::as_string ;
1215sub as_string {
1216 eval { require Data::Dumper };
1217 if ($@) {
1218 return shift->SUPER::as_string;
5f05dabc 1219 } else {
05454584 1220 return Data::Dumper::Dumper(shift);
5f05dabc
PP
1221 }
1222}
1223
05454584
AK
1224#-> sub CPAN::CacheMgr::cachesize ;
1225sub cachesize {
1226 shift->{DU};
5f05dabc 1227}
5f05dabc 1228
c4d24d4c 1229#-> sub CPAN::CacheMgr::tidyup ;
09d9d230
A
1230sub tidyup {
1231 my($self) = @_;
1232 return unless -d $self->{ID};
1233 while ($self->{DU} > $self->{'MAX'} ) {
1234 my($toremove) = shift @{$self->{FIFO}};
1235 $CPAN::Frontend->myprint(sprintf(
1236 "Deleting from cache".
1237 ": $toremove (%.1f>%.1f MB)\n",
1238 $self->{DU}, $self->{'MAX'})
1239 );
1240 return if $CPAN::Signal;
1241 $self->force_clean_cache($toremove);
1242 return if $CPAN::Signal;
1243 }
1244}
5f05dabc 1245
05454584
AK
1246#-> sub CPAN::CacheMgr::dir ;
1247sub dir {
1248 shift->{ID};
1249}
1250
1251#-> sub CPAN::CacheMgr::entries ;
1252sub entries {
1253 my($self,$dir) = @_;
55e314ee 1254 return unless defined $dir;
e50380aa 1255 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
05454584 1256 $dir ||= $self->{ID};
9d61fa1d 1257 my($cwd) = CPAN::anycwd();
05454584 1258 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
f14b5cec
JH
1259 my $dh = DirHandle->new(File::Spec->curdir)
1260 or Carp::croak("Couldn't opendir $dir: $!");
05454584
AK
1261 my(@entries);
1262 for ($dh->read) {
1263 next if $_ eq "." || $_ eq "..";
1264 if (-f $_) {
5de3f0da 1265 push @entries, File::Spec->catfile($dir,$_);
05454584 1266 } elsif (-d _) {
5de3f0da 1267 push @entries, File::Spec->catdir($dir,$_);
5f05dabc 1268 } else {
c356248b 1269 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
5f05dabc 1270 }
5f05dabc 1271 }
05454584 1272 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
e50380aa 1273 sort { -M $b <=> -M $a} @entries;
5f05dabc
PP
1274}
1275
05454584
AK
1276#-> sub CPAN::CacheMgr::disk_usage ;
1277sub disk_usage {
1278 my($self,$dir) = @_;
09d9d230
A
1279 return if exists $self->{SIZE}{$dir};
1280 return if $CPAN::Signal;
1281 my($Du) = 0;
c9869e1c
SP
1282 if (-e $dir) {
1283 unless (-x $dir) {
1284 unless (chmod 0755, $dir) {
1285 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1286 "permission to change the permission; cannot ".
1287 "estimate disk usage of '$dir'\n");
1288 $CPAN::Frontend->mysleep(5);
1289 return;
1290 }
1291 }
1292 } else {
1293 $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
0cf35e6a 1294 return;
0cf35e6a 1295 }
05454584 1296 find(
0cf35e6a
SP
1297 sub {
1298 $File::Find::prune++ if $CPAN::Signal;
1299 return if -l $_;
1300 if ($^O eq 'MacOS') {
1301 require Mac::Files;
1302 my $cat = Mac::Files::FSpGetCatInfo($_);
1303 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1304 } else {
1305 if (-d _) {
1306 unless (-x _) {
1307 unless (chmod 0755, $_) {
1308 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1309 "the permission to change the permission; ".
1310 "can only partially estimate disk usage ".
1311 "of '$_'\n");
8962fc49 1312 $CPAN::Frontend->mysleep(5);
0cf35e6a
SP
1313 return;
1314 }
1315 }
1316 } else {
1317 $Du += (-s _);
1318 }
1319 }
1320 },
1321 $dir
1322 );
09d9d230 1323 return if $CPAN::Signal;
05454584
AK
1324 $self->{SIZE}{$dir} = $Du/1024/1024;
1325 push @{$self->{FIFO}}, $dir;
1326 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1327 $self->{DU} += $Du/1024/1024;
05454584 1328 $self->{DU};
5f05dabc
PP
1329}
1330
05454584
AK
1331#-> sub CPAN::CacheMgr::force_clean_cache ;
1332sub force_clean_cache {
1333 my($self,$dir) = @_;
09d9d230 1334 return unless -e $dir;
05454584
AK
1335 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1336 if $CPAN::DEBUG;
1337 File::Path::rmtree($dir);
05bab18e 1338 unlink "$dir.yml"; # may fail
05454584
AK
1339 $self->{DU} -= $self->{SIZE}{$dir};
1340 delete $self->{SIZE}{$dir};
5f05dabc
PP
1341}
1342
05454584
AK
1343#-> sub CPAN::CacheMgr::new ;
1344sub new {
1345 my $class = shift;
e50380aa
AK
1346 my $time = time;
1347 my($debug,$t2);
1348 $debug = "";
05454584
AK
1349 my $self = {
1350 ID => $CPAN::Config->{'build_dir'},
1351 MAX => $CPAN::Config->{'build_cache'},
f610777f 1352 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
05454584
AK
1353 DU => 0
1354 };
1355 File::Path::mkpath($self->{ID});
1356 my $dh = DirHandle->new($self->{ID});
1357 bless $self, $class;
f610777f
A
1358 $self->scan_cache;
1359 $t2 = time;
1360 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1361 $time = $t2;
1362 CPAN->debug($debug) if $CPAN::DEBUG;
1363 $self;
1364}
1365
1366#-> sub CPAN::CacheMgr::scan_cache ;
1367sub scan_cache {
1368 my $self = shift;
1369 return if $self->{SCAN} eq 'never';
1370 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1371 unless $self->{SCAN} eq 'atstart';
09d9d230
A
1372 $CPAN::Frontend->myprint(
1373 sprintf("Scanning cache %s for sizes\n",
1374 $self->{ID}));
f610777f 1375 my $e;
09d9d230 1376 for $e ($self->entries($self->{ID})) {
05454584 1377 next if $e eq ".." || $e eq ".";
05454584 1378 $self->disk_usage($e);
09d9d230 1379 return if $CPAN::Signal;
5f05dabc 1380 }
09d9d230 1381 $self->tidyup;
5f05dabc
PP
1382}
1383
05454584 1384package CPAN::Shell;
e82b9348 1385use strict;
5f05dabc 1386
05454584
AK
1387#-> sub CPAN::Shell::h ;
1388sub h {
1389 my($class,$about) = @_;
1390 if (defined $about) {
c356248b 1391 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
05454584 1392 } else {
9ddc4ed0
A
1393 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1394 $CPAN::Frontend->myprint(qq{
1395Display Information $filler (ver $CPAN::VERSION)
c049f953
JH
1396 command argument description
1397 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
6a94b120 1398 i WORD or /REGEXP/ about any of the above
0cf35e6a 1399 ls AUTHOR or GLOB about files in the author's directory
ec5fee46
A
1400 (with WORD being a module, bundle or author name or a distribution
1401 name of the form AUTHOR/DISTRIBUTION)
911a92db
GS
1402
1403Download, Test, Make, Install...
ec5fee46
A
1404 get download clean make clean
1405 make make (implies get) look open subshell in dist directory
1406 test make test (implies make) readme display these README files
1407 install make install (implies test) perldoc display POD documentation
1408
135a59c2
A
1409Upgrade
1410 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1411 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1412
ec5fee46
A
1413Pragmas
1414 force COMMAND unconditionally do command
1415 notest COMMAND skip testing
911a92db
GS
1416
1417Other
1418 h,? display this menu ! perl-code eval a perl command
1419 o conf [opt] set and query options q quit the cpan shell
1420 reload cpan load CPAN.pm again reload index load newer indices
ec5fee46 1421 autobundle Snapshot recent latest CPAN uploads});
135a59c2 1422}
05454584 1423}
da199366 1424
09d9d230
A
1425*help = \&h;
1426
05454584 1427#-> sub CPAN::Shell::a ;
de34a54b
JH
1428sub a {
1429 my($self,@arg) = @_;
1430 # authors are always UPPERCASE
1431 for (@arg) {
c049f953 1432 $_ = uc $_ unless /=/;
de34a54b
JH
1433 }
1434 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1435}
6d29edf5 1436
ca79d794
SP
1437#-> sub CPAN::Shell::globls ;
1438sub globls {
1439 my($self,$s,$pragmas) = @_;
0cf35e6a
SP
1440 # ls is really very different, but we had it once as an ordinary
1441 # command in the Shell (upto rev. 321) and we could not handle
1442 # force well then
e82b9348 1443 my(@accept,@preexpand);
0cf35e6a
SP
1444 if ($s =~ /[\*\?\/]/) {
1445 if ($CPAN::META->has_inst("Text::Glob")) {
1446 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1447 my $rau = Text::Glob::glob_to_regex(uc $au);
1448 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1449 if $CPAN::DEBUG;
1450 push @preexpand, map { $_->id . "/" . $pathglob }
1451 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
e82b9348 1452 } else {
0cf35e6a
SP
1453 my $rau = Text::Glob::glob_to_regex(uc $s);
1454 push @preexpand, map { $_->id }
1455 CPAN::Shell->expand_by_method('CPAN::Author',
1456 ['id'],
1457 "/$rau/");
e82b9348
SP
1458 }
1459 } else {
0cf35e6a 1460 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
e82b9348 1461 }
0cf35e6a
SP
1462 } else {
1463 push @preexpand, uc $s;
554a9ef5 1464 }
e82b9348
SP
1465 for (@preexpand) {
1466 unless (/^[A-Z0-9\-]+(\/|$)/i) {
5fc0f0f6 1467 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
c049f953
JH
1468 next;
1469 }
e82b9348 1470 push @accept, $_;
8d97e4a1 1471 }
554a9ef5
SP
1472 my $silent = @accept>1;
1473 my $last_alpha = "";
ca79d794 1474 my @results;
c049f953 1475 for my $a (@accept){
e82b9348
SP
1476 my($author,$pathglob);
1477 if ($a =~ m|(.*?)/(.*)|) {
1478 my $a2 = $1;
1479 $pathglob = $2;
0cf35e6a
SP
1480 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1481 ['id'],
1482 $a2) or die "No author found for $a2";
e82b9348 1483 } else {
0cf35e6a
SP
1484 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1485 ['id'],
1486 $a) or die "No author found for $a";
e82b9348 1487 }
554a9ef5 1488 if ($silent) {
e82b9348 1489 my $alpha = substr $author->id, 0, 1;
554a9ef5 1490 my $ad;
e82b9348
SP
1491 if ($alpha eq $last_alpha) {
1492 $ad = "";
554a9ef5 1493 } else {
e82b9348
SP
1494 $ad = "[$alpha]";
1495 $last_alpha = $alpha;
554a9ef5
SP
1496 }
1497 $CPAN::Frontend->myprint($ad);
1498 }
9ddc4ed0
A
1499 for my $pragma (@$pragmas) {
1500 if ($author->can($pragma)) {
1501 $author->$pragma();
1502 }
1503 }
ca79d794
SP
1504 push @results, $author->ls($pathglob,$silent); # silent if
1505 # more than one
1506 # author
9ddc4ed0 1507 for my $pragma (@$pragmas) {
05bab18e
SP
1508 my $unpragma = "un$pragma";
1509 if ($author->can($unpragma)) {
1510 $author->$unpragma();
9ddc4ed0
A
1511 }
1512 }
8d97e4a1 1513 }
ca79d794 1514 @results;
8d97e4a1 1515}
6d29edf5 1516
8d97e4a1 1517#-> sub CPAN::Shell::local_bundles ;
6d29edf5 1518sub local_bundles {
05454584 1519 my($self,@which) = @_;
55e314ee 1520 my($incdir,$bdir,$dh);
05454584 1521 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8d97e4a1
JH
1522 my @bbase = "Bundle";
1523 while (my $bbase = shift @bbase) {
5de3f0da 1524 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
8d97e4a1
JH
1525 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1526 if ($dh = DirHandle->new($bdir)) { # may fail
1527 my($entry);
1528 for $entry ($dh->read) {
c049f953 1529 next if $entry =~ /^\./;
b96578bb 1530 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
5de3f0da 1531 if (-d File::Spec->catdir($bdir,$entry)){
8d97e4a1
JH
1532 push @bbase, "$bbase\::$entry";
1533 } else {
1534 next unless $entry =~ s/\.pm(?!\n)\Z//;
1535 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1536 }
1537 }
1538 }
1539 }
05454584 1540 }
6d29edf5
JH
1541}
1542
1543#-> sub CPAN::Shell::b ;
1544sub b {
1545 my($self,@which) = @_;
1546 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1547 $self->local_bundles;
c356248b 1548 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
05454584 1549}
6d29edf5 1550
05454584 1551#-> sub CPAN::Shell::d ;
c356248b 1552sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
6d29edf5 1553
05454584 1554#-> sub CPAN::Shell::m ;
f610777f 1555sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
35576f8c
A
1556 my $self = shift;
1557 $CPAN::Frontend->myprint($self->format_result('Module',@_));
f610777f 1558}
da199366 1559
05454584
AK
1560#-> sub CPAN::Shell::i ;
1561sub i {
1562 my($self) = shift;
1563 my(@args) = @_;
05454584
AK
1564 @args = '/./' unless @args;
1565 my(@result);
190aa835 1566 for my $type (qw/Bundle Distribution Module/) {
05454584
AK
1567 push @result, $self->expand($type,@args);
1568 }
190aa835
MS
1569 # Authors are always uppercase.
1570 push @result, $self->expand("Author", map { uc $_ } @args);
1571
8d97e4a1 1572 my $result = @result == 1 ?
05454584 1573 $result[0]->as_string :
8d97e4a1
JH
1574 @result == 0 ?
1575 "No objects found of any type for argument @args\n" :
1576 join("",
1577 (map {$_->as_glimpse} @result),
1578 scalar @result, " items found\n",
1579 );
c356248b 1580 $CPAN::Frontend->myprint($result);
da199366 1581}
da199366 1582
05454584 1583#-> sub CPAN::Shell::o ;
5e05dca5 1584
8962fc49
SP
1585# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1586# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
135a59c2
A
1587# probably have been called 'set' and 'o debug' maybe 'set debug' or
1588# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
05454584
AK
1589sub o {
1590 my($self,$o_type,@o_what) = @_;
1591 $o_type ||= "";
1592 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1593 if ($o_type eq 'conf') {
5e05dca5 1594 if (!@o_what) { # print all things, "o conf"
05454584 1595 my($k,$v);
ed84aac9
A
1596 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1597 my @from;
09d9d230 1598 if (exists $INC{'CPAN/Config.pm'}) {
ed84aac9 1599 push @from, $INC{'CPAN/Config.pm'};
09d9d230
A
1600 }
1601 if (exists $INC{'CPAN/MyConfig.pm'}) {
ed84aac9 1602 push @from, $INC{'CPAN/MyConfig.pm'};
09d9d230 1603 }
ed84aac9 1604 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
09d9d230 1605 $CPAN::Frontend->myprint(":\n");
e82b9348
SP
1606 for $k (sort keys %CPAN::HandleConfig::can) {
1607 $v = $CPAN::HandleConfig::can{$k};
554a9ef5 1608 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
05454584 1609 }
c356248b 1610 $CPAN::Frontend->myprint("\n");
05454584 1611 for $k (sort keys %$CPAN::Config) {
e82b9348 1612 CPAN::HandleConfig->prettyprint($k);
10b2abe6 1613 }
c356248b 1614 $CPAN::Frontend->myprint("\n");
05bab18e
SP
1615 } else {
1616 if (CPAN::HandleConfig->edit(@o_what)) {
1617 unless ($o_what[0] eq "init") {
1618 $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
1619 "make the config permanent!\n\n");
1620 }
1621 } else {
1622 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1623 qq{items\n\n});
1624 }
5f05dabc 1625 }
05454584
AK
1626 } elsif ($o_type eq 'debug') {
1627 my(%valid);
1628 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1629 if (@o_what) {
1630 while (@o_what) {
1631 my($what) = shift @o_what;
8d97e4a1
JH
1632 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1633 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1634 next;
1635 }
05454584
AK
1636 if ( exists $CPAN::DEBUG{$what} ) {
1637 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1638 } elsif ($what =~ /^\d/) {
1639 $CPAN::DEBUG = $what;
1640 } elsif (lc $what eq 'all') {
1641 my($max) = 0;
1642 for (values %CPAN::DEBUG) {
1643 $max += $_;
10b2abe6 1644 }
05454584 1645 $CPAN::DEBUG = $max;
10b2abe6 1646 } else {
d4fd5c69 1647 my($known) = 0;
05454584
AK
1648 for (keys %CPAN::DEBUG) {
1649 next unless lc($_) eq lc($what);
1650 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
d4fd5c69 1651 $known = 1;
10b2abe6 1652 }
c356248b
AK
1653 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1654 unless $known;
10b2abe6
CS
1655 }
1656 }
05454584 1657 } else {
911a92db
GS
1658 my $raw = "Valid options for debug are ".
1659 join(", ",sort(keys %CPAN::DEBUG), 'all').
1660 qq{ or a number. Completion works on the options. }.
1661 qq{Case is ignored.};
1662 require Text::Wrap;
1663 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1664 $CPAN::Frontend->myprint("\n\n");
05454584
AK
1665 }
1666 if ($CPAN::DEBUG) {
7d97ad34 1667 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
05454584
AK
1668 my($k,$v);
1669 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1670 $v = $CPAN::DEBUG{$k};
05d2a450
A
1671 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1672 if $v & $CPAN::DEBUG;
05454584
AK
1673 }
1674 } else {
c356248b 1675 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
10b2abe6 1676 }
05454584 1677 } else {
c356248b 1678 $CPAN::Frontend->myprint(qq{
05454584
AK
1679Known options:
1680 conf set or get configuration variables
1681 debug set or get debugging options
c356248b 1682});
5f05dabc 1683 }
5f05dabc
PP
1684}
1685
6a935156 1686# CPAN::Shell::paintdots_onreload
6d29edf5 1687sub paintdots_onreload {
36263cb3
GS
1688 my($ref) = shift;
1689 sub {
5fc0f0f6 1690 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
36263cb3
GS
1691 my($subr) = $1;
1692 ++$$ref;
1693 local($|) = 1;
1694 # $CPAN::Frontend->myprint(".($subr)");
1695 $CPAN::Frontend->myprint(".");
6a935156
SP
1696 if ($subr =~ /\bshell\b/i) {
1697 # warn "debug[$_[0]]";
1698
1699 # It would be nice if we could detect that a
1700 # subroutine has actually changed, but for now we
1701 # practically always set the GOTOSHELL global
1702
1703 $CPAN::GOTOSHELL=1;
1704 }
36263cb3
GS
1705 return;
1706 }
1707 warn @_;
1708 };
1709}
1710
05bab18e
SP
1711#-> sub CPAN::Shell::hosts ;
1712sub hosts {
1713 my($self) = @_;
1714 my $fullstats = CPAN::FTP->_ftp_statistics();
1715 my $history = $fullstats->{history} || [];
1716 my %S; # statistics
1717 while (my $last = pop @$history) {
1718 my $attempts = $last->{attempts} or next;
1719 my $start;
1720 if (@$attempts) {
1721 $start = $attempts->[-1]{start};
1722 if ($#$attempts > 0) {
1723 for my $i (0..$#$attempts-1) {
1724 my $url = $attempts->[$i]{url} or next;
1725 $S{no}{$url}++;
1726 }
1727 }
1728 } else {
1729 $start = $last->{start};
1730 }
1731 next unless $last->{thesiteurl}; # C-C? bad filenames?
1732 $S{start} = $start;
1733 $S{end} ||= $last->{end};
1734 my $dltime = $last->{end} - $start;
1735 my $dlsize = $last->{filesize} || 0;
1736 my $url = $last->{thesiteurl}->text;
1737 my $s = $S{ok}{$url} ||= {};
1738 $s->{n}++;
1739 $s->{dlsize} ||= 0;
1740 $s->{dlsize} += $dlsize/1024;
1741 $s->{dltime} ||= 0;
1742 $s->{dltime} += $dltime;
1743 }
1744 my $res;
1745 for my $url (keys %{$S{ok}}) {
1746 next if $S{ok}{$url}{dltime} == 0; # div by zero
1747 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1748 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1749 $url,
1750 ];
1751 }
1752 for my $url (keys %{$S{no}}) {
1753 push @{$res->{no}}, [$S{no}{$url},
1754 $url,
1755 ];
1756 }
1757 my $R = ""; # report
1758 $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown";
1759 $R .= sprintf "Log ends : %s\n", scalar(localtime $S{end}) || "unknown";
1760 if ($res->{ok} && @{$res->{ok}}) {
1761 $R .= sprintf "\nSuccessful downloads:
1762 N kB secs kB/s url\n";
1763 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1764 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1765 }
1766 }
1767 if ($res->{no} && @{$res->{no}}) {
1768 $R .= sprintf "\nUnsuccessful downloads:\n";
1769 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1770 $R .= sprintf "%4d %s\n", @$_;
1771 }
1772 }
1773 $CPAN::Frontend->myprint($R);
1774}
1775
05454584
AK
1776#-> sub CPAN::Shell::reload ;
1777sub reload {
d4fd5c69
AK
1778 my($self,$command,@arg) = @_;
1779 $command ||= "";
1780 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
135a59c2 1781 if ($command =~ /^cpan$/i) {
e82b9348 1782 my $redef = 0;
0cf35e6a
SP
1783 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1784 my $failed;
8962fc49
SP
1785 my @relo = (
1786 "CPAN.pm",
1787 "CPAN/HandleConfig.pm",
1788 "CPAN/FirstTime.pm",
1789 "CPAN/Tarzip.pm",
1790 "CPAN/Debug.pm",
1791 "CPAN/Version.pm",
135a59c2
A
1792 "CPAN/Queue.pm",
1793 "CPAN/Reporter.pm",
8962fc49 1794 );
8962fc49 1795 MFILE: for my $f (@relo) {
135a59c2
A
1796 next unless exists $INC{$f};
1797 my $p = $f;
1798 $p =~ s/\.pm$//;
1799 $p =~ s|/|::|g;
1800 $CPAN::Frontend->myprint("($p");
5fc0f0f6 1801 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
c9869e1c 1802 $self->reload_this($f) or $failed++;
135a59c2
A
1803 my $v = eval "$p\::->VERSION";
1804 $CPAN::Frontend->myprint("v$v)");
5fc0f0f6 1805 }
e82b9348 1806 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
0cf35e6a 1807 if ($failed) {
135a59c2
A
1808 my $errors = $failed == 1 ? "error" : "errors";
1809 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
0cf35e6a
SP
1810 "this session.\n");
1811 }
135a59c2 1812 } elsif ($command =~ /^index$/i) {
2e2b7522 1813 CPAN::Index->force_reload;
d4fd5c69 1814 } else {
135a59c2 1815 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
f14b5cec 1816index re-reads the index files\n});
05454584
AK
1817 }
1818}
1819
2ccf00a7
SP
1820# reload means only load again what we have loaded before
1821#-> sub CPAN::Shell::reload_this ;
c9869e1c 1822sub reload_this {
6a935156 1823 my($self,$f,$args) = @_;
7d97ad34 1824 CPAN->debug("f[$f]") if $CPAN::DEBUG;
2ccf00a7
SP
1825 return 1 unless $INC{$f}; # we never loaded this, so we do not
1826 # reload but say OK
c9869e1c 1827 my $pwd = CPAN::anycwd();
7d97ad34
SP
1828 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1829 my($file);
c9869e1c 1830 for my $inc (@INC) {
7d97ad34
SP
1831 $file = File::Spec->catfile($inc,split /\//, $f);
1832 last if -f $file;
1833 $file = "";
1834 }
1835 CPAN->debug("file[$file]") if $CPAN::DEBUG;
1836 my @inc = @INC;
1837 unless ($file && -f $file) {
1838 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1839 $file = $INC{$f};
6658a91b
SP
1840 unless (CPAN->has_inst("File::Basename")) {
1841 @inc = File::Basename::dirname($file);
1842 } else {
1843 # do we ever need this?
1844 @inc = substr($file,0,-length($f)-1); # bring in back to me!
1845 }
7d97ad34
SP
1846 }
1847 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1848 unless (-f $file) {
c9869e1c
SP
1849 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1850 return;
1851 }
6a935156
SP
1852 my $mtime = (stat $file)[9];
1853 $reload->{$f} ||= $^T;
1854 my $must_reload = $mtime > $reload->{$f};
1855 $args ||= {};
1856 $must_reload ||= $args->{force};
1857 if ($must_reload) {
1858 my $fh = FileHandle->new($file) or
1859 $CPAN::Frontend->mydie("Could not open $file: $!");
1860 local($/);
1861 local $^W = 1;
1862 my $content = <$fh>;
1863 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1864 if $CPAN::DEBUG;
1865 delete $INC{$f};
1866 local @INC = @inc;
1867 eval "require '$f'";
1868 if ($@){
1869 warn $@;
1870 return;
1871 }
1872 $reload->{$f} = time;
1873 } else {
1874 $CPAN::Frontend->myprint("__unchanged__");
c9869e1c
SP
1875 }
1876 return 1;
1877}
1878
44d21104
A
1879#-> sub CPAN::Shell::mkmyconfig ;
1880sub mkmyconfig {
1881 my($self, $cpanpm, %args) = @_;
1882 require CPAN::FirstTime;
87892b73
RGS
1883 my $home = CPAN::HandleConfig::home;
1884 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1885 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
44d21104 1886 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
87892b73 1887 CPAN::HandleConfig::require_myconfig_or_config;
44d21104
A
1888 $CPAN::Config ||= {};
1889 $CPAN::Config = {
1890 %$CPAN::Config,
1891 build_dir => undef,
1892 cpan_home => undef,
1893 keep_source_where => undef,
1894 histfile => undef,
1895 };
1896 CPAN::FirstTime::init($cpanpm, %args);
1897}
1898
05454584
AK
1899#-> sub CPAN::Shell::_binary_extensions ;
1900sub _binary_extensions {
1901 my($self) = shift @_;
1902 my(@result,$module,%seen,%need,$headerdone);
1903 for $module ($self->expand('Module','/./')) {
1904 my $file = $module->cpan_file;
1905 next if $file eq "N/A";
1906 next if $file =~ /^Contact Author/;
05d2a450
A
1907 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1908 next if $dist->isa_perl;
05454584
AK
1909 next unless $module->xs_file;
1910 local($|) = 1;
c356248b 1911 $CPAN::Frontend->myprint(".");
05454584
AK
1912 push @result, $module;
1913 }
1914# print join " | ", @result;
c356248b 1915 $CPAN::Frontend->myprint("\n");
05454584
AK
1916 return @result;
1917}
1918
1919#-> sub CPAN::Shell::recompile ;
1920sub recompile {
1921 my($self) = shift @_;
1922 my($module,@module,$cpan_file,%dist);
1923 @module = $self->_binary_extensions();
c356248b
AK
1924 for $module (@module){ # we force now and compile later, so we
1925 # don't do it twice
05454584
AK
1926 $cpan_file = $module->cpan_file;
1927 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1928 $pack->force;
1929 $dist{$cpan_file}++;
1930 }
1931 for $cpan_file (sort keys %dist) {
c356248b 1932 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
05454584
AK
1933 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1934 $pack->install;
1935 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1936 # stop a package from recompiling,
1937 # e.g. IO-1.12 when we have perl5.003_10
1938 }
1939}
1940
ed84aac9
A
1941#-> sub CPAN::Shell::scripts ;
1942sub scripts {
1943 my($self, $arg) = @_;
1944 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1945
8962fc49
SP
1946 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1947 unless ($CPAN::META->has_inst($req)) {
1948 $CPAN::Frontend->mywarn(" $req not available\n");
1949 }
1950 }
ed84aac9
A
1951 my $p = HTML::LinkExtor->new();
1952 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1953 unless (-f $indexfile) {
1954 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1955 }
1956 $p->parse_file($indexfile);
1957 my @hrefs;
1958 my $qrarg;
1959 if ($arg =~ s|^/(.+)/$|$1|) {
8962fc49 1960 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
ed84aac9
A
1961 }
1962 for my $l ($p->links) {
1963 my $tag = shift @$l;
1964 next unless $tag eq "a";
1965 my %att = @$l;
1966 my $href = $att{href};
1967 next unless $href =~ s|^\.\./authors/id/./../||;
1968 if ($arg) {
1969 if ($qrarg) {
1970 if ($href =~ $qrarg) {
1971 push @hrefs, $href;
1972 }
1973 } else {
1974 if ($href =~ /\Q$arg\E/) {
1975 push @hrefs, $href;
1976 }
1977 }
1978 } else {
1979 push @hrefs, $href;
1980 }
1981 }
1982 # now filter for the latest version if there is more than one of a name
1983 my %stems;
1984 for (sort @hrefs) {
1985 my $href = $_;
1986 s/-v?\d.*//;
1987 my $stem = $_;
1988 $stems{$stem} ||= [];
1989 push @{$stems{$stem}}, $href;
1990 }
1991 for (sort keys %stems) {
1992 my $highest;
1993 if (@{$stems{$_}} > 1) {
1994 $highest = List::Util::reduce {
1995 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1996 } @{$stems{$_}};
1997 } else {
1998 $highest = $stems{$_}[0];
1999 }
2000 $CPAN::Frontend->myprint("$highest\n");
2001 }
2002}
2003
8fc516fe
SP
2004#-> sub CPAN::Shell::report ;
2005sub report {
2006 my($self,@args) = @_;
2007 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2008 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2009 }
2010 local $CPAN::Config->{test_report} = 1;
6658a91b
SP
2011 $self->force("test",@args); # force is there so that the test be
2012 # re-run (as documented)
8fc516fe
SP
2013}
2014
05bab18e
SP
2015#-> sub CPAN::Shell::install_tested
2016sub install_tested {
2017 my($self,@some) = @_;
2018 $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
2019 return if @some;
2020 CPAN::Index->reload;
2021
2022 for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) {
2023 my $do = CPAN::Shell->expandany($d);
2024 next unless $do->{build_dir};
2025 push @some, $do;
2026 }
2027
2028 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2029 return unless @some;
2030
2031 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2032 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2033 return unless @some;
2034
2035 @some = grep { not $_->uptodate } @some;
2036 $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2037 return unless @some;
2038
2039 CPAN->debug("some[@some]");
2040 for my $d (@some) {
2041 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2042 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2043 $CPAN::Frontend->sleep(1);
2044 $self->install($d);
2045 }
2046}
2047
ed84aac9
A
2048#-> sub CPAN::Shell::upgrade ;
2049sub upgrade {
135a59c2
A
2050 my($self,@args) = @_;
2051 $self->install($self->r(@args));
ed84aac9
A
2052}
2053
05454584
AK
2054#-> sub CPAN::Shell::_u_r_common ;
2055sub _u_r_common {
2056 my($self) = shift @_;
2057 my($what) = shift @_;
2058 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
c4d24d4c
A
2059 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2060 $what && $what =~ /^[aru]$/;
05454584
AK
2061 my(@args) = @_;
2062 @args = '/./' unless @args;
c356248b
AK
2063 my(@result,$module,%seen,%need,$headerdone,
2064 $version_undefs,$version_zeroes);
2065 $version_undefs = $version_zeroes = 0;
9d61fa1d 2066 my $sprintf = "%s%-25s%s %9s %9s %s\n";
6d29edf5
JH
2067 my @expand = $self->expand('Module',@args);
2068 my $expand = scalar @expand;
2069 if (0) { # Looks like noise to me, was very useful for debugging
2070 # for metadata cache
2071 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2072 }
554a9ef5 2073 MODULE: for $module (@expand) {
05454584 2074 my $file = $module->cpan_file;
554a9ef5 2075 next MODULE unless defined $file; # ??
e82b9348 2076 $file =~ s|^./../||;
6d29edf5 2077 my($latest) = $module->cpan_version;
05454584
AK
2078 my($inst_file) = $module->inst_file;
2079 my($have);
09d9d230 2080 return if $CPAN::Signal;
05454584
AK
2081 if ($inst_file){
2082 if ($what eq "a") {
6d29edf5 2083 $have = $module->inst_version;
05454584 2084 } elsif ($what eq "r") {
6d29edf5 2085 $have = $module->inst_version;
05454584 2086 local($^W) = 0;
c356248b
AK
2087 if ($have eq "undef"){
2088 $version_undefs++;
2089 } elsif ($have == 0){
2090 $version_zeroes++;
2091 }
554a9ef5 2092 next MODULE unless CPAN::Version->vgt($latest, $have);
c356248b
AK
2093# to be pedantic we should probably say:
2094# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2095# to catch the case where CPAN has a version 0 and we have a version undef
05454584 2096 } elsif ($what eq "u") {
554a9ef5 2097 next MODULE;
05454584
AK
2098 }
2099 } else {
2100 if ($what eq "a") {
554a9ef5 2101 next MODULE;
05454584 2102 } elsif ($what eq "r") {
554a9ef5 2103 next MODULE;
05454584
AK
2104 } elsif ($what eq "u") {
2105 $have = "-";
2106 }
2107 }
2108 return if $CPAN::Signal; # this is sometimes lengthy
2109 $seen{$file} ||= 0;
2110 if ($what eq "a") {
2111 push @result, sprintf "%s %s\n", $module->id, $have;
2112 } elsif ($what eq "r") {
2113 push @result, $module->id;
f3fe0ae6 2114 next MODULE if $seen{$file}++;
05454584
AK
2115 } elsif ($what eq "u") {
2116 push @result, $module->id;
f3fe0ae6
NC
2117 next MODULE if $seen{$file}++;
2118 next MODULE if $file =~ /^Contact/;
05454584
AK
2119 }
2120 unless ($headerdone++){
c356248b
AK
2121 $CPAN::Frontend->myprint("\n");
2122 $CPAN::Frontend->myprint(sprintf(
9d61fa1d
A
2123 $sprintf,
2124 "",
2125 "Package namespace",
2126 "",
2127 "installed",
2128 "latest",
2129 "in CPAN file"
2130 ));
05454584 2131 }
9d61fa1d
A
2132 my $color_on = "";
2133 my $color_off = "";
2134 if (
2135 $COLOR_REGISTERED
2136 &&
2137 $CPAN::META->has_inst("Term::ANSIColor")
2138 &&
0cf35e6a 2139 $module->description
9d61fa1d
A
2140 ) {
2141 $color_on = Term::ANSIColor::color("green");
2142 $color_off = Term::ANSIColor::color("reset");
2143 }
05d2a450 2144 $CPAN::Frontend->myprint(sprintf $sprintf,
9d61fa1d 2145 $color_on,
05d2a450 2146 $module->id,
9d61fa1d 2147 $color_off,
05d2a450
A
2148 $have,
2149 $latest,
2150 $file);
05454584
AK
2151 $need{$module->id}++;
2152 }
2153 unless (%need) {
2154 if ($what eq "u") {
c356248b 2155 $CPAN::Frontend->myprint("No modules found for @args\n");
05454584 2156 } elsif ($what eq "r") {
c356248b 2157 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
05454584
AK
2158 }
2159 }
c356248b
AK
2160 if ($what eq "r") {
2161 if ($version_zeroes) {
2162 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2163 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2164 qq{a version number of 0\n});
2165 }
2166 if ($version_undefs) {
2167 my $s_has = $version_undefs > 1 ? "s have" : " has";
2168 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2169 qq{parseable version number\n});
2170 }
05454584
AK
2171 }
2172 @result;
2173}
2174
2175#-> sub CPAN::Shell::r ;
2176sub r {
2177 shift->_u_r_common("r",@_);
2178}
2179
2180#-> sub CPAN::Shell::u ;
2181sub u {
2182 shift->_u_r_common("u",@_);
2183}
2184
0cf35e6a
SP
2185#-> sub CPAN::Shell::failed ;
2186sub failed {
9ddc4ed0 2187 my($self,$only_id,$silent) = @_;
c9869e1c 2188 my @failed;
0cf35e6a
SP
2189 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2190 my $failed = "";
87892b73 2191 NAY: for my $nosayer (
6658a91b 2192 "unwrapped",
87892b73
RGS
2193 "writemakefile",
2194 "signature_verify",
2195 "make",
2196 "make_test",
2197 "install",
2198 "make_clean",
2199 ) {
0cf35e6a 2200 next unless exists $d->{$nosayer};
44d21104
A
2201 next unless (
2202 $d->{$nosayer}->can("failed") ?
2203 $d->{$nosayer}->failed :
2204 $d->{$nosayer} =~ /^NO/
2205 );
87892b73
RGS
2206 next NAY if $only_id && $only_id != (
2207 $d->{$nosayer}->can("commandid")
2208 ?
2209 $d->{$nosayer}->commandid
2210 :
2211 $CPAN::CurrentCommandId
2212 );
0cf35e6a
SP
2213 $failed = $nosayer;
2214 last;
2215 }
2216 next DIST unless $failed;
2217 my $id = $d->id;
2218 $id =~ s|^./../||;
c9869e1c
SP
2219 #$print .= sprintf(
2220 # " %-45s: %s %s\n",
44d21104
A
2221 push @failed,
2222 (
2223 $d->{$failed}->can("failed") ?
2224 [
2225 $d->{$failed}->commandid,
2226 $id,
2227 $failed,
2228 $d->{$failed}->text,
2229 ] :
2230 [
2231 1,
2232 $id,
2233 $failed,
2234 $d->{$failed},
2235 ]
2236 );
0cf35e6a 2237 }
9ddc4ed0 2238 my $scope = $only_id ? "command" : "session";
c9869e1c
SP
2239 if (@failed) {
2240 my $print = join "",
2241 map { sprintf " %-45s: %s %s\n", @$_[1,2,3] }
2242 sort { $a->[0] <=> $b->[0] } @failed;
2243 $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
9ddc4ed0 2244 } elsif (!$only_id || !$silent) {
c9869e1c 2245 $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
0cf35e6a
SP
2246 }
2247}
2248
c9869e1c
SP
2249# XXX intentionally undocumented because completely bogus, unportable,
2250# useless, etc.
2251
0cf35e6a
SP
2252#-> sub CPAN::Shell::status ;
2253sub status {
2254 my($self) = @_;
2255 require Devel::Size;
2256 my $ps = FileHandle->new;
2257 open $ps, "/proc/$$/status";
2258 my $vm = 0;
2259 while (<$ps>) {
2260 next unless /VmSize:\s+(\d+)/;
2261 $vm = $1;
2262 last;
2263 }
2264 $CPAN::Frontend->mywarn(sprintf(
2265 "%-27s %6d\n%-27s %6d\n",
2266 "vm",
2267 $vm,
2268 "CPAN::META",
2269 Devel::Size::total_size($CPAN::META)/1024,
2270 ));
2271 for my $k (sort keys %$CPAN::META) {
2272 next unless substr($k,0,4) eq "read";
2273 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2274 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
7d97ad34 2275 warn sprintf " %-25s %6d (keys: %6d)\n",
0cf35e6a
SP
2276 $k2,
2277 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2278 scalar keys %{$CPAN::META->{$k}{$k2}};
2279 }
2280 }
2281}
2282
05454584
AK
2283#-> sub CPAN::Shell::autobundle ;
2284sub autobundle {
2285 my($self) = shift;
e82b9348 2286 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
05454584 2287 my(@bundle) = $self->_u_r_common("a",@_);
5de3f0da 2288 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
05454584
AK
2289 File::Path::mkpath($todir);
2290 unless (-d $todir) {
c356248b 2291 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
05454584
AK
2292 return;
2293 }
2294 my($y,$m,$d) = (localtime)[5,4,3];
2295 $y+=1900;
2296 $m++;
2297 my($c) = 0;
2298 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
5de3f0da 2299 my($to) = File::Spec->catfile($todir,"$me.pm");
05454584
AK
2300 while (-f $to) {
2301 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
5de3f0da 2302 $to = File::Spec->catfile($todir,"$me.pm");
05454584
AK
2303 }
2304 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2305 $fh->print(
2306 "package Bundle::$me;\n\n",
2307 "\$VERSION = '0.01';\n\n",
2308 "1;\n\n",
2309 "__END__\n\n",
2310 "=head1 NAME\n\n",
2311 "Bundle::$me - Snapshot of installation on ",
2312 $Config::Config{'myhostname'},
2313 " on ",
2314 scalar(localtime),
2315 "\n\n=head1 SYNOPSIS\n\n",
2316 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2317 "=head1 CONTENTS\n\n",
2318 join("\n", @bundle),
2319 "\n\n=head1 CONFIGURATION\n\n",
2320 Config->myconfig,
2321 "\n\n=head1 AUTHOR\n\n",
2322 "This Bundle has been generated automatically ",
2323 "by the autobundle routine in CPAN.pm.\n",
2324 );
2325 $fh->close;
c356248b
AK
2326 $CPAN::Frontend->myprint("\nWrote bundle file
2327 $to\n\n");
05454584
AK
2328}
2329
6d29edf5
JH
2330#-> sub CPAN::Shell::expandany ;
2331sub expandany {
2332 my($self,$s) = @_;
2333 CPAN->debug("s[$s]") if $CPAN::DEBUG;
8fc516fe 2334 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
8d97e4a1 2335 $s = CPAN::Distribution->normalize($s);
6d29edf5
JH
2336 return $CPAN::META->instance('CPAN::Distribution',$s);
2337 # Distributions spring into existence, not expand
2338 } elsif ($s =~ m|^Bundle::|) {
2339 $self->local_bundles; # scanning so late for bundles seems
2340 # both attractive and crumpy: always
2341 # current state but easy to forget
2342 # somewhere
2343 return $self->expand('Bundle',$s);
2344 } else {
2345 return $self->expand('Module',$s)
2346 if $CPAN::META->exists('CPAN::Module',$s);
2347 }
2348 return;
2349}
2350
05454584
AK
2351#-> sub CPAN::Shell::expand ;
2352sub expand {
e82b9348 2353 my $self = shift;
05454584 2354 my($type,@args) = @_;
8d97e4a1 2355 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
e82b9348
SP
2356 my $class = "CPAN::$type";
2357 my $methods = ['id'];
2358 for my $meth (qw(name)) {
2359 next if $] < 5.00303; # no "can"
2360 next unless $class->can($meth);
2361 push @$methods, $meth;
2362 }
2363 $self->expand_by_method($class,$methods,@args);
2364}
2365
05bab18e 2366#-> sub CPAN::Shell::expand_by_method ;
e82b9348
SP
2367sub expand_by_method {
2368 my $self = shift;
2369 my($class,$methods,@args) = @_;
2370 my($arg,@m);
05454584 2371 for $arg (@args) {
6d29edf5 2372 my($regex,$command);
05454584
AK
2373 if ($arg =~ m|^/(.*)/$|) {
2374 $regex = $1;
8d97e4a1
JH
2375 } elsif ($arg =~ m/=/) {
2376 $command = 1;
6d29edf5 2377 }
05454584 2378 my $obj;
8d97e4a1
JH
2379 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2380 $class,
2381 defined $regex ? $regex : "UNDEFINED",
e82b9348 2382 defined $command ? $command : "UNDEFINED",
8d97e4a1 2383 ) if $CPAN::DEBUG;
05454584 2384 if (defined $regex) {
6d29edf5 2385 for $obj (
6d29edf5
JH
2386 $CPAN::META->all_objects($class)
2387 ) {
2388 unless ($obj->id){
2389 # BUG, we got an empty object somewhere
8d97e4a1 2390 require Data::Dumper;
6d29edf5 2391 CPAN->debug(sprintf(
8d97e4a1 2392 "Bug in CPAN: Empty id on obj[%s][%s]",
6d29edf5 2393 $obj,
8d97e4a1 2394 Data::Dumper::Dumper($obj)
6d29edf5
JH
2395 )) if $CPAN::DEBUG;
2396 next;
2397 }
e82b9348 2398 for my $method (@$methods) {
135a59c2
A
2399 my $match = eval {$obj->$method() =~ /$regex/i};
2400 if ($@) {
2401 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2402 $err ||= $@; # if we were too restrictive above
2403 $CPAN::Frontend->mydie("$err\n");
2404 } elsif ($match) {
e82b9348
SP
2405 push @m, $obj;
2406 last;
2407 }
2408 }
6d29edf5
JH
2409 }
2410 } elsif ($command) {
8d97e4a1
JH
2411 die "equal sign in command disabled (immature interface), ".
2412 "you can set
2413 ! \$CPAN::Shell::ADVANCED_QUERY=1
2414to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2415that may go away anytime.\n"
2416 unless $ADVANCED_QUERY;
2417 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2418 my($matchcrit) = $criterion =~ m/^~(.+)/;
6d29edf5
JH
2419 for my $self (
2420 sort
2421 {$a->id cmp $b->id}
2422 $CPAN::META->all_objects($class)
2423 ) {
8d97e4a1
JH
2424 my $lhs = $self->$method() or next; # () for 5.00503
2425 if ($matchcrit) {
2426 push @m, $self if $lhs =~ m/$matchcrit/;
2427 } else {
2428 push @m, $self if $lhs eq $criterion;
2429 }
6d29edf5 2430 }
05454584
AK
2431 } else {
2432 my($xarg) = $arg;
e82b9348 2433 if ( $class eq 'CPAN::Bundle' ) {
05454584 2434 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
e82b9348 2435 } elsif ($class eq "CPAN::Distribution") {
8d97e4a1 2436 $xarg = CPAN::Distribution->normalize($arg);
e82b9348
SP
2437 } else {
2438 $xarg =~ s/:+/::/g;
8d97e4a1 2439 }
05454584
AK
2440 if ($CPAN::META->exists($class,$xarg)) {
2441 $obj = $CPAN::META->instance($class,$xarg);
2442 } elsif ($CPAN::META->exists($class,$arg)) {
2443 $obj = $CPAN::META->instance($class,$arg);
2444 } else {
2445 next;
2446 }
2447 push @m, $obj;
2448 }
2449 }
e82b9348
SP
2450 @m = sort {$a->id cmp $b->id} @m;
2451 if ( $CPAN::DEBUG ) {
2452 my $wantarray = wantarray;
2453 my $join_m = join ",", map {$_->id} @m;
2454 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2455 }
e50380aa 2456 return wantarray ? @m : $m[0];
05454584
AK
2457}
2458
2459#-> sub CPAN::Shell::format_result ;
2460sub format_result {
2461 my($self) = shift;
2462 my($type,@args) = @_;
2463 @args = '/./' unless @args;
2464 my(@result) = $self->expand($type,@args);
8d97e4a1 2465 my $result = @result == 1 ?
05454584 2466 $result[0]->as_string :
8d97e4a1
JH
2467 @result == 0 ?
2468 "No objects of type $type found for argument @args\n" :
2469 join("",
2470 (map {$_->as_glimpse} @result),
2471 scalar @result, " items found\n",
2472 );
05454584
AK
2473 $result;
2474}
2475
554a9ef5
SP
2476#-> sub CPAN::Shell::report_fh ;
2477{
2478 my $installation_report_fh;
2479 my $previously_noticed = 0;
2480
2481 sub report_fh {
2482 return $installation_report_fh if $installation_report_fh;
4d1321a7
A
2483 if ($CPAN::META->has_inst("File::Temp")) {
2484 $installation_report_fh
2485 = File::Temp->new(
2486 template => 'cpan_install_XXXX',
2487 suffix => '.txt',
2488 unlink => 0,
2489 );
2490 }
554a9ef5
SP
2491 unless ( $installation_report_fh ) {
2492 warn("Couldn't open installation report file; " .
2493 "no report file will be generated."
2494 ) unless $previously_noticed++;
2495 }
2496 }
2497}
2498
2499
c356248b
AK
2500# The only reason for this method is currently to have a reliable
2501# debugging utility that reveals which output is going through which
2502# channel. No, I don't like the colors ;-)
8d97e4a1 2503
8962fc49
SP
2504# to turn colordebugging on, write
2505# cpan> o conf colorize_output 1
2506
2507#-> sub CPAN::Shell::print_ornamented ;
2508{
2509 my $print_ornamented_have_warned = 0;
2510 sub colorize_output {
2511 my $colorize_output = $CPAN::Config->{colorize_output};
2512 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2513 unless ($print_ornamented_have_warned++) {
2514 # no myprint/mywarn within myprint/mywarn!
2515 warn "Colorize_output is set to true but Term::ANSIColor is not
2516installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2517 }
2518 $colorize_output = 0;
2519 }
2520 return $colorize_output;
2521 }
2522}
2523
2524
05bab18e 2525#-> sub CPAN::Shell::print_ornamented ;
c356248b
AK
2526sub print_ornamented {
2527 my($self,$what,$ornament) = @_;
8d97e4a1 2528 return unless defined $what;
c356248b 2529
554a9ef5
SP
2530 local $| = 1; # Flush immediately
2531 if ( $CPAN::Be_Silent ) {
2532 print {report_fh()} $what;
2533 return;
2534 }
8962fc49 2535 my $swhat = "$what"; # stringify if it is an object
8d97e4a1
JH
2536 if ($CPAN::Config->{term_is_latin}){
2537 # courtesy jhi:
8962fc49 2538 $swhat
8d97e4a1
JH
2539 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2540 }
8962fc49 2541 if ($self->colorize_output) {
135a59c2
A
2542 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2543 # if you want to have this configurable, please file a bugreport
2544 $ornament = "black on_cyan";
2545 }
8962fc49
SP
2546 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2547 if ($@) {
2548 print "Term::ANSIColor rejects color[$ornament]: $@\n
2549Please choose a different color (Hint: try 'o conf init color.*')\n";
2550 }
135a59c2
A
2551 print $color_on,
2552 $swhat,
2553 Term::ANSIColor::color("reset");
c356248b 2554 } else {
8962fc49 2555 print $swhat;
c356248b
AK
2556 }
2557}
2558
05bab18e
SP
2559#-> sub CPAN::Shell::myprint ;
2560
8962fc49
SP
2561# where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2562# where to use what! I think, we send everything to STDOUT and use
2563# print for normal/good news and warn for news that need more
2564# attention. Yes, this is our working contract for now.
c356248b
AK
2565sub myprint {
2566 my($self,$what) = @_;
8d97e4a1 2567
2ccf00a7 2568 $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
c356248b
AK
2569}
2570
05bab18e 2571#-> sub CPAN::Shell::myexit ;
c356248b
AK
2572sub myexit {
2573 my($self,$what) = @_;
2574 $self->myprint($what);
2575 exit;
2576}
2577
05bab18e 2578#-> sub CPAN::Shell::mywarn ;
c356248b
AK
2579sub mywarn {
2580 my($self,$what) = @_;
2ccf00a7 2581 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
c356248b
AK
2582}
2583
b96578bb 2584# only to be used for shell commands
05bab18e 2585#-> sub CPAN::Shell::mydie ;
c356248b
AK
2586sub mydie {
2587 my($self,$what) = @_;
2ccf00a7 2588 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
b96578bb
SP
2589
2590 # If it is the shell, we want that the following die to be silent,
2591 # but if it is not the shell, we would need a 'die $what'. We need
2592 # to take care that only shell commands use mydie. Is this
2593 # possible?
2594
c356248b
AK
2595 die "\n";
2596}
2597
05bab18e 2598# sub CPAN::Shell::colorable_makemaker_prompt ;
8962fc49
SP
2599sub colorable_makemaker_prompt {
2600 my($foo,$bar) = @_;
2601 if (CPAN::Shell->colorize_output) {
2ccf00a7 2602 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
8962fc49
SP
2603 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2604 print $color_on;
2605 }
2606 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2607 if (CPAN::Shell->colorize_output) {
2608 print Term::ANSIColor::color('reset');
2609 }
2610 return $ans;
2611}
2612
c9869e1c 2613# use this only for unrecoverable errors!
05bab18e 2614#-> sub CPAN::Shell::unrecoverable_error ;
c9869e1c
SP
2615sub unrecoverable_error {
2616 my($self,$what) = @_;
2617 my @lines = split /\n/, $what;
2618 my $longest = 0;
2619 for my $l (@lines) {
2620 $longest = length $l if length $l > $longest;
2621 }
2622 $longest = 62 if $longest > 62;
2623 for my $l (@lines) {
2624 if ($l =~ /^\s*$/){
2625 $l = "\n";
2626 next;
2627 }
2628 $l = "==> $l";
2629 if (length $l < 66) {
2630 $l = pack "A66 A*", $l, "<==";
2631 }
2632 $l .= "\n";
2633 }
2634 unshift @lines, "\n";
2635 $self->mydie(join "", @lines);
c9869e1c
SP
2636}
2637
05bab18e 2638#-> sub CPAN::Shell::mysleep ;
9ddc4ed0
A
2639sub mysleep {
2640 my($self, $sleep) = @_;
2641 sleep $sleep;
2642}
2643
05bab18e 2644#-> sub CPAN::Shell::setup_output ;
911a92db
GS
2645sub setup_output {
2646 return if -t STDOUT;
2647 my $odef = select STDERR;
2648 $| = 1;
2649 select STDOUT;
2650 $| = 1;
2651 select $odef;
2652}
2653
05454584 2654#-> sub CPAN::Shell::rematein ;
09d9d230 2655# RE-adme||MA-ke||TE-st||IN-stall
05454584 2656sub rematein {
0cf35e6a 2657 my $self = shift;
05454584 2658 my($meth,@some) = @_;
554a9ef5 2659 my @pragma;
f3fe0ae6 2660 while($meth =~ /^(force|notest)$/) {
554a9ef5 2661 push @pragma, $meth;
0cf35e6a
SP
2662 $meth = shift @some or
2663 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2664 "cannot continue");
05454584 2665 }
911a92db 2666 setup_output();
554a9ef5 2667 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
6d29edf5
JH
2668
2669 # Here is the place to set "test_count" on all involved parties to
2670 # 0. We then can pass this counter on to the involved
2671 # distributions and those can refuse to test if test_count > X. In
2672 # the first stab at it we could use a 1 for "X".
2673
2674 # But when do I reset the distributions to start with 0 again?
2675 # Jost suggested to have a random or cycling interaction ID that
2676 # we pass through. But the ID is something that is just left lying
2677 # around in addition to the counter, so I'd prefer to set the
2678 # counter to 0 now, and repeat at the end of the loop. But what
2679 # about dependencies? They appear later and are not reset, they
2680 # enter the queue but not its copy. How do they get a sensible
2681 # test_count?
2682
2683 # construct the queue
2684 my($s,@s,@qcopy);
0cf35e6a 2685 STHING: foreach $s (@some) {
05454584
AK
2686 my $obj;
2687 if (ref $s) {
6d29edf5 2688 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
05454584 2689 $obj = $s;
7d97ad34 2690 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
c4d24d4c 2691 } elsif ($s =~ m|^/|) { # looks like a regexp
8fc516fe
SP
2692 if (substr($s,-1,1) eq ".") {
2693 $obj = CPAN::Shell->expandany($s);
2694 } else {
2695 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2696 "not supported.\nRejecting argument '$s'\n");
2697 $CPAN::Frontend->mysleep(2);
2698 next;
2699 }
0cf35e6a 2700 } elsif ($meth eq "ls") {
ca79d794 2701 $self->globls($s,\@pragma);
0cf35e6a
SP
2702 next STHING;
2703 } else {
6d29edf5
JH
2704 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2705 $obj = CPAN::Shell->expandany($s);
05454584 2706 }
7d97ad34
SP
2707 if (0) {
2708 } elsif (ref $obj) {
6d29edf5 2709 $obj->color_cmd_tmps(0,1);
135a59c2 2710 CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
6d29edf5 2711 push @qcopy, $obj;
554a9ef5
SP
2712 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2713 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
5fc0f0f6
JH
2714 if ($meth =~ /^(dump|ls)$/) {
2715 $obj->$meth();
8d97e4a1 2716 } else {
8962fc49
SP
2717 $CPAN::Frontend->mywarn(
2718 join "",
2719 "Don't be silly, you can't $meth ",
2720 $obj->fullname,
2721 " ;-)\n"
2722 );
2723 $CPAN::Frontend->mysleep(2);
8d97e4a1 2724 }
7d97ad34 2725 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
135a59c2
A
2726 CPAN::InfoObj->dump($s);
2727 } else {
f610777f 2728 $CPAN::Frontend
8962fc49 2729 ->mywarn(qq{Warning: Cannot $meth $s, }.
135a59c2 2730 qq{don't know what it is.
e50380aa
AK
2731Try the command
2732
2733 i /$s/
2734
6d29edf5 2735to find objects with matching identifiers.
c356248b 2736});
8962fc49 2737 $CPAN::Frontend->mysleep(2);
6d29edf5
JH
2738 }
2739 }
2740
2741 # queuerunner (please be warned: when I started to change the
2742 # queue to hold objects instead of names, I made one or two
2743 # mistakes and never found which. I reverted back instead)
135a59c2 2744 while (my $q = CPAN::Queue->first) {
6d29edf5 2745 my $obj;
135a59c2
A
2746 my $s = $q->as_string;
2747 my $reqtype = $q->reqtype || "";
2748 $obj = CPAN::Shell->expandany($s);
2749 $obj->{reqtype} ||= "";
2750 CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2751 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2752 if ($obj->{reqtype}) {
2753 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2754 $obj->{reqtype} = $reqtype;
2755 if (
2756 exists $obj->{install}
2757 &&
2758 (
2759 $obj->{install}->can("failed") ?
2760 $obj->{install}->failed :
2761 $obj->{install} =~ /^NO/
2762 )
2763 ) {
2764 delete $obj->{install};
2765 $CPAN::Frontend->mywarn
2766 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2767 }
2768 }
2769 } else {
2770 $obj->{reqtype} = $reqtype;
2771 }
2772
554a9ef5
SP
2773 for my $pragma (@pragma) {
2774 if ($pragma
2775 &&
05bab18e
SP
2776 $obj->can($pragma)){
2777 $obj->$pragma($meth);
554a9ef5 2778 }
6d29edf5 2779 }
05bab18e 2780 if ($obj->can('called_for')) {
6d29edf5
JH
2781 $obj->called_for($s);
2782 }
135a59c2
A
2783 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2784 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
6d29edf5 2785
6a935156 2786 push @qcopy, $obj;
6d29edf5
JH
2787 if ($obj->$meth()){
2788 CPAN::Queue->delete($s);
2789 } else {
2790 CPAN->debug("failed");
2791 }
2792
2793 $obj->undelay;
05bab18e
SP
2794 for my $pragma (@pragma) {
2795 my $unpragma = "un$pragma";
2796 if ($obj->can($unpragma)) {
2797 $obj->$unpragma();
2798 }
2799 }
f610777f 2800 CPAN::Queue->delete_first($s);
05454584 2801 }
6d29edf5
JH
2802 for my $obj (@qcopy) {
2803 $obj->color_cmd_tmps(0,0);
2804 }
05454584
AK
2805}
2806
554a9ef5
SP
2807#-> sub CPAN::Shell::recent ;
2808sub recent {
f3fe0ae6 2809 my($self) = @_;
554a9ef5
SP
2810
2811 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2812 return;
2813}
2814
2815{
2816 # set up the dispatching methods
2817 no strict "refs";
2818 for my $command (qw(
0cf35e6a
SP
2819 clean
2820 cvs_import
2821 dump
2822 force
2823 get
2824 install
2825 look
2826 ls
2827 make
2828 notest
2829 perldoc
2830 readme
2831 test
554a9ef5
SP
2832 )) {
2833 *$command = sub { shift->rematein($command, @_); };
2834 }
2835}
05454584 2836
c049f953 2837package CPAN::LWP::UserAgent;
e82b9348 2838use strict;
c049f953
JH
2839
2840sub config {
2841 return if $SETUPDONE;
2842 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2843 require LWP::UserAgent;
2844 @ISA = qw(Exporter LWP::UserAgent);
2845 $SETUPDONE++;
2846 } else {
8962fc49 2847 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
c049f953
JH
2848 }
2849}
2850
2851sub get_basic_credentials {
2852 my($self, $realm, $uri, $proxy) = @_;
c049f953 2853 if ($USER && $PASSWD) {
ed84aac9
A
2854 return ($USER, $PASSWD);
2855 }
2856 if ( $proxy ) {
2857 ($USER,$PASSWD) = $self->get_proxy_credentials();
c049f953 2858 } else {
ed84aac9
A
2859 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2860 }
2861 return($USER,$PASSWD);
2862}
2863
2864sub get_proxy_credentials {
2865 my $self = shift;
2866 my ($user, $password);
2867 if ( defined $CPAN::Config->{proxy_user} &&
2868 defined $CPAN::Config->{proxy_pass}) {
2869 $user = $CPAN::Config->{proxy_user};
2870 $password = $CPAN::Config->{proxy_pass};
2871 return ($user, $password);
2872 }
2873 my $username_prompt = "\nProxy authentication needed!
c049f953
JH
2874 (Note: to permanently configure username and password run
2875 o conf proxy_user your_username
2876 o conf proxy_pass your_password
ed84aac9
A
2877 )\nUsername:";
2878 ($user, $password) =
2879 _get_username_and_password_from_user($username_prompt);
2880 return ($user,$password);
2881}
2882
2883sub get_non_proxy_credentials {
2884 my $self = shift;
2885 my ($user,$password);
2886 if ( defined $CPAN::Config->{username} &&
2887 defined $CPAN::Config->{password}) {
2888 $user = $CPAN::Config->{username};
2889 $password = $CPAN::Config->{password};
2890 return ($user, $password);
2891 }
2892 my $username_prompt = "\nAuthentication needed!
2893 (Note: to permanently configure username and password run
2894 o conf username your_username
2895 o conf password your_password
2896 )\nUsername:";
8962fc49 2897
ed84aac9
A
2898 ($user, $password) =
2899 _get_username_and_password_from_user($username_prompt);
2900 return ($user,$password);
2901}
2902
2903sub _get_username_and_password_from_user {
ed84aac9
A
2904 my $username_message = shift;
2905 my ($username,$password);
2906
2907 ExtUtils::MakeMaker->import(qw(prompt));
2908 $username = prompt($username_message);
c049f953
JH
2909 if ($CPAN::META->has_inst("Term::ReadKey")) {
2910 Term::ReadKey::ReadMode("noecho");
c049f953 2911 }
ed84aac9
A
2912 else {
2913 $CPAN::Frontend->mywarn(
2914 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2915 );
2916 }
2917 $password = prompt("Password:");
2918
c049f953
JH
2919 if ($CPAN::META->has_inst("Term::ReadKey")) {
2920 Term::ReadKey::ReadMode("restore");
2921 }
2922 $CPAN::Frontend->myprint("\n\n");
ed84aac9 2923 return ($username,$password);
c049f953
JH
2924}
2925
1426a145
JH
2926# mirror(): Its purpose is to deal with proxy authentication. When we
2927# call SUPER::mirror, we relly call the mirror method in
2928# LWP::UserAgent. LWP::UserAgent will then call
2929# $self->get_basic_credentials or some equivalent and this will be
2930# $self->dispatched to our own get_basic_credentials method.
2931
2932# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2933
2934# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2935# although we have gone through our get_basic_credentials, the proxy
2936# server refuses to connect. This could be a case where the username or
2937# password has changed in the meantime, so I'm trying once again without
2938# $USER and $PASSWD to give the get_basic_credentials routine another
2939# chance to set $USER and $PASSWD.
2940
554a9ef5
SP
2941# mirror(): Its purpose is to deal with proxy authentication. When we
2942# call SUPER::mirror, we relly call the mirror method in
2943# LWP::UserAgent. LWP::UserAgent will then call
2944# $self->get_basic_credentials or some equivalent and this will be
2945# $self->dispatched to our own get_basic_credentials method.
2946
2947# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2948
2949# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2950# although we have gone through our get_basic_credentials, the proxy
2951# server refuses to connect. This could be a case where the username or
2952# password has changed in the meantime, so I'm trying once again without
2953# $USER and $PASSWD to give the get_basic_credentials routine another
2954# chance to set $USER and $PASSWD.
2955
c049f953
JH
2956sub mirror {
2957 my($self,$url,$aslocal) = @_;
2958 my $result = $self->SUPER::mirror($url,$aslocal);
2959 if ($result->code == 407) {
2960 undef $USER;
2961 undef $PASSWD;
2962 $result = $self->SUPER::mirror($url,$aslocal);
2963 }
2964 $result;
2965}
2966
05454584 2967package CPAN::FTP;
e82b9348 2968use strict;
05454584 2969
05bab18e
SP
2970#-> sub CPAN::FTP::ftp_statistics
2971# if they want to rewrite, they need to pass in a filehandle
2972sub _ftp_statistics {
2973 my($self,$fh) = @_;
2974 my $locktype = $fh ? LOCK_EX : LOCK_SH;
2975 $fh ||= FileHandle->new;
2976 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
2977 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
2978 my $sleep = 1;
2979 while (!flock $fh, $locktype|LOCK_NB) {
2980 if ($sleep>3) {
2981 die;
2982 }
2983 $CPAN::Frontend->mysleep($sleep++);
2984 }
2985 my $stats = CPAN->_yaml_loadfile($file);
2986 if ($locktype == LOCK_SH) {
2987 } else {
2988 seek $fh, 0, 0;
2989 if (@$stats){ # no yaml no write
2990 truncate $fh, 0;
2991 }
2992 }
2993 return $stats->[0];
2994}
2995
2996sub _mytime () {
2997 if (CPAN->has_inst("Time::HiRes")) {
2998 return Time::HiRes::time();
2999 } else {
3000 return time;
3001 }
3002}
3003
3004sub _new_stats {
3005 my($self,$file) = @_;
3006 my $ret = {
3007 file => $file,
3008 attempts => [],
3009 start => _mytime,
3010 };
3011 $ret;
3012}
3013
3014sub _add_to_statistics {
3015 my($self,$stats) = @_;
3016 $stats->{thesiteurl} = $ThesiteURL;
3017 if (CPAN->has_inst("Time::HiRes")) {
3018 $stats->{end} = Time::HiRes::time();
3019 } else {
3020 $stats->{end} = time;
3021 }
3022 my $fh = FileHandle->new;
3023 my $fullstats = $self->_ftp_statistics($fh);
3024 push @{$fullstats->{history}}, $stats;
3025 my $time = time;
3026 shift @{$fullstats->{history}}
3027 while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
3028 CPAN->_yaml_dumpfile($fh,$fullstats);
3029}
3030
3031# if file is CHECKSUMS, suggest the place where we got the file to be
3032# checked from, maybe only for young files?
3033sub _recommend_url_for {
3034 my($self, $file) = @_;
3035 my $urllist = $self->_get_urllist;
3036 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3037 my $fullstats = $self->_ftp_statistics();
3038 my $history = $fullstats->{history} || [];
3039 while (my $last = pop @$history) {
3040 last if $last->{end} - time > 3600; # only young results are interesting
3041 next unless $file eq File::Basename::dirname($last->{file});
3042 return $last->{thesiteurl};
3043 }
3044 }
3045 if ($CPAN::Config->{randomize_urllist}
3046 &&
3047 rand(1) < $CPAN::Config->{randomize_urllist}
3048 ) {
3049 $urllist->[int rand scalar @$urllist];
3050 } else {
3051 return ();
3052 }
3053}
3054
3055sub _get_urllist {
3056 my($self) = @_;
3057 $CPAN::Config->{urllist} ||= [];
3058 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3059 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
3060 $CPAN::Config->{urllist} = [];
3061 }
3062 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3063 for my $u (@urllist) {
3064 CPAN->debug("u[$u]") if $CPAN::DEBUG;
3065 if (UNIVERSAL::can($u,"text")) {
3066 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3067 } else {
3068 $u .= "/" unless substr($u,-1) eq "/";
3069 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3070 }
3071 }
3072 \@urllist;
3073}
3074
05454584
AK
3075#-> sub CPAN::FTP::ftp_get ;
3076sub ftp_get {
9ddc4ed0
A
3077 my($class,$host,$dir,$file,$target) = @_;
3078 $class->debug(
3079 qq[Going to fetch file [$file] from dir [$dir]
05454584 3080 on host [$host] as local [$target]\n]
9ddc4ed0
A
3081 ) if $CPAN::DEBUG;
3082 my $ftp = Net::FTP->new($host);
3083 unless ($ftp) {
3084 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
3085 return;
3086 }
3087 return 0 unless defined $ftp;
3088 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3089 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3090 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3091 my $msg = $ftp->message;
3092 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
3093 return;
3094 }
3095 unless ( $ftp->cwd($dir) ){
3096 my $msg = $ftp->message;
3097 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
3098 return;
3099 }
3100 $ftp->binary;
3101 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3102 unless ( $ftp->get($file,$target) ){
3103 my $msg = $ftp->message;
3104 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
3105 return;
3106 }
3107 $ftp->quit; # it's ok if this fails
3108 return 1;
05454584
AK
3109}
3110
09d9d230 3111# If more accuracy is wanted/needed, Chris Leach sent me this patch...
f610777f 3112
6d29edf5
JH
3113 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
3114 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
3115 # > ***************
3116 # > *** 1562,1567 ****
3117 # > --- 1562,1580 ----
3118 # > return 1 if substr($url,0,4) eq "file";
3119 # > return 1 unless $url =~ m|://([^/]+)|;
3120 # > my $host = $1;
3121 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3122 # > + if ($proxy) {
3123 # > + $proxy =~ m|://([^/:]+)|;
3124 # > + $proxy = $1;
3125 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3126 # > + if ($noproxy) {
3127 # > + if ($host !~ /$noproxy$/) {
3128 # > + $host = $proxy;
3129 # > + }
3130 # > + } else {
3131 # > + $host = $proxy;
3132 # > + }
3133 # > + }
3134 # > require Net::Ping;
3135 # > return 1 unless $Net::Ping::VERSION >= 2;
3136 # > my $p;
09d9d230
A
3137
3138
05454584
AK
3139#-> sub CPAN::FTP::localize ;
3140sub localize {
3141 my($self,$file,$aslocal,$force) = @_;
3142 $force ||= 0;
3143 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3144 unless defined $aslocal;
55e314ee
AK
3145 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3146 if $CPAN::DEBUG;
05454584 3147
f14b5cec 3148 if ($^O eq 'MacOS') {
6d29edf5
JH
3149 # Comment by AK on 2000-09-03: Uniq short filenames would be
3150 # available in CHECKSUMS file
f14b5cec
JH
3151 my($name, $path) = File::Basename::fileparse($aslocal, '');
3152 if (length($name) > 31) {
6d29edf5
JH
3153 $name =~ s/(
3154 \.(
3155 readme(\.(gz|Z))? |
3156 (tar\.)?(gz|Z) |
3157 tgz |
3158 zip |
3159 pm\.(gz|Z)
3160 )
3161 )$//x;
f14b5cec
JH
3162 my $suf = $1;
3163 my $size = 31 - length($suf);
3164 while (length($name) > $size) {
3165 chop $name;
3166 }
3167 $name .= $suf;
3168 $aslocal = File::Spec->catfile($path, $name);
3169 }
3170 }
3171
0cf35e6a 3172 if (-f $aslocal && -r _ && !($force & 1)){
b96578bb
SP
3173 my $size;
3174 if ($size = -s $aslocal) {
3175 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3176 return $aslocal;
3177 } else {
3178 # empty file from a previous unsuccessful attempt to download it
3179 unlink $aslocal or
ed84aac9
A
3180 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3181 "could not remove.");
b96578bb 3182 }
0cf35e6a 3183 }
05bab18e 3184 my($maybe_restore) = 0;
55e314ee 3185 if (-f $aslocal){
05bab18e
SP
3186 rename $aslocal, "$aslocal.bak$$";
3187 $maybe_restore++;
55e314ee 3188 }
05454584
AK
3189
3190 my($aslocal_dir) = File::Basename::dirname($aslocal);
3191 File::Path::mkpath($aslocal_dir);
c356248b 3192 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
05454584 3193 qq{directory "$aslocal_dir".
c356248b
AK
3194 I\'ll continue, but if you encounter problems, they may be due
3195 to insufficient permissions.\n}) unless -w $aslocal_dir;
05454584
AK
3196
3197 # Inheritance is not easier to manage than a few if/else branches
de34a54b 3198 if ($CPAN::META->has_usable('LWP::UserAgent')) {
05454584 3199 unless ($Ua) {
c049f953
JH
3200 CPAN::LWP::UserAgent->config;
3201 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
d8773709 3202 if ($@) {
5fc0f0f6 3203 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
d8773709
JH
3204 if $CPAN::DEBUG;
3205 } else {
3206 my($var);
3207 $Ua->proxy('ftp', $var)
3208 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3209 $Ua->proxy('http', $var)
3210 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
c049f953
JH
3211
3212
3213# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3214#
3215# > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3216# > use ones that require basic autorization.
3217#
3218# > Example of when I use it manually in my own stuff:
3219#
3220# > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3221# > $req->proxy_authorization_basic("username","password");
3222# > $res = $ua->request($req);
3223#
3224
d8773709
JH
3225 $Ua->no_proxy($var)
3226 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3227 }
05454584
AK
3228 }
3229 }
35576f8c
A
3230 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3231 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3232 }
05454584
AK
3233
3234 # Try the list of urls for each single object. We keep a record
3235 # where we did get a file from
c356248b 3236 my(@reordered,$last);
05bab18e
SP
3237 my $ccurllist = $self->_get_urllist;
3238 $last = $#$ccurllist;
c356248b
AK
3239 if ($force & 2) { # local cpans probably out of date, don't reorder
3240 @reordered = (0..$last);
3241 } else {
3242 @reordered =
3243 sort {
05bab18e 3244 (substr($ccurllist->[$b],0,4) eq "file")
f610777f 3245 <=>
05bab18e 3246 (substr($ccurllist->[$a],0,4) eq "file")
c356248b 3247 or
44d21104 3248 defined($ThesiteURL)
c356248b 3249 and
05bab18e 3250 ($ccurllist->[$b] eq $ThesiteURL)
c356248b 3251 <=>
05bab18e 3252 ($ccurllist->[$a] eq $ThesiteURL)
c356248b 3253 } 0..$last;
c356248b 3254 }
c4d24d4c 3255 my(@levels);
7fefbd44 3256 $Themethod ||= "";
05bab18e 3257 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
c356248b
AK
3258 if ($Themethod) {
3259 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3260 } else {
3261 @levels = qw/easy hard hardest/;
3262 }
f14b5cec 3263 @levels = qw/easy/ if $^O eq 'MacOS';
c4d24d4c 3264 my($levelno);
4d1321a7
A
3265 local $ENV{FTP_PASSIVE} =
3266 exists $CPAN::Config->{ftp_passive} ?
3267 $CPAN::Config->{ftp_passive} : 1;
05bab18e
SP
3268 my $ret;
3269 my $stats = $self->_new_stats($file);
3270 LEVEL: for $levelno (0..$#levels) {
c4d24d4c 3271 my $level = $levels[$levelno];
c356248b
AK
3272 my $method = "host$level";
3273 my @host_seq = $level eq "easy" ?
3274 @reordered : 0..$last; # reordered has CDROM up front
05bab18e 3275 my @urllist = map { $ccurllist->[$_] } @host_seq;
ca79d794
SP
3276 for my $u (@CPAN::Defaultsites) {
3277 push @urllist, $u unless grep { $_ eq $u } @urllist;
3278 }
3279 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
05bab18e
SP
3280 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3281 if (my $recommend = $self->_recommend_url_for($file)) {
3282 @urllist = grep { $_ ne $recommend } @urllist;
3283 unshift @urllist, $recommend;
3284 }
3285 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3286 $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
c356248b 3287 if ($ret) {
05bab18e
SP
3288 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3289 if ($ret eq $aslocal_tempfile) {
3290 # if we got it exactly as we asked for, only then we
3291 # want to rename
3292 rename $aslocal_tempfile, $aslocal
3293 or $CPAN::Frontend->mydie("Error while trying to rename ".
3294 "'$ret' to '$aslocal': $!");
3295 $ret = $aslocal;
3296 }
3297 $Themethod = $level;
3298 my $now = time;
3299 # utime $now, $now, $aslocal; # too bad, if we do that, we
3300 # might alter a local mirror
3301 $self->debug("level[$level]") if $CPAN::DEBUG;
3302 last LEVEL;
2e2b7522 3303 } else {
05bab18e
SP
3304 unlink $aslocal_tempfile;
3305 last if $CPAN::Signal; # need to cleanup
c356248b
AK
3306 }
3307 }
05bab18e
SP
3308 if ($ret) {
3309 $stats->{filesize} = -s $ret;
3310 }
3311 $self->_add_to_statistics($stats);
3312 if ($ret) {
3313 return $ret;
3314 }
c4d24d4c
A
3315 unless ($CPAN::Signal) {
3316 my(@mess);
8962fc49
SP
3317 local $" = " ";
3318 if (@{$CPAN::Config->{urllist}}) {
3319 push @mess,
3320 qq{Please check, if the URLs I found in your configuration file \(}.
3321 join(", ", @{$CPAN::Config->{urllist}}).
3322 qq{\) are valid.};
3323 } else {
3324 push @mess, qq{Your urllist is empty!};
3325 }
3326 push @mess, qq{The urllist can be edited.},
3327 qq{E.g. with 'o conf urllist push ftp://myurl/'};
3328 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3329 $CPAN::Frontend->mywarn("Could not fetch $file\n");
3330 $CPAN::Frontend->mysleep(2);
c4d24d4c 3331 }
05bab18e
SP
3332 if ($maybe_restore) {
3333 rename "$aslocal.bak$$", $aslocal;
c356248b
AK
3334 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3335 $self->ls($aslocal));
3336 return $aslocal;
3337 }
3338 return;
3339}
3340
05bab18e
SP
3341sub _set_attempt {
3342 my($self,$stats,$method,$url) = @_;
3343 push @{$stats->{attempts}}, {
3344 method => $method,
3345 start => _mytime,
3346 url => $url,
3347 };
3348}
3349
ca79d794 3350# package CPAN::FTP;
c356248b 3351sub hosteasy {
05bab18e 3352 my($self,$host_seq,$file,$aslocal,$stats) = @_;
ca79d794
SP
3353 my($ro_url);
3354 HOSTEASY: for $ro_url (@$host_seq) {
05bab18e 3355 $self->_set_attempt($stats,"easy",$ro_url);
ca79d794 3356 my $url .= "$ro_url$file";
c356248b 3357 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
05454584
AK
3358 if ($url =~ /^file:/) {
3359 my $l;
de34a54b 3360 if ($CPAN::META->has_inst('URI::URL')) {
55e314ee 3361 my $u = URI::URL->new($url);
05454584
AK
3362 $l = $u->path;
3363 } else { # works only on Unix, is poorly constructed, but
c356248b
AK
3364 # hopefully better than nothing.
3365 # RFC 1738 says fileurl BNF is
3366 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3367 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3368 # the code
36263cb3
GS
3369 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3370 $l =~ s|^file:||; # assume they
3371 # meant
3372 # file://localhost
4d1321a7
A
3373 $l =~ s|^/||s
3374 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
05454584 3375 }
4d1321a7 3376 $self->debug("local file[$l]") if $CPAN::DEBUG;
c356248b 3377 if ( -f $l && -r _) {
44d21104 3378 $ThesiteURL = $ro_url;
c356248b
AK
3379 return $l;
3380 }
4d1321a7
A
3381 if ($l =~ /(.+)\.gz$/) {
3382 my $ungz = $1;
3383 if ( -f $ungz && -r _) {
3384 $ThesiteURL = $ro_url;
3385 return $ungz;
3386 }
3387 }
05454584
AK
3388 # Maybe mirror has compressed it?
3389 if (-f "$l.gz") {
d4fd5c69 3390 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
e82b9348 3391 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
c356248b 3392 if ( -f $aslocal) {
44d21104 3393 $ThesiteURL = $ro_url;
c356248b
AK
3394 return $aslocal;
3395 }
05454584
AK
3396 }
3397 }
05bab18e 3398 $self->debug("it was not a file URL") if $CPAN::DEBUG;
c4d24d4c 3399 if ($CPAN::META->has_usable('LWP')) {
7fefbd44 3400 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
AK
3401 $url
3402");
7fefbd44
RGS
3403 unless ($Ua) {
3404 CPAN::LWP::UserAgent->config;
3405 eval { $Ua = CPAN::LWP::UserAgent->new; };
3406 if ($@) {
3407 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3408 }
3409 }
3410 my $res = $Ua->mirror($url, $aslocal);
3411 if ($res->is_success) {
3412 $ThesiteURL = $ro_url;
3413 my $now = time;
3414 utime $now, $now, $aslocal; # download time is more
3415 # important than upload
3416 # time
3417 return $aslocal;
3418 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3419 my $gzurl = "$url.gz";
3420 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
AK
3421 $gzurl
3422");
7fefbd44
RGS
3423 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3424 if ($res->is_success &&
3425 CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
3426 ) {
3427 $ThesiteURL = $ro_url;
3428 return $aslocal;
3429 }
3430 } else {
3431 $CPAN::Frontend->myprint(sprintf(
3432 "LWP failed with code[%s] message[%s]\n",
3433 $res->code,
3434 $res->message,
3435 ));
3436 # Alan Burlison informed me that in firewall environments
3437 # Net::FTP can still succeed where LWP fails. So we do not
3438 # skip Net::FTP anymore when LWP is available.
3439 }
7fefbd44 3440 } else {
8962fc49 3441 $CPAN::Frontend->mywarn(" LWP not available\n");
05454584 3442 }
c4d24d4c 3443 return if $CPAN::Signal;
05454584
AK
3444 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3445 # that's the nice and easy way thanks to Graham
05bab18e 3446 $self->debug("recognized ftp") if $CPAN::DEBUG;
05454584 3447 my($host,$dir,$getfile) = ($1,$2,$3);
de34a54b 3448 if ($CPAN::META->has_usable('Net::FTP')) {
05454584 3449 $dir =~ s|/+|/|g;
c356248b 3450 $CPAN::Frontend->myprint("Fetching with Net::FTP:
09d9d230 3451 $url
c356248b
AK
3452");
3453 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3454 "aslocal[$aslocal]") if $CPAN::DEBUG;
3455 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
44d21104 3456 $ThesiteURL = $ro_url;
c356248b
AK
3457 return $aslocal;
3458 }
05d2a450 3459 if ($aslocal !~ /\.gz(?!\n)\Z/) {
c356248b
AK
3460 my $gz = "$aslocal.gz";
3461 $CPAN::Frontend->myprint("Fetching with Net::FTP
09d9d230 3462 $url.gz
c356248b 3463");
e82b9348
SP
3464 if (CPAN::FTP->ftp_get($host,
3465 $dir,
3466 "$getfile.gz",
3467 $gz) &&
3468 CPAN::Tarzip->new($gz)->gunzip($aslocal)
09d9d230 3469 ){
44d21104 3470 $ThesiteURL = $ro_url;
c356248b
AK
3471 return $aslocal;
3472 }
3473 }
09d9d230 3474 # next HOSTEASY;
05bab18e
SP
3475 } else {
3476 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3477 }
05454584 3478 }
05bab18e
SP
3479 if (
3480 UNIVERSAL::can($ro_url,"text")
3481 and
3482 $ro_url->{FROM} eq "USER"
3483 ){
3484 ##address #17973: default URLs should not try to override
3485 ##user-defined URLs just because LWP is not available
3486 my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3487 return $ret if $ret;
3488 }
c4d24d4c 3489 return if $CPAN::Signal;
c356248b
AK
3490 }
3491}
05454584 3492
ca79d794 3493# package CPAN::FTP;
c356248b 3494sub hosthard {
05bab18e 3495 my($self,$host_seq,$file,$aslocal,$stats) = @_;
05454584 3496
2e2b7522
GS
3497 # Came back if Net::FTP couldn't establish connection (or
3498 # failed otherwise) Maybe they are behind a firewall, but they
3499 # gave us a socksified (or other) ftp program...
c356248b 3500
ca79d794 3501 my($ro_url);
f610777f 3502 my($devnull) = $CPAN::Config->{devnull} || "";
2e2b7522
GS
3503 # < /dev/null ";
3504 my($aslocal_dir) = File::Basename::dirname($aslocal);
3505 File::Path::mkpath($aslocal_dir);
ca79d794 3506 HOSTHARD: for $ro_url (@$host_seq) {
05bab18e 3507 $self->_set_attempt($stats,"hard",$ro_url);
ca79d794 3508 my $url = "$ro_url$file";
09d9d230
A
3509 my($proto,$host,$dir,$getfile);
3510
3511 # Courtesy Mark Conty mark_conty@cargill.com change from
3512 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3513 # to
3514 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
911a92db
GS
3515 # proto not yet used
3516 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
c356248b 3517 } else {
911a92db 3518 next HOSTHARD; # who said, we could ftp anything except ftp?
c356248b 3519 }
5a5fac02
JH
3520 next HOSTHARD if $proto eq "file"; # file URLs would have had
3521 # success above. Likely a bogus URL
911a92db 3522
c356248b 3523 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
73beb80c
MS
3524
3525 # Try the most capable first and leave ncftp* for last as it only
3526 # does FTP.
44d21104 3527 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
ed84aac9 3528 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
73beb80c 3529 next unless defined $funkyftp;
911a92db 3530 next if $funkyftp =~ /^\s*$/;
73beb80c 3531
de34a54b
JH
3532 my($asl_ungz, $asl_gz);
3533 ($asl_ungz = $aslocal) =~ s/\.gz//;
3534 $asl_gz = "$asl_ungz.gz";
73beb80c 3535
de34a54b 3536 my($src_switch) = "";
554a9ef5
SP
3537 my($chdir) = "";
3538 my($stdout_redir) = " > $asl_ungz";
911a92db 3539 if ($f eq "lynx"){
de34a54b 3540 $src_switch = " -source";
911a92db 3541 } elsif ($f eq "ncftp"){
de34a54b 3542 $src_switch = " -c";
fc83dee7 3543 } elsif ($f eq "wget"){
554a9ef5
SP
3544 $src_switch = " -O $asl_ungz";
3545 $stdout_redir = "";
fc83dee7 3546 } elsif ($f eq 'curl'){
44d21104 3547 $src_switch = ' -L -f -s -S --netrc-optional';
911a92db 3548 }
73beb80c 3549
911a92db
GS
3550 if ($f eq "ncftpget"){
3551 $chdir = "cd $aslocal_dir && ";
3552 $stdout_redir = "";
3553 }
3554 $CPAN::Frontend->myprint(
3555 qq[
de34a54b 3556Trying with "$funkyftp$src_switch" to get
c356248b 3557 $url
2e2b7522 3558]);
911a92db 3559 my($system) =
e662ec5f 3560 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
911a92db 3561 $self->debug("system[$system]") if $CPAN::DEBUG;
44d21104
A
3562 my($wstatus) = system($system);
3563 if ($f eq "lynx") {
3564 # lynx returns 0 when it fails somewhere
3565 if (-s $asl_ungz) {
05bab18e
SP
3566 my $content = do { local *FH;
3567 open FH, $asl_ungz or die;
3568 local $/;
3569 <FH> };
3570 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
8962fc49 3571 $CPAN::Frontend->mywarn(qq{
44d21104
A
3572No success, the file that lynx has has downloaded looks like an error message:
3573$content
3574});
3575 $CPAN::Frontend->mysleep(1);
3576 next DLPRG;
3577 }
3578 } else {
3579 $CPAN::Frontend->myprint(qq{
3580No success, the file that lynx has has downloaded is an empty file.
3581});
3582 next DLPRG;
3583 }
3584 }
3585 if ($wstatus == 0) {
911a92db
GS
3586 if (-s $aslocal) {
3587 # Looks good
de34a54b 3588 } elsif ($asl_ungz ne $aslocal) {
911a92db 3589 # test gzip integrity
e82b9348 3590 if (CPAN::Tarzip->new($asl_ungz)->gtest) {
5a5fac02
JH
3591 # e.g. foo.tar is gzipped --> foo.tar.gz
3592 rename $asl_ungz, $aslocal;
911a92db 3593 } else {
e82b9348 3594 CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
911a92db
GS
3595 }
3596 }
44d21104 3597 $ThesiteURL = $ro_url;
911a92db 3598 return $aslocal;
05d2a450 3599 } elsif ($url !~ /\.gz(?!\n)\Z/) {
de34a54b
JH
3600 unlink $asl_ungz if
3601 -f $asl_ungz && -s _ == 0;
911a92db
GS
3602 my $gz = "$aslocal.gz";
3603 my $gzurl = "$url.gz";
3604 $CPAN::Frontend->myprint(
3605 qq[
de34a54b 3606Trying with "$funkyftp$src_switch" to get
911a92db
GS
3607 $url.gz
3608]);
e662ec5f 3609 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
55e314ee 3610 $self->debug("system[$system]") if $CPAN::DEBUG;
05454584 3611 my($wstatus);
55e314ee
AK
3612 if (($wstatus = system($system)) == 0
3613 &&
de34a54b 3614 -s $asl_gz
55e314ee 3615 ) {
911a92db 3616 # test gzip integrity
e82b9348
SP
3617 my $ct = CPAN::Tarzip->new($asl_gz);
3618 if ($ct->gtest) {
3619 $ct->gunzip($aslocal);
2e2b7522 3620 } else {
5a5fac02
JH
3621 # somebody uncompressed file for us?
3622 rename $asl_ungz, $aslocal;
2e2b7522 3623 }
44d21104 3624 $ThesiteURL = $ro_url;
911a92db 3625 return $aslocal;
05454584 3626 } else {
de34a54b 3627 unlink $asl_gz if -f $asl_gz;
911a92db
GS
3628 }
3629 } else {
3630 my $estatus = $wstatus >> 8;
3631 my $size = -f $aslocal ?
3632 ", left\n$aslocal with size ".-s _ :
3633 "\nWarning: expected file [$aslocal] doesn't exist";
3634 $CPAN::Frontend->myprint(qq{
05454584 3635System call "$system"
c356248b
AK
3636returned status $estatus (wstat $wstatus)$size
3637});
911a92db 3638 }
c4d24d4c 3639 return if $CPAN::Signal;
73beb80c 3640 } # transfer programs
c4d24d4c 3641 } # host
c356248b 3642}
05454584 3643
ca79d794 3644# package CPAN::FTP;
c356248b 3645sub hosthardest {
05bab18e 3646 my($self,$host_seq,$file,$aslocal,$stats) = @_;
c356248b 3647
ca79d794 3648 my($ro_url);
c356248b
AK
3649 my($aslocal_dir) = File::Basename::dirname($aslocal);
3650 File::Path::mkpath($aslocal_dir);
35576f8c 3651 my $ftpbin = $CPAN::Config->{ftp};