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