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