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