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