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