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