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