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