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