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