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