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