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