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