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