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