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