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