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