lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 package CPAN;
   3 $VERSION = '1.59_54';
   4 # $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $
   5
   6 # only used during development:
   7 $Revision = "";
   8 # $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";
   9
  10 use Carp ();
  11 use Config ();
  12 use Cwd ();
  13 use DirHandle;
  14 use Exporter ();
  15 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
  16 use File::Basename ();
  17 use File::Copy ();
  18 use File::Find;
  19 use File::Path ();
  20 use FileHandle ();
  21 use Safe ();
  22 use Text::ParseWords ();
  23 use Text::Wrap;
  24 use File::Spec;
  25 no lib "."; # we need to run chdir all over and we would get at wrong
  26             # libraries there
  27
  28 END { $End++; &cleanup; }
  29
  30 %CPAN::DEBUG = qw[
  31                   CPAN              1
  32                   Index             2
  33                   InfoObj           4
  34                   Author            8
  35                   Distribution     16
  36                   Bundle           32
  37                   Module           64
  38                   CacheMgr        128
  39                   Complete        256
  40                   FTP             512
  41                   Shell          1024
  42                   Eval           2048
  43                   Config         4096
  44                   Tarzip         8192
  45                   Version       16384
  46                   Queue         32768
  47 ];
  48
  49 $CPAN::DEBUG ||= 0;
  50 $CPAN::Signal ||= 0;
  51 $CPAN::Frontend ||= "CPAN::Shell";
  52 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
  53
  54 package CPAN;
  55 use strict qw(vars);
  56
  57 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
  58             $Revision $Signal $End $Suppress_readline $Frontend
  59             $Defaultsite $Have_warned);
  60
  61 @CPAN::ISA = qw(CPAN::Debug Exporter);
  62
  63 @EXPORT = qw(
  64              autobundle bundle expand force get cvs_import
  65              install make readme recompile shell test clean
  66             );
  67
  68 #-> sub CPAN::AUTOLOAD ;
  69 sub AUTOLOAD {
  70     my($l) = $AUTOLOAD;
  71     $l =~ s/.*:://;
  72     my(%EXPORT);
  73     @EXPORT{@EXPORT} = '';
  74     CPAN::Config->load unless $CPAN::Config_loaded++;
  75     if (exists $EXPORT{$l}){
  76         CPAN::Shell->$l(@_);
  77     } else {
  78         $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
  79                                 qq{Type ? for help.
  80 });
  81     }
  82 }
  83
  84 #-> sub CPAN::shell ;
  85 sub shell {
  86     my($self) = @_;
  87     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
  88     CPAN::Config->load unless $CPAN::Config_loaded++;
  89
  90     my $oprompt = shift || "cpan> ";
  91     my $prompt = $oprompt;
  92     my $commandline = shift || "";
  93
  94     local($^W) = 1;
  95     unless ($Suppress_readline) {
  96         require Term::ReadLine;
  97         if (! $term
  98             or
  99             $term->ReadLine eq "Term::ReadLine::Stub"
 100            ) {
 101             $term = Term::ReadLine->new('CPAN Monitor');
 102         }
 103         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 104             my $attribs = $term->Attribs;
 105              $attribs->{attempted_completion_function} = sub {
 106                  &CPAN::Complete::gnu_cpl;
 107              }
 108         } else {
 109             $readline::rl_completion_function =
 110                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 111         }
 112         # $term->OUT is autoflushed anyway
 113         my $odef = select STDERR;
 114         $| = 1;
 115         select STDOUT;
 116         $| = 1;
 117         select $odef;
 118     }
 119
 120     # no strict; # I do not recall why no strict was here (2000-09-03)
 121     $META->checklock();
 122     my $cwd = CPAN::anycwd();
 123     my $try_detect_readline;
 124     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 125     my $rl_avail = $Suppress_readline ? "suppressed" :
 126         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 127             "available (try 'install Bundle::CPAN')";
 128
 129     $CPAN::Frontend->myprint(
 130                              sprintf qq{
 131 cpan shell -- CPAN exploration and modules installation (v%s%s)
 132 ReadLine support %s
 133
 134 },
 135                              $CPAN::VERSION,
 136                              $CPAN::Revision,
 137                              $rl_avail
 138                             )
 139         unless $CPAN::Config->{'inhibit_startup_message'} ;
 140     my($continuation) = "";
 141   SHELLCOMMAND: while () {
 142         if ($Suppress_readline) {
 143             print $prompt;
 144             last SHELLCOMMAND unless defined ($_ = <> );
 145             chomp;
 146         } else {
 147             last SHELLCOMMAND unless
 148                 defined ($_ = $term->readline($prompt, $commandline));
 149         }
 150         $_ = "$continuation$_" if $continuation;
 151         s/^\s+//;
 152         next SHELLCOMMAND if /^$/;
 153         $_ = 'h' if /^\s*\?/;
 154         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 155             last SHELLCOMMAND;
 156         } elsif (s/\\$//s) {
 157             chomp;
 158             $continuation = $_;
 159             $prompt = "    > ";
 160         } elsif (/^\!/) {
 161             s/^\!//;
 162             my($eval) = $_;
 163             package CPAN::Eval;
 164             use vars qw($import_done);
 165             CPAN->import(':DEFAULT') unless $import_done++;
 166             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 167             eval($eval);
 168             warn $@ if $@;
 169             $continuation = "";
 170             $prompt = $oprompt;
 171         } elsif (/./) {
 172             my(@line);
 173             if ($] < 5.00322) { # parsewords had a bug until recently
 174                 @line = split;
 175             } else {
 176                 eval { @line = Text::ParseWords::shellwords($_) };
 177                 warn($@), next SHELLCOMMAND if $@;
 178                 warn("Text::Parsewords could not parse the line [$_]"),
 179                     next SHELLCOMMAND unless @line;
 180             }
 181             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 182             my $command = shift @line;
 183             eval { CPAN::Shell->$command(@line) };
 184             warn $@ if $@;
 185             chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
 186             $CPAN::Frontend->myprint("\n");
 187             $continuation = "";
 188             $prompt = $oprompt;
 189         }
 190     } continue {
 191       $commandline = ""; # I do want to be able to pass a default to
 192                          # shell, but on the second command I see no
 193                          # use in that
 194       $Signal=0;
 195       CPAN::Queue->nullify_queue;
 196       if ($try_detect_readline) {
 197         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 198             ||
 199             $CPAN::META->has_inst("Term::ReadLine::Perl")
 200            ) {
 201             delete $INC{"Term/ReadLine.pm"};
 202             my $redef = 0;
 203             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 204             require Term::ReadLine;
 205             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 206                                      "Term::ReadLine redefined\n");
 207             @_ = ($oprompt,"");
 208             goto &shell;
 209         }
 210       }
 211     }
 212     chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
 213 }
 214
 215 package CPAN::CacheMgr;
 216 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 217 use File::Find;
 218
 219 package CPAN::Config;
 220 use vars qw(%can $dot_cpan);
 221
 222 %can = (
 223   'commit' => "Commit changes to disk",
 224   'defaults' => "Reload defaults from disk",
 225   'init'   => "Interactive setting of all options",
 226 );
 227
 228 package CPAN::FTP;
 229 use vars qw($Ua $Thesite $Themethod);
 230 @CPAN::FTP::ISA = qw(CPAN::Debug);
 231
 232 package CPAN::LWP::UserAgent;
 233 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 234 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
 235
 236 package CPAN::Complete;
 237 @CPAN::Complete::ISA = qw(CPAN::Debug);
 238 @CPAN::Complete::COMMANDS = sort qw(
 239                        ! a b d h i m o q r u autobundle clean dump
 240                        make test install force readme reload look
 241                        cvs_import ls
 242 ) unless @CPAN::Complete::COMMANDS;
 243
 244 package CPAN::Index;
 245 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
 246 @CPAN::Index::ISA = qw(CPAN::Debug);
 247 $LAST_TIME ||= 0;
 248 $DATE_OF_03 ||= 0;
 249 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 250 sub PROTOCOL { 2.0 }
 251
 252 package CPAN::InfoObj;
 253 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 254
 255 package CPAN::Author;
 256 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 257
 258 package CPAN::Distribution;
 259 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 260
 261 package CPAN::Bundle;
 262 @CPAN::Bundle::ISA = qw(CPAN::Module);
 263
 264 package CPAN::Module;
 265 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 266
 267 package CPAN::Shell;
 268 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
 269 @CPAN::Shell::ISA = qw(CPAN::Debug);
 270 $COLOR_REGISTERED ||= 0;
 271 $PRINT_ORNAMENTING ||= 0;
 272
 273 #-> sub CPAN::Shell::AUTOLOAD ;
 274 sub AUTOLOAD {
 275     my($autoload) = $AUTOLOAD;
 276     my $class = shift(@_);
 277     # warn "autoload[$autoload] class[$class]";
 278     $autoload =~ s/.*:://;
 279     if ($autoload =~ /^w/) {
 280         if ($CPAN::META->has_inst('CPAN::WAIT')) {
 281             CPAN::WAIT->$autoload(@_);
 282         } else {
 283             $CPAN::Frontend->mywarn(qq{
 284 Commands starting with "w" require CPAN::WAIT to be installed.
 285 Please consider installing CPAN::WAIT to use the fulltext index.
 286 For this you just need to type
 287     install CPAN::WAIT
 288 });
 289         }
 290     } else {
 291         $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
 292                                 qq{Type ? for help.
 293 });
 294     }
 295 }
 296
 297 package CPAN::Tarzip;
 298 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
 299 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
 300 $BUGHUNTING = 0; # released code must have turned off
 301
 302 package CPAN::Queue;
 303
 304 # One use of the queue is to determine if we should or shouldn't
 305 # announce the availability of a new CPAN module
 306
 307 # Now we try to use it for dependency tracking. For that to happen
 308 # we need to draw a dependency tree and do the leaves first. This can
 309 # easily be reached by running CPAN.pm recursively, but we don't want
 310 # to waste memory and run into deep recursion. So what we can do is
 311 # this:
 312
 313 # CPAN::Queue is the package where the queue is maintained. Dependencies
 314 # often have high priority and must be brought to the head of the queue,
 315 # possibly by jumping the queue if they are already there. My first code
 316 # attempt tried to be extremely correct. Whenever a module needed
 317 # immediate treatment, I either unshifted it to the front of the queue,
 318 # or, if it was already in the queue, I spliced and let it bypass the
 319 # others. This became a too correct model that made it impossible to put
 320 # an item more than once into the queue. Why would you need that? Well,
 321 # you need temporary duplicates as the manager of the queue is a loop
 322 # that
 323 #
 324 #  (1) looks at the first item in the queue without shifting it off
 325 #
 326 #  (2) cares for the item
 327 #
 328 #  (3) removes the item from the queue, *even if its agenda failed and
 329 #      even if the item isn't the first in the queue anymore* (that way
 330 #      protecting against never ending queues)
 331 #
 332 # So if an item has prerequisites, the installation fails now, but we
 333 # want to retry later. That's easy if we have it twice in the queue.
 334 #
 335 # I also expect insane dependency situations where an item gets more
 336 # than two lives in the queue. Simplest example is triggered by 'install
 337 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
 338 # get in the way. I wanted the queue manager to be a dumb servant, not
 339 # one that knows everything.
 340 #
 341 # Who would I tell in this model that the user wants to be asked before
 342 # processing? I can't attach that information to the module object,
 343 # because not modules are installed but distributions. So I'd have to
 344 # tell the distribution object that it should ask the user before
 345 # processing. Where would the question be triggered then? Most probably
 346 # in CPAN::Distribution::rematein.
 347 # Hope that makes sense, my head is a bit off:-) -- AK
 348
 349 use vars qw{ @All };
 350
 351 # CPAN::Queue::new ;
 352 sub new {
 353   my($class,$s) = @_;
 354   my $self = bless { qmod => $s }, $class;
 355   push @All, $self;
 356   return $self;
 357 }
 358
 359 # CPAN::Queue::first ;
 360 sub first {
 361   my $obj = $All[0];
 362   $obj->{qmod};
 363 }
 364
 365 # CPAN::Queue::delete_first ;
 366 sub delete_first {
 367   my($class,$what) = @_;
 368   my $i;
 369   for my $i (0..$#All) {
 370     if (  $All[$i]->{qmod} eq $what ) {
 371       splice @All, $i, 1;
 372       return;
 373     }
 374   }
 375 }
 376
 377 # CPAN::Queue::jumpqueue ;
 378 sub jumpqueue {
 379     my $class = shift;
 380     my @what = @_;
 381     CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
 382                         join(",",map {$_->{qmod}} @All),
 383                         join(",",@what)
 384                        )) if $CPAN::DEBUG;
 385   WHAT: for my $what (reverse @what) {
 386         my $jumped = 0;
 387         for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
 388             CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
 389             if ($All[$i]->{qmod} eq $what){
 390                 $jumped++;
 391                 if ($jumped > 100) { # one's OK if e.g. just
 392                                      # processing now; more are OK if
 393                                      # user typed it several times
 394                     $CPAN::Frontend->mywarn(
 395 qq{Object [$what] queued more than 100 times, ignoring}
 396                                  );
 397                     next WHAT;
 398                 }
 399             }
 400         }
 401         my $obj = bless { qmod => $what }, $class;
 402         unshift @All, $obj;
 403     }
 404     CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
 405                         join(",",map {$_->{qmod}} @All),
 406                         join(",",@what)
 407                        )) if $CPAN::DEBUG;
 408 }
 409
 410 # CPAN::Queue::exists ;
 411 sub exists {
 412   my($self,$what) = @_;
 413   my @all = map { $_->{qmod} } @All;
 414   my $exists = grep { $_->{qmod} eq $what } @All;
 415   # warn "in exists what[$what] all[@all] exists[$exists]";
 416   $exists;
 417 }
 418
 419 # CPAN::Queue::delete ;
 420 sub delete {
 421   my($self,$mod) = @_;
 422   @All = grep { $_->{qmod} ne $mod } @All;
 423 }
 424
 425 # CPAN::Queue::nullify_queue ;
 426 sub nullify_queue {
 427   @All = ();
 428 }
 429
 430
 431
 432 package CPAN;
 433
 434 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 435
 436 # from here on only subs.
 437 ################################################################################
 438
 439 #-> sub CPAN::all_objects ;
 440 sub all_objects {
 441     my($mgr,$class) = @_;
 442     CPAN::Config->load unless $CPAN::Config_loaded++;
 443     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 444     CPAN::Index->reload;
 445     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 446 }
 447 *all = \&all_objects;
 448
 449 # Called by shell, not in batch mode. In batch mode I see no risk in
 450 # having many processes updating something as installations are
 451 # continually checked at runtime. In shell mode I suspect it is
 452 # unintentional to open more than one shell at a time
 453
 454 #-> sub CPAN::checklock ;
 455 sub checklock {
 456     my($self) = @_;
 457     my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
 458     if (-f $lockfile && -M _ > 0) {
 459         my $fh = FileHandle->new($lockfile) or
 460             $CPAN::Frontend->mydie("Could not open $lockfile: $!");
 461         my $other = <$fh>;
 462         $fh->close;
 463         if (defined $other && $other) {
 464             chomp $other;
 465             return if $$==$other; # should never happen
 466             $CPAN::Frontend->mywarn(
 467                                     qq{
 468 There seems to be running another CPAN process ($other). Contacting...
 469 });
 470             if (kill 0, $other) {
 471                 $CPAN::Frontend->mydie(qq{Other job is running.
 472 You may want to kill it and delete the lockfile, maybe. On UNIX try:
 473     kill $other
 474     rm $lockfile
 475 });
 476             } elsif (-w $lockfile) {
 477                 my($ans) =
 478                     ExtUtils::MakeMaker::prompt
 479                         (qq{Other job not responding. Shall I overwrite }.
 480                          qq{the lockfile? (Y/N)},"y");
 481                 $CPAN::Frontend->myexit("Ok, bye\n")
 482                     unless $ans =~ /^y/i;
 483             } else {
 484                 Carp::croak(
 485                             qq{Lockfile $lockfile not writeable by you. }.
 486                             qq{Cannot proceed.\n}.
 487                             qq{    On UNIX try:\n}.
 488                             qq{    rm $lockfile\n}.
 489                             qq{  and then rerun us.\n}
 490                            );
 491             }
 492         } else {
 493             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
 494                                            "reports other process with ID ".
 495                                            "$other. Cannot proceed.\n"));
 496         }
 497     }
 498     my $dotcpan = $CPAN::Config->{cpan_home};
 499     eval { File::Path::mkpath($dotcpan);};
 500     if ($@) {
 501       # A special case at least for Jarkko.
 502       my $firsterror = $@;
 503       my $seconderror;
 504       my $symlinkcpan;
 505       if (-l $dotcpan) {
 506         $symlinkcpan = readlink $dotcpan;
 507         die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 508         eval { File::Path::mkpath($symlinkcpan); };
 509         if ($@) {
 510           $seconderror = $@;
 511         } else {
 512           $CPAN::Frontend->mywarn(qq{
 513 Working directory $symlinkcpan created.
 514 });
 515         }
 516       }
 517       unless (-d $dotcpan) {
 518         my $diemess = qq{
 519 Your configuration suggests "$dotcpan" as your
 520 CPAN.pm working directory. I could not create this directory due
 521 to this error: $firsterror\n};
 522         $diemess .= qq{
 523 As "$dotcpan" is a symlink to "$symlinkcpan",
 524 I tried to create that, but I failed with this error: $seconderror
 525 } if $seconderror;
 526         $diemess .= qq{
 527 Please make sure the directory exists and is writable.
 528 };
 529         $CPAN::Frontend->mydie($diemess);
 530       }
 531     }
 532     my $fh;
 533     unless ($fh = FileHandle->new(">$lockfile")) {
 534         if ($! =~ /Permission/) {
 535             my $incc = $INC{'CPAN/Config.pm'};
 536             my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
 537             $CPAN::Frontend->myprint(qq{
 538
 539 Your configuration suggests that CPAN.pm should use a working
 540 directory of
 541     $CPAN::Config->{cpan_home}
 542 Unfortunately we could not create the lock file
 543     $lockfile
 544 due to permission problems.
 545
 546 Please make sure that the configuration variable
 547     \$CPAN::Config->{cpan_home}
 548 points to a directory where you can write a .lock file. You can set
 549 this variable in either
 550     $incc
 551 or
 552     $myincc
 553
 554 });
 555         }
 556         $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
 557     }
 558     $fh->print($$, "\n");
 559     $self->{LOCK} = $lockfile;
 560     $fh->close;
 561     $SIG{TERM} = sub {
 562       &cleanup;
 563       $CPAN::Frontend->mydie("Got SIGTERM, leaving");
 564     };
 565     $SIG{INT} = sub {
 566       # no blocks!!!
 567       &cleanup if $Signal;
 568       $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
 569       print "Caught SIGINT\n";
 570       $Signal++;
 571     };
 572
 573 #       From: Larry Wall <larry@wall.org>
 574 #       Subject: Re: deprecating SIGDIE
 575 #       To: perl5-porters@perl.org
 576 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 577 #
 578 #       The original intent of __DIE__ was only to allow you to substitute one
 579 #       kind of death for another on an application-wide basis without respect
 580 #       to whether you were in an eval or not.  As a global backstop, it should
 581 #       not be used any more lightly (or any more heavily :-) than class
 582 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 583 #       be politely squashed.  Any bug that causes every eval {} to have to be
 584 #       modified should be not so politely squashed.
 585 #
 586 #       Those are my current opinions.  It is also my optinion that polite
 587 #       arguments degenerate to personal arguments far too frequently, and that
 588 #       when they do, it's because both people wanted it to, or at least didn't
 589 #       sufficiently want it not to.
 590 #
 591 #       Larry
 592
 593     # global backstop to cleanup if we should really die
 594     $SIG{__DIE__} = \&cleanup;
 595     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 596 }
 597
 598 #-> sub CPAN::DESTROY ;
 599 sub DESTROY {
 600     &cleanup; # need an eval?
 601 }
 602
 603 #-> sub CPAN::anycwd ;
 604 sub anycwd () {
 605     my $getcwd;
 606     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 607     CPAN->$getcwd();
 608 }
 609
 610 #-> sub CPAN::cwd ;
 611 sub cwd {Cwd::cwd();}
 612
 613 #-> sub CPAN::getcwd ;
 614 sub getcwd {Cwd::getcwd();}
 615
 616 #-> sub CPAN::exists ;
 617 sub exists {
 618     my($mgr,$class,$id) = @_;
 619     CPAN::Config->load unless $CPAN::Config_loaded++;
 620     CPAN::Index->reload;
 621     ### Carp::croak "exists called without class argument" unless $class;
 622     $id ||= "";
 623     exists $META->{readonly}{$class}{$id} or
 624         exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 625 }
 626
 627 #-> sub CPAN::delete ;
 628 sub delete {
 629   my($mgr,$class,$id) = @_;
 630   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
 631   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 632 }
 633
 634 #-> sub CPAN::has_usable
 635 # has_inst is sometimes too optimistic, we should replace it with this
 636 # has_usable whenever a case is given
 637 sub has_usable {
 638     my($self,$mod,$message) = @_;
 639     return 1 if $HAS_USABLE->{$mod};
 640     my $has_inst = $self->has_inst($mod,$message);
 641     return unless $has_inst;
 642     my $usable;
 643     $usable = {
 644                LWP => [ # we frequently had "Can't locate object
 645                         # method "new" via package "LWP::UserAgent" at
 646                         # (eval 69) line 2006
 647                        sub {require LWP},
 648                        sub {require LWP::UserAgent},
 649                        sub {require HTTP::Request},
 650                        sub {require URI::URL},
 651                       ],
 652                Net::FTP => [
 653                             sub {require Net::FTP},
 654                             sub {require Net::Config},
 655                            ]
 656               };
 657     if ($usable->{$mod}) {
 658       for my $c (0..$#{$usable->{$mod}}) {
 659         my $code = $usable->{$mod}[$c];
 660         my $ret = eval { &$code() };
 661         if ($@) {
 662           warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
 663           return;
 664         }
 665       }
 666     }
 667     return $HAS_USABLE->{$mod} = 1;
 668 }
 669
 670 #-> sub CPAN::has_inst
 671 sub has_inst {
 672     my($self,$mod,$message) = @_;
 673     Carp::croak("CPAN->has_inst() called without an argument")
 674         unless defined $mod;
 675     if (defined $message && $message eq "no"
 676         ||
 677         exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
 678         ||
 679         exists $CPAN::Config->{dontload_hash}{$mod}
 680        ) {
 681       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
 682       return 0;
 683     }
 684     my $file = $mod;
 685     my $obj;
 686     $file =~ s|::|/|g;
 687     $file =~ s|/|\\|g if $^O eq 'MSWin32';
 688     $file .= ".pm";
 689     if ($INC{$file}) {
 690         # checking %INC is wrong, because $INC{LWP} may be true
 691         # although $INC{"URI/URL.pm"} may have failed. But as
 692         # I really want to say "bla loaded OK", I have to somehow
 693         # cache results.
 694         ### warn "$file in %INC"; #debug
 695         return 1;
 696     } elsif (eval { require $file }) {
 697         # eval is good: if we haven't yet read the database it's
 698         # perfect and if we have installed the module in the meantime,
 699         # it tries again. The second require is only a NOOP returning
 700         # 1 if we had success, otherwise it's retrying
 701
 702         $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
 703         if ($mod eq "CPAN::WAIT") {
 704             push @CPAN::Shell::ISA, CPAN::WAIT;
 705         }
 706         return 1;
 707     } elsif ($mod eq "Net::FTP") {
 708         $CPAN::Frontend->mywarn(qq{
 709   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
 710   if you just type
 711       install Bundle::libnet
 712
 713 }) unless $Have_warned->{"Net::FTP"}++;
 714         sleep 3;
 715     } elsif ($mod eq "MD5"){
 716         $CPAN::Frontend->myprint(qq{
 717   CPAN: MD5 security checks disabled because MD5 not installed.
 718   Please consider installing the MD5 module.
 719
 720 });
 721         sleep 2;
 722     } else {
 723         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
 724     }
 725     return 0;
 726 }
 727
 728 #-> sub CPAN::instance ;
 729 sub instance {
 730     my($mgr,$class,$id) = @_;
 731     CPAN::Index->reload;
 732     $id ||= "";
 733     # unsafe meta access, ok?
 734     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
 735     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
 736 }
 737
 738 #-> sub CPAN::new ;
 739 sub new {
 740     bless {}, shift;
 741 }
 742
 743 #-> sub CPAN::cleanup ;
 744 sub cleanup {
 745   # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
 746   local $SIG{__DIE__} = '';
 747   my($message) = @_;
 748   my $i = 0;
 749   my $ineval = 0;
 750   if (
 751       0 &&           # disabled, try reload cpan with it
 752       $] > 5.004_60  # thereabouts
 753      ) {
 754     $ineval = $^S;
 755   } else {
 756     my($subroutine);
 757     while ((undef,undef,undef,$subroutine) = caller(++$i)) {
 758       $ineval = 1, last if
 759           $subroutine eq '(eval)';
 760     }
 761   }
 762   return if $ineval && !$End;
 763   return unless defined $META->{LOCK}; # unsafe meta access, ok
 764   return unless -f $META->{LOCK}; # unsafe meta access, ok
 765   unlink $META->{LOCK}; # unsafe meta access, ok
 766   # require Carp;
 767   # Carp::cluck("DEBUGGING");
 768   $CPAN::Frontend->mywarn("Lockfile removed.\n");
 769 }
 770
 771 package CPAN::CacheMgr;
 772
 773 #-> sub CPAN::CacheMgr::as_string ;
 774 sub as_string {
 775     eval { require Data::Dumper };
 776     if ($@) {
 777         return shift->SUPER::as_string;
 778     } else {
 779         return Data::Dumper::Dumper(shift);
 780     }
 781 }
 782
 783 #-> sub CPAN::CacheMgr::cachesize ;
 784 sub cachesize {
 785     shift->{DU};
 786 }
 787
 788 #-> sub CPAN::CacheMgr::tidyup ;
 789 sub tidyup {
 790   my($self) = @_;
 791   return unless -d $self->{ID};
 792   while ($self->{DU} > $self->{'MAX'} ) {
 793     my($toremove) = shift @{$self->{FIFO}};
 794     $CPAN::Frontend->myprint(sprintf(
 795                                      "Deleting from cache".
 796                                      ": $toremove (%.1f>%.1f MB)\n",
 797                                      $self->{DU}, $self->{'MAX'})
 798                             );
 799     return if $CPAN::Signal;
 800     $self->force_clean_cache($toremove);
 801     return if $CPAN::Signal;
 802   }
 803 }
 804
 805 #-> sub CPAN::CacheMgr::dir ;
 806 sub dir {
 807     shift->{ID};
 808 }
 809
 810 #-> sub CPAN::CacheMgr::entries ;
 811 sub entries {
 812     my($self,$dir) = @_;
 813     return unless defined $dir;
 814     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
 815     $dir ||= $self->{ID};
 816     my($cwd) = CPAN::anycwd();
 817     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
 818     my $dh = DirHandle->new(File::Spec->curdir)
 819         or Carp::croak("Couldn't opendir $dir: $!");
 820     my(@entries);
 821     for ($dh->read) {
 822         next if $_ eq "." || $_ eq "..";
 823         if (-f $_) {
 824             push @entries, MM->catfile($dir,$_);
 825         } elsif (-d _) {
 826             push @entries, MM->catdir($dir,$_);
 827         } else {
 828             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
 829         }
 830     }
 831     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
 832     sort { -M $b <=> -M $a} @entries;
 833 }
 834
 835 #-> sub CPAN::CacheMgr::disk_usage ;
 836 sub disk_usage {
 837     my($self,$dir) = @_;
 838     return if exists $self->{SIZE}{$dir};
 839     return if $CPAN::Signal;
 840     my($Du) = 0;
 841     find(
 842          sub {
 843            $File::Find::prune++ if $CPAN::Signal;
 844            return if -l $_;
 845            if ($^O eq 'MacOS') {
 846              require Mac::Files;
 847              my $cat  = Mac::Files::FSpGetCatInfo($_);
 848              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
 849            } else {
 850              $Du += (-s _);
 851            }
 852          },
 853          $dir
 854         );
 855     return if $CPAN::Signal;
 856     $self->{SIZE}{$dir} = $Du/1024/1024;
 857     push @{$self->{FIFO}}, $dir;
 858     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
 859     $self->{DU} += $Du/1024/1024;
 860     $self->{DU};
 861 }
 862
 863 #-> sub CPAN::CacheMgr::force_clean_cache ;
 864 sub force_clean_cache {
 865     my($self,$dir) = @_;
 866     return unless -e $dir;
 867     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
 868         if $CPAN::DEBUG;
 869     File::Path::rmtree($dir);
 870     $self->{DU} -= $self->{SIZE}{$dir};
 871     delete $self->{SIZE}{$dir};
 872 }
 873
 874 #-> sub CPAN::CacheMgr::new ;
 875 sub new {
 876     my $class = shift;
 877     my $time = time;
 878     my($debug,$t2);
 879     $debug = "";
 880     my $self = {
 881                 ID => $CPAN::Config->{'build_dir'},
 882                 MAX => $CPAN::Config->{'build_cache'},
 883                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
 884                 DU => 0
 885                };
 886     File::Path::mkpath($self->{ID});
 887     my $dh = DirHandle->new($self->{ID});
 888     bless $self, $class;
 889     $self->scan_cache;
 890     $t2 = time;
 891     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
 892     $time = $t2;
 893     CPAN->debug($debug) if $CPAN::DEBUG;
 894     $self;
 895 }
 896
 897 #-> sub CPAN::CacheMgr::scan_cache ;
 898 sub scan_cache {
 899     my $self = shift;
 900     return if $self->{SCAN} eq 'never';
 901     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
 902         unless $self->{SCAN} eq 'atstart';
 903     $CPAN::Frontend->myprint(
 904                              sprintf("Scanning cache %s for sizes\n",
 905                                      $self->{ID}));
 906     my $e;
 907     for $e ($self->entries($self->{ID})) {
 908         next if $e eq ".." || $e eq ".";
 909         $self->disk_usage($e);
 910         return if $CPAN::Signal;
 911     }
 912     $self->tidyup;
 913 }
 914
 915 package CPAN::Debug;
 916
 917 #-> sub CPAN::Debug::debug ;
 918 sub debug {
 919     my($self,$arg) = @_;
 920     my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
 921                                                # Complete, caller(1)
 922                                                # eg readline
 923     ($caller) = caller(0);
 924     $caller =~ s/.*:://;
 925     $arg = "" unless defined $arg;
 926     my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
 927     if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
 928         if ($arg and ref $arg) {
 929             eval { require Data::Dumper };
 930             if ($@) {
 931                 $CPAN::Frontend->myprint($arg->as_string);
 932             } else {
 933                 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
 934             }
 935         } else {
 936             $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
 937         }
 938     }
 939 }
 940
 941 package CPAN::Config;
 942
 943 #-> sub CPAN::Config::edit ;
 944 # returns true on successful action
 945 sub edit {
 946     my($self,@args) = @_;
 947     return unless @args;
 948     CPAN->debug("self[$self]args[".join(" | ",@args)."]");
 949     my($o,$str,$func,$args,$key_exists);
 950     $o = shift @args;
 951     if($can{$o}) {
 952         $self->$o(@args);
 953         return 1;
 954     } else {
 955         CPAN->debug("o[$o]") if $CPAN::DEBUG;
 956         if ($o =~ /list$/) {
 957             $func = shift @args;
 958             $func ||= "";
 959             CPAN->debug("func[$func]") if $CPAN::DEBUG;
 960             my $changed;
 961             # Let's avoid eval, it's easier to comprehend without.
 962             if ($func eq "push") {
 963                 push @{$CPAN::Config->{$o}}, @args;
 964                 $changed = 1;
 965             } elsif ($func eq "pop") {
 966                 pop @{$CPAN::Config->{$o}};
 967                 $changed = 1;
 968             } elsif ($func eq "shift") {
 969                 shift @{$CPAN::Config->{$o}};
 970                 $changed = 1;
 971             } elsif ($func eq "unshift") {
 972                 unshift @{$CPAN::Config->{$o}}, @args;
 973                 $changed = 1;
 974             } elsif ($func eq "splice") {
 975                 splice @{$CPAN::Config->{$o}}, @args;
 976                 $changed = 1;
 977             } elsif (@args) {
 978                 $CPAN::Config->{$o} = [@args];
 979                 $changed = 1;
 980             } else {
 981                 $self->prettyprint($o);
 982             }
 983             if ($o eq "urllist" && $changed) {
 984                 # reset the cached values
 985                 undef $CPAN::FTP::Thesite;
 986                 undef $CPAN::FTP::Themethod;
 987             }
 988             return $changed;
 989         } else {
 990             $CPAN::Config->{$o} = $args[0] if defined $args[0];
 991             $self->prettyprint($o);
 992         }
 993     }
 994 }
 995
 996 sub prettyprint {
 997   my($self,$k) = @_;
 998   my $v = $CPAN::Config->{$k};
 999   if (ref $v) {
1000     my(@report) = ref $v eq "ARRAY" ?
1001         @$v :
1002             map { sprintf("   %-18s => %s\n",
1003                           $_,
1004                           defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1005                          )} keys %$v;
1006     $CPAN::Frontend->myprint(
1007                              join(
1008                                   "",
1009                                   sprintf(
1010                                           "    %-18s\n",
1011                                           $k
1012                                          ),
1013                                   map {"\t$_\n"} @report
1014                                  )
1015                             );
1016   } elsif (defined $v) {
1017     $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1018   } else {
1019     $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, "UNDEFINED");
1020   }
1021 }
1022
1023 #-> sub CPAN::Config::commit ;
1024 sub commit {
1025     my($self,$configpm) = @_;
1026     unless (defined $configpm){
1027         $configpm ||= $INC{"CPAN/MyConfig.pm"};
1028         $configpm ||= $INC{"CPAN/Config.pm"};
1029         $configpm || Carp::confess(q{
1030 CPAN::Config::commit called without an argument.
1031 Please specify a filename where to save the configuration or try
1032 "o conf init" to have an interactive course through configing.
1033 });
1034     }
1035     my($mode);
1036     if (-f $configpm) {
1037         $mode = (stat $configpm)[2];
1038         if ($mode && ! -w _) {
1039             Carp::confess("$configpm is not writable");
1040         }
1041     }
1042
1043     my $msg;
1044     $msg = <<EOF unless $configpm =~ /MyConfig/;
1045
1046 # This is CPAN.pm's systemwide configuration file. This file provides
1047 # defaults for users, and the values can be changed in a per-user
1048 # configuration file. The user-config file is being looked for as
1049 # ~/.cpan/CPAN/MyConfig.pm.
1050
1051 EOF
1052     $msg ||= "\n";
1053     my($fh) = FileHandle->new;
1054     rename $configpm, "$configpm~" if -f $configpm;
1055     open $fh, ">$configpm" or
1056         $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1057     $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1058     foreach (sort keys %$CPAN::Config) {
1059         $fh->print(
1060                    "  '$_' => ",
1061                    ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1062                    ",\n"
1063                   );
1064     }
1065
1066     $fh->print("};\n1;\n__END__\n");
1067     close $fh;
1068
1069     #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1070     #chmod $mode, $configpm;
1071 ###why was that so?    $self->defaults;
1072     $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1073     1;
1074 }
1075
1076 *default = \&defaults;
1077 #-> sub CPAN::Config::defaults ;
1078 sub defaults {
1079     my($self) = @_;
1080     $self->unload;
1081     $self->load;
1082     1;
1083 }
1084
1085 sub init {
1086     my($self) = @_;
1087     undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1088                                                       # have the least
1089                                                       # important
1090                                                       # variable
1091                                                       # undefined
1092     $self->load;
1093     1;
1094 }
1095
1096 #-> sub CPAN::Config::load ;
1097 sub load {
1098     my($self) = shift;
1099     my(@miss);
1100     use Carp;
1101     eval {require CPAN::Config;};       # We eval because of some
1102                                         # MakeMaker problems
1103     unless ($dot_cpan++){
1104       unshift @INC, MM->catdir($ENV{HOME},".cpan");
1105       eval {require CPAN::MyConfig;};   # where you can override
1106                                         # system wide settings
1107       shift @INC;
1108     }
1109     return unless @miss = $self->missing_config_data;
1110
1111     require CPAN::FirstTime;
1112     my($configpm,$fh,$redo,$theycalled);
1113     $redo ||= "";
1114     $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1115     if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1116         $configpm = $INC{"CPAN/Config.pm"};
1117         $redo++;
1118     } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1119         $configpm = $INC{"CPAN/MyConfig.pm"};
1120         $redo++;
1121     } else {
1122         my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1123         my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1124         my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1125         if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1126             if (-w $configpmtest) {
1127                 $configpm = $configpmtest;
1128             } elsif (-w $configpmdir) {
1129                 #_#_# following code dumped core on me with 5.003_11, a.k.
1130                 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1131                 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1132                 my $fh = FileHandle->new;
1133                 if ($fh->open(">$configpmtest")) {
1134                     $fh->print("1;\n");
1135                     $configpm = $configpmtest;
1136                 } else {
1137                     # Should never happen
1138                     Carp::confess("Cannot open >$configpmtest");
1139                 }
1140             }
1141         }
1142         unless ($configpm) {
1143             $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1144             File::Path::mkpath($configpmdir);
1145             $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1146             if (-w $configpmtest) {
1147                 $configpm = $configpmtest;
1148             } elsif (-w $configpmdir) {
1149                 #_#_# following code dumped core on me with 5.003_11, a.k.
1150                 my $fh = FileHandle->new;
1151                 if ($fh->open(">$configpmtest")) {
1152                     $fh->print("1;\n");
1153                     $configpm = $configpmtest;
1154                 } else {
1155                     # Should never happen
1156                     Carp::confess("Cannot open >$configpmtest");
1157                 }
1158             } else {
1159                 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1160                               qq{create a configuration file.});
1161             }
1162         }
1163     }
1164     local($") = ", ";
1165     $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1166 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1167
1168 @miss
1169 END
1170     $CPAN::Frontend->myprint(qq{
1171 $configpm initialized.
1172 });
1173     sleep 2;
1174     CPAN::FirstTime::init($configpm);
1175 }
1176
1177 #-> sub CPAN::Config::missing_config_data ;
1178 sub missing_config_data {
1179     my(@miss);
1180     for (
1181          "cpan_home", "keep_source_where", "build_dir", "build_cache",
1182          "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1183          "pager",
1184          "makepl_arg", "make_arg", "make_install_arg", "urllist",
1185          "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1186          "prerequisites_policy",
1187          "cache_metadata",
1188         ) {
1189         push @miss, $_ unless defined $CPAN::Config->{$_};
1190     }
1191     return @miss;
1192 }
1193
1194 #-> sub CPAN::Config::unload ;
1195 sub unload {
1196     delete $INC{'CPAN/MyConfig.pm'};
1197     delete $INC{'CPAN/Config.pm'};
1198 }
1199
1200 #-> sub CPAN::Config::help ;
1201 sub help {
1202     $CPAN::Frontend->myprint(q[
1203 Known options:
1204   defaults  reload default config values from disk
1205   commit    commit session changes to disk
1206   init      go through a dialog to set all parameters
1207
1208 You may edit key values in the follow fashion (the "o" is a literal
1209 letter o):
1210
1211   o conf build_cache 15
1212
1213   o conf build_dir "/foo/bar"
1214
1215   o conf urllist shift
1216
1217   o conf urllist unshift ftp://ftp.foo.bar/
1218
1219 ]);
1220     undef; #don't reprint CPAN::Config
1221 }
1222
1223 #-> sub CPAN::Config::cpl ;
1224 sub cpl {
1225     my($word,$line,$pos) = @_;
1226     $word ||= "";
1227     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1228     my(@words) = split " ", substr($line,0,$pos+1);
1229     if (
1230         defined($words[2])
1231         and
1232         (
1233          $words[2] =~ /list$/ && @words == 3
1234          ||
1235          $words[2] =~ /list$/ && @words == 4 && length($word)
1236         )
1237        ) {
1238         return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1239     } elsif (@words >= 4) {
1240         return ();
1241     }
1242     my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1243     return grep /^\Q$word\E/, @o_conf;
1244 }
1245
1246 package CPAN::Shell;
1247
1248 #-> sub CPAN::Shell::h ;
1249 sub h {
1250     my($class,$about) = @_;
1251     if (defined $about) {
1252         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1253     } else {
1254         $CPAN::Frontend->myprint(q{
1255 Display Information
1256  command  argument          description
1257  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1258  i        WORD or /REGEXP/  about anything of above
1259  r        NONE              reinstall recommendations
1260  ls       AUTHOR            about files in the author's directory
1261
1262 Download, Test, Make, Install...
1263  get                        download
1264  make                       make (implies get)
1265  test      MODULES,         make test (implies make)
1266  install   DISTS, BUNDLES   make install (implies test)
1267  clean                      make clean
1268  look                       open subshell in these dists' directories
1269  readme                     display these dists' README files
1270
1271 Other
1272  h,?           display this menu       ! perl-code   eval a perl command
1273  o conf [opt]  set and query options   q             quit the cpan shell
1274  reload cpan   load CPAN.pm again      reload index  load newer indices
1275  autobundle    Snapshot                force cmd     unconditionally do cmd});
1276     }
1277 }
1278
1279 *help = \&h;
1280
1281 #-> sub CPAN::Shell::a ;
1282 sub a {
1283   my($self,@arg) = @_;
1284   # authors are always UPPERCASE
1285   for (@arg) {
1286     $_ = uc $_ unless /=/;
1287   }
1288   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1289 }
1290
1291 #-> sub CPAN::Shell::ls ;
1292 sub ls      {
1293     my($self,@arg) = @_;
1294     my @accept;
1295     for (@arg) {
1296         unless (/^[A-Z\-]+$/i) {
1297             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
1298             next;
1299         }
1300         push @accept, uc $_;
1301     }
1302     for my $a (@accept){
1303         my $author = $self->expand('Author',$a) or die "No author found for $a";
1304         $author->ls;
1305     }
1306 }
1307
1308 #-> sub CPAN::Shell::local_bundles ;
1309 sub local_bundles {
1310     my($self,@which) = @_;
1311     my($incdir,$bdir,$dh);
1312     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1313         my @bbase = "Bundle";
1314         while (my $bbase = shift @bbase) {
1315             $bdir = MM->catdir($incdir,split /::/, $bbase);
1316             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1317             if ($dh = DirHandle->new($bdir)) { # may fail
1318                 my($entry);
1319                 for $entry ($dh->read) {
1320                     next if $entry =~ /^\./;
1321                     if (-d MM->catdir($bdir,$entry)){
1322                         push @bbase, "$bbase\::$entry";
1323                     } else {
1324                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1325                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1326                     }
1327                 }
1328             }
1329         }
1330     }
1331 }
1332
1333 #-> sub CPAN::Shell::b ;
1334 sub b {
1335     my($self,@which) = @_;
1336     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1337     $self->local_bundles;
1338     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1339 }
1340
1341 #-> sub CPAN::Shell::d ;
1342 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1343
1344 #-> sub CPAN::Shell::m ;
1345 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1346     $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1347 }
1348
1349 #-> sub CPAN::Shell::i ;
1350 sub i {
1351     my($self) = shift;
1352     my(@args) = @_;
1353     my(@type,$type,@m);
1354     @type = qw/Author Bundle Distribution Module/;
1355     @args = '/./' unless @args;
1356     my(@result);
1357     for $type (@type) {
1358         push @result, $self->expand($type,@args);
1359     }
1360     my $result = @result == 1 ?
1361         $result[0]->as_string :
1362             @result == 0 ?
1363                 "No objects found of any type for argument @args\n" :
1364                     join("",
1365                          (map {$_->as_glimpse} @result),
1366                          scalar @result, " items found\n",
1367                         );
1368     $CPAN::Frontend->myprint($result);
1369 }
1370
1371 #-> sub CPAN::Shell::o ;
1372
1373 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1374 # should have been called set and 'o debug' maybe 'set debug'
1375 sub o {
1376     my($self,$o_type,@o_what) = @_;
1377     $o_type ||= "";
1378     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1379     if ($o_type eq 'conf') {
1380         shift @o_what if @o_what && $o_what[0] eq 'help';
1381         if (!@o_what) { # print all things, "o conf"
1382             my($k,$v);
1383             $CPAN::Frontend->myprint("CPAN::Config options");
1384             if (exists $INC{'CPAN/Config.pm'}) {
1385               $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1386             }
1387             if (exists $INC{'CPAN/MyConfig.pm'}) {
1388               $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1389             }
1390             $CPAN::Frontend->myprint(":\n");
1391             for $k (sort keys %CPAN::Config::can) {
1392                 $v = $CPAN::Config::can{$k};
1393                 $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1394             }
1395             $CPAN::Frontend->myprint("\n");
1396             for $k (sort keys %$CPAN::Config) {
1397                 CPAN::Config->prettyprint($k);
1398             }
1399             $CPAN::Frontend->myprint("\n");
1400         } elsif (!CPAN::Config->edit(@o_what)) {
1401             $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1402                                      qq{edit options\n\n});
1403         }
1404     } elsif ($o_type eq 'debug') {
1405         my(%valid);
1406         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1407         if (@o_what) {
1408             while (@o_what) {
1409                 my($what) = shift @o_what;
1410                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1411                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1412                     next;
1413                 }
1414                 if ( exists $CPAN::DEBUG{$what} ) {
1415                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1416                 } elsif ($what =~ /^\d/) {
1417                     $CPAN::DEBUG = $what;
1418                 } elsif (lc $what eq 'all') {
1419                     my($max) = 0;
1420                     for (values %CPAN::DEBUG) {
1421                         $max += $_;
1422                     }
1423                     $CPAN::DEBUG = $max;
1424                 } else {
1425                     my($known) = 0;
1426                     for (keys %CPAN::DEBUG) {
1427                         next unless lc($_) eq lc($what);
1428                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1429                         $known = 1;
1430                     }
1431                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1432                         unless $known;
1433                 }
1434             }
1435         } else {
1436           my $raw = "Valid options for debug are ".
1437               join(", ",sort(keys %CPAN::DEBUG), 'all').
1438                   qq{ or a number. Completion works on the options. }.
1439                       qq{Case is ignored.};
1440           require Text::Wrap;
1441           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1442           $CPAN::Frontend->myprint("\n\n");
1443         }
1444         if ($CPAN::DEBUG) {
1445             $CPAN::Frontend->myprint("Options set for debugging:\n");
1446             my($k,$v);
1447             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1448                 $v = $CPAN::DEBUG{$k};
1449                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1450                     if $v & $CPAN::DEBUG;
1451             }
1452         } else {
1453             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1454         }
1455     } else {
1456         $CPAN::Frontend->myprint(qq{
1457 Known options:
1458   conf    set or get configuration variables
1459   debug   set or get debugging options
1460 });
1461     }
1462 }
1463
1464 sub paintdots_onreload {
1465     my($ref) = shift;
1466     sub {
1467         if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1468             my($subr) = $1;
1469             ++$$ref;
1470             local($|) = 1;
1471             # $CPAN::Frontend->myprint(".($subr)");
1472             $CPAN::Frontend->myprint(".");
1473             return;
1474         }
1475         warn @_;
1476     };
1477 }
1478
1479 #-> sub CPAN::Shell::reload ;
1480 sub reload {
1481     my($self,$command,@arg) = @_;
1482     $command ||= "";
1483     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1484     if ($command =~ /cpan/i) {
1485         CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1486         my $fh = FileHandle->new($INC{'CPAN.pm'});
1487         local($/);
1488         my $redef = 0;
1489         local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1490         eval <$fh>;
1491         warn $@ if $@;
1492         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1493     } elsif ($command =~ /index/) {
1494       CPAN::Index->force_reload;
1495     } else {
1496       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
1497 index    re-reads the index files\n});
1498     }
1499 }
1500
1501 #-> sub CPAN::Shell::_binary_extensions ;
1502 sub _binary_extensions {
1503     my($self) = shift @_;
1504     my(@result,$module,%seen,%need,$headerdone);
1505     for $module ($self->expand('Module','/./')) {
1506         my $file  = $module->cpan_file;
1507         next if $file eq "N/A";
1508         next if $file =~ /^Contact Author/;
1509         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1510         next if $dist->isa_perl;
1511         next unless $module->xs_file;
1512         local($|) = 1;
1513         $CPAN::Frontend->myprint(".");
1514         push @result, $module;
1515     }
1516 #    print join " | ", @result;
1517     $CPAN::Frontend->myprint("\n");
1518     return @result;
1519 }
1520
1521 #-> sub CPAN::Shell::recompile ;
1522 sub recompile {
1523     my($self) = shift @_;
1524     my($module,@module,$cpan_file,%dist);
1525     @module = $self->_binary_extensions();
1526     for $module (@module){  # we force now and compile later, so we
1527                             # don't do it twice
1528         $cpan_file = $module->cpan_file;
1529         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1530         $pack->force;
1531         $dist{$cpan_file}++;
1532     }
1533     for $cpan_file (sort keys %dist) {
1534         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1535         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1536         $pack->install;
1537         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1538                            # stop a package from recompiling,
1539                            # e.g. IO-1.12 when we have perl5.003_10
1540     }
1541 }
1542
1543 #-> sub CPAN::Shell::_u_r_common ;
1544 sub _u_r_common {
1545     my($self) = shift @_;
1546     my($what) = shift @_;
1547     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1548     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1549           $what && $what =~ /^[aru]$/;
1550     my(@args) = @_;
1551     @args = '/./' unless @args;
1552     my(@result,$module,%seen,%need,$headerdone,
1553        $version_undefs,$version_zeroes);
1554     $version_undefs = $version_zeroes = 0;
1555     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
1556     my @expand = $self->expand('Module',@args);
1557     my $expand = scalar @expand;
1558     if (0) { # Looks like noise to me, was very useful for debugging
1559              # for metadata cache
1560         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1561     }
1562     for $module (@expand) {
1563         my $file  = $module->cpan_file;
1564         next unless defined $file; # ??
1565         my($latest) = $module->cpan_version;
1566         my($inst_file) = $module->inst_file;
1567         my($have);
1568         return if $CPAN::Signal;
1569         if ($inst_file){
1570             if ($what eq "a") {
1571                 $have = $module->inst_version;
1572             } elsif ($what eq "r") {
1573                 $have = $module->inst_version;
1574                 local($^W) = 0;
1575                 if ($have eq "undef"){
1576                     $version_undefs++;
1577                 } elsif ($have == 0){
1578                     $version_zeroes++;
1579                 }
1580                 next unless CPAN::Version->vgt($latest, $have);
1581 # to be pedantic we should probably say:
1582 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1583 # to catch the case where CPAN has a version 0 and we have a version undef
1584             } elsif ($what eq "u") {
1585                 next;
1586             }
1587         } else {
1588             if ($what eq "a") {
1589                 next;
1590             } elsif ($what eq "r") {
1591                 next;
1592             } elsif ($what eq "u") {
1593                 $have = "-";
1594             }
1595         }
1596         return if $CPAN::Signal; # this is sometimes lengthy
1597         $seen{$file} ||= 0;
1598         if ($what eq "a") {
1599             push @result, sprintf "%s %s\n", $module->id, $have;
1600         } elsif ($what eq "r") {
1601             push @result, $module->id;
1602             next if $seen{$file}++;
1603         } elsif ($what eq "u") {
1604             push @result, $module->id;
1605             next if $seen{$file}++;
1606             next if $file =~ /^Contact/;
1607         }
1608         unless ($headerdone++){
1609             $CPAN::Frontend->myprint("\n");
1610             $CPAN::Frontend->myprint(sprintf(
1611                                              $sprintf,
1612                                              "",
1613                                              "Package namespace",
1614                                              "",
1615                                              "installed",
1616                                              "latest",
1617                                              "in CPAN file"
1618                                             ));
1619         }
1620         my $color_on = "";
1621         my $color_off = "";
1622         if (
1623             $COLOR_REGISTERED
1624             &&
1625             $CPAN::META->has_inst("Term::ANSIColor")
1626             &&
1627             $module->{RO}{description}
1628            ) {
1629             $color_on = Term::ANSIColor::color("green");
1630             $color_off = Term::ANSIColor::color("reset");
1631         }
1632         $CPAN::Frontend->myprint(sprintf $sprintf,
1633                                  $color_on,
1634                                  $module->id,
1635                                  $color_off,
1636                                  $have,
1637                                  $latest,
1638                                  $file);
1639         $need{$module->id}++;
1640     }
1641     unless (%need) {
1642         if ($what eq "u") {
1643             $CPAN::Frontend->myprint("No modules found for @args\n");
1644         } elsif ($what eq "r") {
1645             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1646         }
1647     }
1648     if ($what eq "r") {
1649         if ($version_zeroes) {
1650             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1651             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1652                 qq{a version number of 0\n});
1653         }
1654         if ($version_undefs) {
1655             my $s_has = $version_undefs > 1 ? "s have" : " has";
1656             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1657                 qq{parseable version number\n});
1658         }
1659     }
1660     @result;
1661 }
1662
1663 #-> sub CPAN::Shell::r ;
1664 sub r {
1665     shift->_u_r_common("r",@_);
1666 }
1667
1668 #-> sub CPAN::Shell::u ;
1669 sub u {
1670     shift->_u_r_common("u",@_);
1671 }
1672
1673 #-> sub CPAN::Shell::autobundle ;
1674 sub autobundle {
1675     my($self) = shift;
1676     CPAN::Config->load unless $CPAN::Config_loaded++;
1677     my(@bundle) = $self->_u_r_common("a",@_);
1678     my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1679     File::Path::mkpath($todir);
1680     unless (-d $todir) {
1681         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1682         return;
1683     }
1684     my($y,$m,$d) =  (localtime)[5,4,3];
1685     $y+=1900;
1686     $m++;
1687     my($c) = 0;
1688     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1689     my($to) = MM->catfile($todir,"$me.pm");
1690     while (-f $to) {
1691         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1692         $to = MM->catfile($todir,"$me.pm");
1693     }
1694     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1695     $fh->print(
1696                "package Bundle::$me;\n\n",
1697                "\$VERSION = '0.01';\n\n",
1698                "1;\n\n",
1699                "__END__\n\n",
1700                "=head1 NAME\n\n",
1701                "Bundle::$me - Snapshot of installation on ",
1702                $Config::Config{'myhostname'},
1703                " on ",
1704                scalar(localtime),
1705                "\n\n=head1 SYNOPSIS\n\n",
1706                "perl -MCPAN -e 'install Bundle::$me'\n\n",
1707                "=head1 CONTENTS\n\n",
1708                join("\n", @bundle),
1709                "\n\n=head1 CONFIGURATION\n\n",
1710                Config->myconfig,
1711                "\n\n=head1 AUTHOR\n\n",
1712                "This Bundle has been generated automatically ",
1713                "by the autobundle routine in CPAN.pm.\n",
1714               );
1715     $fh->close;
1716     $CPAN::Frontend->myprint("\nWrote bundle file
1717     $to\n\n");
1718 }
1719
1720 #-> sub CPAN::Shell::expandany ;
1721 sub expandany {
1722     my($self,$s) = @_;
1723     CPAN->debug("s[$s]") if $CPAN::DEBUG;
1724     if ($s =~ m|/|) { # looks like a file
1725         $s = CPAN::Distribution->normalize($s);
1726         return $CPAN::META->instance('CPAN::Distribution',$s);
1727         # Distributions spring into existence, not expand
1728     } elsif ($s =~ m|^Bundle::|) {
1729         $self->local_bundles; # scanning so late for bundles seems
1730                               # both attractive and crumpy: always
1731                               # current state but easy to forget
1732                               # somewhere
1733         return $self->expand('Bundle',$s);
1734     } else {
1735         return $self->expand('Module',$s)
1736             if $CPAN::META->exists('CPAN::Module',$s);
1737     }
1738     return;
1739 }
1740
1741 #-> sub CPAN::Shell::expand ;
1742 sub expand {
1743     shift;
1744     my($type,@args) = @_;
1745     my($arg,@m);
1746     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1747     for $arg (@args) {
1748         my($regex,$command);
1749         if ($arg =~ m|^/(.*)/$|) {
1750             $regex = $1;
1751         } elsif ($arg =~ m/=/) {
1752             $command = 1;
1753         }
1754         my $class = "CPAN::$type";
1755         my $obj;
1756         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1757                     $class,
1758                     defined $regex ? $regex : "UNDEFINED",
1759                     $command || "UNDEFINED",
1760                    ) if $CPAN::DEBUG;
1761         if (defined $regex) {
1762             for $obj (
1763                       sort
1764                       {$a->id cmp $b->id}
1765                       $CPAN::META->all_objects($class)
1766                      ) {
1767                 unless ($obj->id){
1768                     # BUG, we got an empty object somewhere
1769                     require Data::Dumper;
1770                     CPAN->debug(sprintf(
1771                                         "Bug in CPAN: Empty id on obj[%s][%s]",
1772                                         $obj,
1773                                         Data::Dumper::Dumper($obj)
1774                                        )) if $CPAN::DEBUG;
1775                     next;
1776                 }
1777                 push @m, $obj
1778                     if $obj->id =~ /$regex/i
1779                         or
1780                             (
1781                              (
1782                               $] < 5.00303 ### provide sort of
1783                               ### compatibility with 5.003
1784                               ||
1785                               $obj->can('name')
1786                              )
1787                              &&
1788                              $obj->name  =~ /$regex/i
1789                             );
1790             }
1791         } elsif ($command) {
1792             die "equal sign in command disabled (immature interface), ".
1793                 "you can set
1794  ! \$CPAN::Shell::ADVANCED_QUERY=1
1795 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1796 that may go away anytime.\n"
1797                     unless $ADVANCED_QUERY;
1798             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1799             my($matchcrit) = $criterion =~ m/^~(.+)/;
1800             for my $self (
1801                           sort
1802                           {$a->id cmp $b->id}
1803                           $CPAN::META->all_objects($class)
1804                          ) {
1805                 my $lhs = $self->$method() or next; # () for 5.00503
1806                 if ($matchcrit) {
1807                     push @m, $self if $lhs =~ m/$matchcrit/;
1808                 } else {
1809                     push @m, $self if $lhs eq $criterion;
1810                 }
1811             }
1812         } else {
1813             my($xarg) = $arg;
1814             if ( $type eq 'Bundle' ) {
1815                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1816             } elsif ($type eq "Distribution") {
1817                 $xarg = CPAN::Distribution->normalize($arg);
1818             }
1819             if ($CPAN::META->exists($class,$xarg)) {
1820                 $obj = $CPAN::META->instance($class,$xarg);
1821             } elsif ($CPAN::META->exists($class,$arg)) {
1822                 $obj = $CPAN::META->instance($class,$arg);
1823             } else {
1824                 next;
1825             }
1826             push @m, $obj;
1827         }
1828     }
1829     return wantarray ? @m : $m[0];
1830 }
1831
1832 #-> sub CPAN::Shell::format_result ;
1833 sub format_result {
1834     my($self) = shift;
1835     my($type,@args) = @_;
1836     @args = '/./' unless @args;
1837     my(@result) = $self->expand($type,@args);
1838     my $result = @result == 1 ?
1839         $result[0]->as_string :
1840             @result == 0 ?
1841                 "No objects of type $type found for argument @args\n" :
1842                     join("",
1843                          (map {$_->as_glimpse} @result),
1844                          scalar @result, " items found\n",
1845                         );
1846     $result;
1847 }
1848
1849 # The only reason for this method is currently to have a reliable
1850 # debugging utility that reveals which output is going through which
1851 # channel. No, I don't like the colors ;-)
1852
1853 #-> sub CPAN::Shell::print_ornameted ;
1854 sub print_ornamented {
1855     my($self,$what,$ornament) = @_;
1856     my $longest = 0;
1857     return unless defined $what;
1858
1859     if ($CPAN::Config->{term_is_latin}){
1860         # courtesy jhi:
1861         $what
1862             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1863     }
1864     if ($PRINT_ORNAMENTING) {
1865         unless (defined &color) {
1866             if ($CPAN::META->has_inst("Term::ANSIColor")) {
1867                 import Term::ANSIColor "color";
1868             } else {
1869                 *color = sub { return "" };
1870             }
1871         }
1872         my $line;
1873         for $line (split /\n/, $what) {
1874             $longest = length($line) if length($line) > $longest;
1875         }
1876         my $sprintf = "%-" . $longest . "s";
1877         while ($what){
1878             $what =~ s/(.*\n?)//m;
1879             my $line = $1;
1880             last unless $line;
1881             my($nl) = chomp $line ? "\n" : "";
1882             #   print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1883             print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1884         }
1885     } else {
1886         print $what;
1887     }
1888 }
1889
1890 sub myprint {
1891     my($self,$what) = @_;
1892
1893     $self->print_ornamented($what, 'bold blue on_yellow');
1894 }
1895
1896 sub myexit {
1897     my($self,$what) = @_;
1898     $self->myprint($what);
1899     exit;
1900 }
1901
1902 sub mywarn {
1903     my($self,$what) = @_;
1904     $self->print_ornamented($what, 'bold red on_yellow');
1905 }
1906
1907 sub myconfess {
1908     my($self,$what) = @_;
1909     $self->print_ornamented($what, 'bold red on_white');
1910     Carp::confess "died";
1911 }
1912
1913 sub mydie {
1914     my($self,$what) = @_;
1915     $self->print_ornamented($what, 'bold red on_white');
1916     die "\n";
1917 }
1918
1919 sub setup_output {
1920     return if -t STDOUT;
1921     my $odef = select STDERR;
1922     $| = 1;
1923     select STDOUT;
1924     $| = 1;
1925     select $odef;
1926 }
1927
1928 #-> sub CPAN::Shell::rematein ;
1929 # RE-adme||MA-ke||TE-st||IN-stall
1930 sub rematein {
1931     shift;
1932     my($meth,@some) = @_;
1933     my $pragma = "";
1934     if ($meth eq 'force') {
1935         $pragma = $meth;
1936         $meth = shift @some;
1937     }
1938     setup_output();
1939     CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1940
1941     # Here is the place to set "test_count" on all involved parties to
1942     # 0. We then can pass this counter on to the involved
1943     # distributions and those can refuse to test if test_count > X. In
1944     # the first stab at it we could use a 1 for "X".
1945
1946     # But when do I reset the distributions to start with 0 again?
1947     # Jost suggested to have a random or cycling interaction ID that
1948     # we pass through. But the ID is something that is just left lying
1949     # around in addition to the counter, so I'd prefer to set the
1950     # counter to 0 now, and repeat at the end of the loop. But what
1951     # about dependencies? They appear later and are not reset, they
1952     # enter the queue but not its copy. How do they get a sensible
1953     # test_count?
1954
1955     # construct the queue
1956     my($s,@s,@qcopy);
1957     foreach $s (@some) {
1958         my $obj;
1959         if (ref $s) {
1960             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1961             $obj = $s;
1962         } elsif ($s =~ m|^/|) { # looks like a regexp
1963             $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1964                                     "not supported\n");
1965             sleep 2;
1966             next;
1967         } else {
1968             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1969             $obj = CPAN::Shell->expandany($s);
1970         }
1971         if (ref $obj) {
1972             $obj->color_cmd_tmps(0,1);
1973             CPAN::Queue->new($obj->id);
1974             push @qcopy, $obj;
1975         } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1976             $obj = $CPAN::META->instance('CPAN::Author',$s);
1977             if ($meth eq "dump") {
1978                 $obj->dump;
1979             } else {
1980                 $CPAN::Frontend->myprint(
1981                                          join "",
1982                                          "Don't be silly, you can't $meth ",
1983                                          $obj->fullname,
1984                                          " ;-)\n"
1985                                         );
1986                 sleep 2;
1987             }
1988         } else {
1989             $CPAN::Frontend
1990                 ->myprint(qq{Warning: Cannot $meth $s, }.
1991                           qq{don\'t know what it is.
1992 Try the command
1993
1994     i /$s/
1995
1996 to find objects with matching identifiers.
1997 });
1998             sleep 2;
1999         }
2000     }
2001
2002     # queuerunner (please be warned: when I started to change the
2003     # queue to hold objects instead of names, I made one or two
2004     # mistakes and never found which. I reverted back instead)
2005     while ($s = CPAN::Queue->first) {
2006         my $obj;
2007         if (ref $s) {
2008             $obj = $s; # I do not believe, we would survive if this happened
2009         } else {
2010             $obj = CPAN::Shell->expandany($s);
2011         }
2012         if ($pragma
2013             &&
2014             ($] < 5.00303 || $obj->can($pragma))){
2015             ### compatibility with 5.003
2016             $obj->$pragma($meth); # the pragma "force" in
2017                                   # "CPAN::Distribution" must know
2018                                   # what we are intending
2019         }
2020         if ($]>=5.00303 && $obj->can('called_for')) {
2021             $obj->called_for($s);
2022         }
2023         CPAN->debug(
2024                     qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2025                     $obj->as_string.
2026                     qq{\]}
2027                    ) if $CPAN::DEBUG;
2028
2029         if ($obj->$meth()){
2030             CPAN::Queue->delete($s);
2031         } else {
2032             CPAN->debug("failed");
2033         }
2034
2035         $obj->undelay;
2036         CPAN::Queue->delete_first($s);
2037     }
2038     for my $obj (@qcopy) {
2039         $obj->color_cmd_tmps(0,0);
2040     }
2041 }
2042
2043 #-> sub CPAN::Shell::dump ;
2044 sub dump    { shift->rematein('dump',@_); }
2045 #-> sub CPAN::Shell::force ;
2046 sub force   { shift->rematein('force',@_); }
2047 #-> sub CPAN::Shell::get ;
2048 sub get     { shift->rematein('get',@_); }
2049 #-> sub CPAN::Shell::readme ;
2050 sub readme  { shift->rematein('readme',@_); }
2051 #-> sub CPAN::Shell::make ;
2052 sub make    { shift->rematein('make',@_); }
2053 #-> sub CPAN::Shell::test ;
2054 sub test    { shift->rematein('test',@_); }
2055 #-> sub CPAN::Shell::install ;
2056 sub install { shift->rematein('install',@_); }
2057 #-> sub CPAN::Shell::clean ;
2058 sub clean   { shift->rematein('clean',@_); }
2059 #-> sub CPAN::Shell::look ;
2060 sub look   { shift->rematein('look',@_); }
2061 #-> sub CPAN::Shell::cvs_import ;
2062 sub cvs_import   { shift->rematein('cvs_import',@_); }
2063
2064 package CPAN::LWP::UserAgent;
2065
2066 sub config {
2067     return if $SETUPDONE;
2068     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2069         require LWP::UserAgent;
2070         @ISA = qw(Exporter LWP::UserAgent);
2071         $SETUPDONE++;
2072     } else {
2073         $CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
2074     }
2075 }
2076
2077 sub get_basic_credentials {
2078     my($self, $realm, $uri, $proxy) = @_;
2079     return unless $proxy;
2080     if ($USER && $PASSWD) {
2081     } elsif (defined $CPAN::Config->{proxy_user} &&
2082         defined $CPAN::Config->{proxy_pass}) {
2083         $USER = $CPAN::Config->{proxy_user};
2084         $PASSWD = $CPAN::Config->{proxy_pass};
2085     } else {
2086         require ExtUtils::MakeMaker;
2087         ExtUtils::MakeMaker->import(qw(prompt));
2088         $USER = prompt("Proxy authentication needed!
2089  (Note: to permanently configure username and password run
2090    o conf proxy_user your_username
2091    o conf proxy_pass your_password
2092  )\nUsername:");
2093         if ($CPAN::META->has_inst("Term::ReadKey")) {
2094             Term::ReadKey::ReadMode("noecho");
2095         } else {
2096             $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2097         }
2098         $PASSWD = prompt("Password:");
2099         if ($CPAN::META->has_inst("Term::ReadKey")) {
2100             Term::ReadKey::ReadMode("restore");
2101         }
2102         $CPAN::Frontend->myprint("\n\n");
2103     }
2104     return($USER,$PASSWD);
2105 }
2106
2107 sub mirror {
2108     my($self,$url,$aslocal) = @_;
2109     my $result = $self->SUPER::mirror($url,$aslocal);
2110     if ($result->code == 407) {
2111         undef $USER;
2112         undef $PASSWD;
2113         $result = $self->SUPER::mirror($url,$aslocal);
2114     }
2115     $result;
2116 }
2117
2118 package CPAN::FTP;
2119
2120 #-> sub CPAN::FTP::ftp_get ;
2121 sub ftp_get {
2122   my($class,$host,$dir,$file,$target) = @_;
2123   $class->debug(
2124                 qq[Going to fetch file [$file] from dir [$dir]
2125         on host [$host] as local [$target]\n]
2126                       ) if $CPAN::DEBUG;
2127   my $ftp = Net::FTP->new($host);
2128   return 0 unless defined $ftp;
2129   $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2130   $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2131   unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2132     warn "Couldn't login on $host";
2133     return;
2134   }
2135   unless ( $ftp->cwd($dir) ){
2136     warn "Couldn't cwd $dir";
2137     return;
2138   }
2139   $ftp->binary;
2140   $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2141   unless ( $ftp->get($file,$target) ){
2142     warn "Couldn't fetch $file from $host\n";
2143     return;
2144   }
2145   $ftp->quit; # it's ok if this fails
2146   return 1;
2147 }
2148
2149 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2150
2151  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
2152  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
2153  # > ***************
2154  # > *** 1562,1567 ****
2155  # > --- 1562,1580 ----
2156  # >       return 1 if substr($url,0,4) eq "file";
2157  # >       return 1 unless $url =~ m|://([^/]+)|;
2158  # >       my $host = $1;
2159  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2160  # > +     if ($proxy) {
2161  # > +         $proxy =~ m|://([^/:]+)|;
2162  # > +         $proxy = $1;
2163  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2164  # > +         if ($noproxy) {
2165  # > +             if ($host !~ /$noproxy$/) {
2166  # > +                 $host = $proxy;
2167  # > +             }
2168  # > +         } else {
2169  # > +             $host = $proxy;
2170  # > +         }
2171  # > +     }
2172  # >       require Net::Ping;
2173  # >       return 1 unless $Net::Ping::VERSION >= 2;
2174  # >       my $p;
2175
2176
2177 #-> sub CPAN::FTP::localize ;
2178 sub localize {
2179     my($self,$file,$aslocal,$force) = @_;
2180     $force ||= 0;
2181     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2182         unless defined $aslocal;
2183     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2184         if $CPAN::DEBUG;
2185
2186     if ($^O eq 'MacOS') {
2187         # Comment by AK on 2000-09-03: Uniq short filenames would be
2188         # available in CHECKSUMS file
2189         my($name, $path) = File::Basename::fileparse($aslocal, '');
2190         if (length($name) > 31) {
2191             $name =~ s/(
2192                         \.(
2193                            readme(\.(gz|Z))? |
2194                            (tar\.)?(gz|Z) |
2195                            tgz |
2196                            zip |
2197                            pm\.(gz|Z)
2198                           )
2199                        )$//x;
2200             my $suf = $1;
2201             my $size = 31 - length($suf);
2202             while (length($name) > $size) {
2203                 chop $name;
2204             }
2205             $name .= $suf;
2206             $aslocal = File::Spec->catfile($path, $name);
2207         }
2208     }
2209
2210     return $aslocal if -f $aslocal && -r _ && !($force & 1);
2211     my($restore) = 0;
2212     if (-f $aslocal){
2213         rename $aslocal, "$aslocal.bak";
2214         $restore++;
2215     }
2216
2217     my($aslocal_dir) = File::Basename::dirname($aslocal);
2218     File::Path::mkpath($aslocal_dir);
2219     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2220         qq{directory "$aslocal_dir".
2221     I\'ll continue, but if you encounter problems, they may be due
2222     to insufficient permissions.\n}) unless -w $aslocal_dir;
2223
2224     # Inheritance is not easier to manage than a few if/else branches
2225     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2226         unless ($Ua) {
2227             CPAN::LWP::UserAgent->config;
2228             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2229             if ($@) {
2230                 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
2231                     if $CPAN::DEBUG;
2232             } else {
2233                 my($var);
2234                 $Ua->proxy('ftp',  $var)
2235                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2236                 $Ua->proxy('http', $var)
2237                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2238
2239
2240 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2241 #
2242 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2243 #  > use ones that require basic autorization.
2244 #
2245 #  > Example of when I use it manually in my own stuff:
2246 #
2247 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2248 #  > $req->proxy_authorization_basic("username","password");
2249 #  > $res = $ua->request($req);
2250 #
2251
2252                 $Ua->no_proxy($var)
2253                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2254             }
2255         }
2256     }
2257     $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2258     $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2259         if $CPAN::Config->{http_proxy};
2260     $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2261
2262     # Try the list of urls for each single object. We keep a record
2263     # where we did get a file from
2264     my(@reordered,$last);
2265     $CPAN::Config->{urllist} ||= [];
2266     $last = $#{$CPAN::Config->{urllist}};
2267     if ($force & 2) { # local cpans probably out of date, don't reorder
2268         @reordered = (0..$last);
2269     } else {
2270         @reordered =
2271             sort {
2272                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2273                     <=>
2274                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2275                     or
2276                 defined($Thesite)
2277                     and
2278                 ($b == $Thesite)
2279                     <=>
2280                 ($a == $Thesite)
2281             } 0..$last;
2282     }
2283     my(@levels);
2284     if ($Themethod) {
2285         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2286     } else {
2287         @levels = qw/easy hard hardest/;
2288     }
2289     @levels = qw/easy/ if $^O eq 'MacOS';
2290     my($levelno);
2291     for $levelno (0..$#levels) {
2292         my $level = $levels[$levelno];
2293         my $method = "host$level";
2294         my @host_seq = $level eq "easy" ?
2295             @reordered : 0..$last;  # reordered has CDROM up front
2296         @host_seq = (0) unless @host_seq;
2297         my $ret = $self->$method(\@host_seq,$file,$aslocal);
2298         if ($ret) {
2299           $Themethod = $level;
2300           my $now = time;
2301           # utime $now, $now, $aslocal; # too bad, if we do that, we
2302                                       # might alter a local mirror
2303           $self->debug("level[$level]") if $CPAN::DEBUG;
2304           return $ret;
2305         } else {
2306           unlink $aslocal;
2307           last if $CPAN::Signal; # need to cleanup
2308         }
2309     }
2310     unless ($CPAN::Signal) {
2311         my(@mess);
2312         push @mess,
2313             qq{Please check, if the URLs I found in your configuration file \(}.
2314                 join(", ", @{$CPAN::Config->{urllist}}).
2315                     qq{\) are valid. The urllist can be edited.},
2316                         qq{E.g. with 'o conf urllist push ftp://myurl/'};
2317         $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2318         sleep 2;
2319         $CPAN::Frontend->myprint("Could not fetch $file\n");
2320     }
2321     if ($restore) {
2322         rename "$aslocal.bak", $aslocal;
2323         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2324                                  $self->ls($aslocal));
2325         return $aslocal;
2326     }
2327     return;
2328 }
2329
2330 sub hosteasy {
2331     my($self,$host_seq,$file,$aslocal) = @_;
2332     my($i);
2333   HOSTEASY: for $i (@$host_seq) {
2334         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2335         $url .= "/" unless substr($url,-1) eq "/";
2336         $url .= $file;
2337         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2338         if ($url =~ /^file:/) {
2339             my $l;
2340             if ($CPAN::META->has_inst('URI::URL')) {
2341                 my $u =  URI::URL->new($url);
2342                 $l = $u->path;
2343             } else { # works only on Unix, is poorly constructed, but
2344                 # hopefully better than nothing.
2345                 # RFC 1738 says fileurl BNF is
2346                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2347                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2348                 # the code
2349                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2350                 $l =~ s|^file:||;                   # assume they
2351                                                     # meant
2352                                                     # file://localhost
2353                 $l =~ s|^/||s unless -f $l;         # e.g. /P:
2354                 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2355             }
2356             if ( -f $l && -r _) {
2357                 $Thesite = $i;
2358                 return $l;
2359             }
2360             # Maybe mirror has compressed it?
2361             if (-f "$l.gz") {
2362                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2363                 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2364                 if ( -f $aslocal) {
2365                     $Thesite = $i;
2366                     return $aslocal;
2367                 }
2368             }
2369         }
2370         if ($CPAN::META->has_usable('LWP')) {
2371           $CPAN::Frontend->myprint("Fetching with LWP:
2372   $url
2373 ");
2374           unless ($Ua) {
2375               CPAN::LWP::UserAgent->config;
2376               eval { $Ua = CPAN::LWP::UserAgent->new; };
2377               if ($@) {
2378                   $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
2379               }
2380           }
2381           my $res = $Ua->mirror($url, $aslocal);
2382           if ($res->is_success) {
2383             $Thesite = $i;
2384             my $now = time;
2385             utime $now, $now, $aslocal; # download time is more
2386                                         # important than upload time
2387             return $aslocal;
2388           } elsif ($url !~ /\.gz(?!\n)\Z/) {
2389             my $gzurl = "$url.gz";
2390             $CPAN::Frontend->myprint("Fetching with LWP:
2391   $gzurl
2392 ");
2393             $res = $Ua->mirror($gzurl, "$aslocal.gz");
2394             if ($res->is_success &&
2395                 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2396                ) {
2397               $Thesite = $i;
2398               return $aslocal;
2399             }
2400           } else {
2401               $CPAN::Frontend->myprint(sprintf(
2402                                                "LWP failed with code[%s] message[%s]\n",
2403                                                $res->code,
2404                                                $res->message,
2405                                               ));
2406             # Alan Burlison informed me that in firewall environments
2407             # Net::FTP can still succeed where LWP fails. So we do not
2408             # skip Net::FTP anymore when LWP is available.
2409           }
2410         } else {
2411             $CPAN::Frontend->myprint("LWP not available\n");
2412         }
2413         return if $CPAN::Signal;
2414         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2415             # that's the nice and easy way thanks to Graham
2416             my($host,$dir,$getfile) = ($1,$2,$3);
2417             if ($CPAN::META->has_usable('Net::FTP')) {
2418                 $dir =~ s|/+|/|g;
2419                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2420   $url
2421 ");
2422                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2423                              "aslocal[$aslocal]") if $CPAN::DEBUG;
2424                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2425                     $Thesite = $i;
2426                     return $aslocal;
2427                 }
2428                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2429                     my $gz = "$aslocal.gz";
2430                     $CPAN::Frontend->myprint("Fetching with Net::FTP
2431   $url.gz
2432 ");
2433                    if (CPAN::FTP->ftp_get($host,
2434                                            $dir,
2435                                            "$getfile.gz",
2436                                            $gz) &&
2437                         CPAN::Tarzip->gunzip($gz,$aslocal)
2438                        ){
2439                         $Thesite = $i;
2440                         return $aslocal;
2441                     }
2442                 }
2443                 # next HOSTEASY;
2444             }
2445         }
2446         return if $CPAN::Signal;
2447     }
2448 }
2449
2450 sub hosthard {
2451   my($self,$host_seq,$file,$aslocal) = @_;
2452
2453   # Came back if Net::FTP couldn't establish connection (or
2454   # failed otherwise) Maybe they are behind a firewall, but they
2455   # gave us a socksified (or other) ftp program...
2456
2457   my($i);
2458   my($devnull) = $CPAN::Config->{devnull} || "";
2459   # < /dev/null ";
2460   my($aslocal_dir) = File::Basename::dirname($aslocal);
2461   File::Path::mkpath($aslocal_dir);
2462   HOSTHARD: for $i (@$host_seq) {
2463         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2464         $url .= "/" unless substr($url,-1) eq "/";
2465         $url .= $file;
2466         my($proto,$host,$dir,$getfile);
2467
2468         # Courtesy Mark Conty mark_conty@cargill.com change from
2469         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2470         # to
2471         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2472           # proto not yet used
2473           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2474         } else {
2475           next HOSTHARD; # who said, we could ftp anything except ftp?
2476         }
2477         next HOSTHARD if $proto eq "file"; # file URLs would have had
2478                                            # success above. Likely a bogus URL
2479
2480         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2481         my($f,$funkyftp);
2482         for $f ('lynx','ncftpget','ncftp','wget') {
2483           next unless exists $CPAN::Config->{$f};
2484           $funkyftp = $CPAN::Config->{$f};
2485           next unless defined $funkyftp;
2486           next if $funkyftp =~ /^\s*$/;
2487           my($asl_ungz, $asl_gz);
2488           ($asl_ungz = $aslocal) =~ s/\.gz//;
2489           $asl_gz = "$asl_ungz.gz";
2490           my($src_switch) = "";
2491           if ($f eq "lynx"){
2492             $src_switch = " -source";
2493           } elsif ($f eq "ncftp"){
2494             $src_switch = " -c";
2495           } elsif ($f eq "wget"){
2496               $src_switch = " -O -";
2497           }
2498           my($chdir) = "";
2499           my($stdout_redir) = " > $asl_ungz";
2500           if ($f eq "ncftpget"){
2501             $chdir = "cd $aslocal_dir && ";
2502             $stdout_redir = "";
2503           }
2504           $CPAN::Frontend->myprint(
2505                                    qq[
2506 Trying with "$funkyftp$src_switch" to get
2507     $url
2508 ]);
2509           my($system) =
2510               "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2511           $self->debug("system[$system]") if $CPAN::DEBUG;
2512           my($wstatus);
2513           if (($wstatus = system($system)) == 0
2514               &&
2515               ($f eq "lynx" ?
2516                -s $asl_ungz # lynx returns 0 when it fails somewhere
2517                : 1
2518               )
2519              ) {
2520             if (-s $aslocal) {
2521               # Looks good
2522             } elsif ($asl_ungz ne $aslocal) {
2523               # test gzip integrity
2524               if (CPAN::Tarzip->gtest($asl_ungz)) {
2525                   # e.g. foo.tar is gzipped --> foo.tar.gz
2526                   rename $asl_ungz, $aslocal;
2527               } else {
2528                   CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2529               }
2530             }
2531             $Thesite = $i;
2532             return $aslocal;
2533           } elsif ($url !~ /\.gz(?!\n)\Z/) {
2534             unlink $asl_ungz if
2535                 -f $asl_ungz && -s _ == 0;
2536             my $gz = "$aslocal.gz";
2537             my $gzurl = "$url.gz";
2538             $CPAN::Frontend->myprint(
2539                                      qq[
2540 Trying with "$funkyftp$src_switch" to get
2541   $url.gz
2542 ]);
2543             my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2544             $self->debug("system[$system]") if $CPAN::DEBUG;
2545             my($wstatus);
2546             if (($wstatus = system($system)) == 0
2547                 &&
2548                 -s $asl_gz
2549                ) {
2550               # test gzip integrity
2551               if (CPAN::Tarzip->gtest($asl_gz)) {
2552                   CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2553               } else {
2554                   # somebody uncompressed file for us?
2555                   rename $asl_ungz, $aslocal;
2556               }
2557               $Thesite = $i;
2558               return $aslocal;
2559             } else {
2560               unlink $asl_gz if -f $asl_gz;
2561             }
2562           } else {
2563             my $estatus = $wstatus >> 8;
2564             my $size = -f $aslocal ?
2565                 ", left\n$aslocal with size ".-s _ :
2566                     "\nWarning: expected file [$aslocal] doesn't exist";
2567             $CPAN::Frontend->myprint(qq{
2568 System call "$system"
2569 returned status $estatus (wstat $wstatus)$size
2570 });
2571           }
2572           return if $CPAN::Signal;
2573         } # lynx,ncftpget,ncftp
2574     } # host
2575 }
2576
2577 sub hosthardest {
2578     my($self,$host_seq,$file,$aslocal) = @_;
2579
2580     my($i);
2581     my($aslocal_dir) = File::Basename::dirname($aslocal);
2582     File::Path::mkpath($aslocal_dir);
2583   HOSTHARDEST: for $i (@$host_seq) {
2584         unless (length $CPAN::Config->{'ftp'}) {
2585             $CPAN::Frontend->myprint("No external ftp command available\n\n");
2586             last HOSTHARDEST;
2587         }
2588         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2589         $url .= "/" unless substr($url,-1) eq "/";
2590         $url .= $file;
2591         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2592         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2593             next;
2594         }
2595         my($host,$dir,$getfile) = ($1,$2,$3);
2596         my $timestamp = 0;
2597         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2598            $ctime,$blksize,$blocks) = stat($aslocal);
2599         $timestamp = $mtime ||= 0;
2600         my($netrc) = CPAN::FTP::netrc->new;
2601         my($netrcfile) = $netrc->netrc;
2602         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2603         my $targetfile = File::Basename::basename($aslocal);
2604         my(@dialog);
2605         push(
2606              @dialog,
2607              "lcd $aslocal_dir",
2608              "cd /",
2609              map("cd $_", split "/", $dir), # RFC 1738
2610              "bin",
2611              "get $getfile $targetfile",
2612              "quit"
2613             );
2614         if (! $netrcfile) {
2615             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2616         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2617             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2618                                 $netrc->hasdefault,
2619                                 $netrc->contains($host))) if $CPAN::DEBUG;
2620             if ($netrc->protected) {
2621                 $CPAN::Frontend->myprint(qq{
2622   Trying with external ftp to get
2623     $url
2624   As this requires some features that are not thoroughly tested, we\'re
2625   not sure, that we get it right....
2626
2627 }
2628                      );
2629                 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2630                                 @dialog);
2631                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2632                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2633                 $mtime ||= 0;
2634                 if ($mtime > $timestamp) {
2635                     $CPAN::Frontend->myprint("GOT $aslocal\n");
2636                     $Thesite = $i;
2637                     return $aslocal;
2638                 } else {
2639                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2640                 }
2641                 return if $CPAN::Signal;
2642             } else {
2643                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2644                                         qq{correctly protected.\n});
2645             }
2646         } else {
2647             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2648   nor does it have a default entry\n");
2649         }
2650
2651         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2652         # then and login manually to host, using e-mail as
2653         # password.
2654         $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2655         unshift(
2656                 @dialog,
2657                 "open $host",
2658                 "user anonymous $Config::Config{'cf_email'}"
2659                );
2660         $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2661         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2662          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2663         $mtime ||= 0;
2664         if ($mtime > $timestamp) {
2665             $CPAN::Frontend->myprint("GOT $aslocal\n");
2666             $Thesite = $i;
2667             return $aslocal;
2668         } else {
2669             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2670         }
2671         return if $CPAN::Signal;
2672         $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2673         sleep 2;
2674     } # host
2675 }
2676
2677 sub talk_ftp {
2678     my($self,$command,@dialog) = @_;
2679     my $fh = FileHandle->new;
2680     $fh->open("|$command") or die "Couldn't open ftp: $!";
2681     foreach (@dialog) { $fh->print("$_\n") }
2682     $fh->close;         # Wait for process to complete
2683     my $wstatus = $?;
2684     my $estatus = $wstatus >> 8;
2685     $CPAN::Frontend->myprint(qq{
2686 Subprocess "|$command"
2687   returned status $estatus (wstat $wstatus)
2688 }) if $wstatus;
2689 }
2690
2691 # find2perl needs modularization, too, all the following is stolen
2692 # from there
2693 # CPAN::FTP::ls
2694 sub ls {
2695     my($self,$name) = @_;
2696     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2697      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2698
2699     my($perms,%user,%group);
2700     my $pname = $name;
2701
2702     if ($blocks) {
2703         $blocks = int(($blocks + 1) / 2);
2704     }
2705     else {
2706         $blocks = int(($sizemm + 1023) / 1024);
2707     }
2708
2709     if    (-f _) { $perms = '-'; }
2710     elsif (-d _) { $perms = 'd'; }
2711     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2712     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2713     elsif (-p _) { $perms = 'p'; }
2714     elsif (-S _) { $perms = 's'; }
2715     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2716
2717     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2718     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2719     my $tmpmode = $mode;
2720     my $tmp = $rwx[$tmpmode & 7];
2721     $tmpmode >>= 3;
2722     $tmp = $rwx[$tmpmode & 7] . $tmp;
2723     $tmpmode >>= 3;
2724     $tmp = $rwx[$tmpmode & 7] . $tmp;
2725     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2726     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2727     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2728     $perms .= $tmp;
2729
2730     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
2731     my $group = $group{$gid} || $gid;
2732
2733     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2734     my($timeyear);
2735     my($moname) = $moname[$mon];
2736     if (-M _ > 365.25 / 2) {
2737         $timeyear = $year + 1900;
2738     }
2739     else {
2740         $timeyear = sprintf("%02d:%02d", $hour, $min);
2741     }
2742
2743     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2744             $ino,
2745                  $blocks,
2746                       $perms,
2747                             $nlink,
2748                                 $user,
2749                                      $group,
2750                                           $sizemm,
2751                                               $moname,
2752                                                  $mday,
2753                                                      $timeyear,
2754                                                          $pname;
2755 }
2756
2757 package CPAN::FTP::netrc;
2758
2759 sub new {
2760     my($class) = @_;
2761     my $file = MM->catfile($ENV{HOME},".netrc");
2762
2763     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2764        $atime,$mtime,$ctime,$blksize,$blocks)
2765         = stat($file);
2766     $mode ||= 0;
2767     my $protected = 0;
2768
2769     my($fh,@machines,$hasdefault);
2770     $hasdefault = 0;
2771     $fh = FileHandle->new or die "Could not create a filehandle";
2772
2773     if($fh->open($file)){
2774         $protected = ($mode & 077) == 0;
2775         local($/) = "";
2776       NETRC: while (<$fh>) {
2777             my(@tokens) = split " ", $_;
2778           TOKEN: while (@tokens) {
2779                 my($t) = shift @tokens;
2780                 if ($t eq "default"){
2781                     $hasdefault++;
2782                     last NETRC;
2783                 }
2784                 last TOKEN if $t eq "macdef";
2785                 if ($t eq "machine") {
2786                     push @machines, shift @tokens;
2787                 }
2788             }
2789         }
2790     } else {
2791         $file = $hasdefault = $protected = "";
2792     }
2793
2794     bless {
2795            'mach' => [@machines],
2796            'netrc' => $file,
2797            'hasdefault' => $hasdefault,
2798            'protected' => $protected,
2799           }, $class;
2800 }
2801
2802 # CPAN::FTP::hasdefault;
2803 sub hasdefault { shift->{'hasdefault'} }
2804 sub netrc      { shift->{'netrc'}      }
2805 sub protected  { shift->{'protected'}  }
2806 sub contains {
2807     my($self,$mach) = @_;
2808     for ( @{$self->{'mach'}} ) {
2809         return 1 if $_ eq $mach;
2810     }
2811     return 0;
2812 }
2813
2814 package CPAN::Complete;
2815
2816 sub gnu_cpl {
2817     my($text, $line, $start, $end) = @_;
2818     my(@perlret) = cpl($text, $line, $start);
2819     # find longest common match. Can anybody show me how to peruse
2820     # T::R::Gnu to have this done automatically? Seems expensive.
2821     return () unless @perlret;
2822     my($newtext) = $text;
2823     for (my $i = length($text)+1;;$i++) {
2824         last unless length($perlret[0]) && length($perlret[0]) >= $i;
2825         my $try = substr($perlret[0],0,$i);
2826         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2827         # warn "try[$try]tries[@tries]";
2828         if (@tries == @perlret) {
2829             $newtext = $try;
2830         } else {
2831             last;
2832         }
2833     }
2834     ($newtext,@perlret);
2835 }
2836
2837 #-> sub CPAN::Complete::cpl ;
2838 sub cpl {
2839     my($word,$line,$pos) = @_;
2840     $word ||= "";
2841     $line ||= "";
2842     $pos ||= 0;
2843     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2844     $line =~ s/^\s*//;
2845     if ($line =~ s/^(force\s*)//) {
2846         $pos -= length($1);
2847     }
2848     my @return;
2849     if ($pos == 0) {
2850         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2851     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2852         @return = ();
2853     } elsif ($line =~ /^(a|ls)\s/) {
2854         @return = cplx('CPAN::Author',uc($word));
2855     } elsif ($line =~ /^b\s/) {
2856         CPAN::Shell->local_bundles;
2857         @return = cplx('CPAN::Bundle',$word);
2858     } elsif ($line =~ /^d\s/) {
2859         @return = cplx('CPAN::Distribution',$word);
2860     } elsif ($line =~ m/^(
2861                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2862                          )\s/x ) {
2863         if ($word =~ /^Bundle::/) {
2864             CPAN::Shell->local_bundles;
2865         }
2866         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2867     } elsif ($line =~ /^i\s/) {
2868         @return = cpl_any($word);
2869     } elsif ($line =~ /^reload\s/) {
2870         @return = cpl_reload($word,$line,$pos);
2871     } elsif ($line =~ /^o\s/) {
2872         @return = cpl_option($word,$line,$pos);
2873     } elsif ($line =~ m/^\S+\s/ ) {
2874         # fallback for future commands and what we have forgotten above
2875         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2876     } else {
2877         @return = ();
2878     }
2879     return @return;
2880 }
2881
2882 #-> sub CPAN::Complete::cplx ;
2883 sub cplx {
2884     my($class, $word) = @_;
2885     # I believed for many years that this was sorted, today I
2886     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2887     # make it sorted again. Maybe sort was dropped when GNU-readline
2888     # support came in? The RCS file is difficult to read on that:-(
2889     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2890 }
2891
2892 #-> sub CPAN::Complete::cpl_any ;
2893 sub cpl_any {
2894     my($word) = shift;
2895     return (
2896             cplx('CPAN::Author',$word),
2897             cplx('CPAN::Bundle',$word),
2898             cplx('CPAN::Distribution',$word),
2899             cplx('CPAN::Module',$word),
2900            );
2901 }
2902
2903 #-> sub CPAN::Complete::cpl_reload ;
2904 sub cpl_reload {
2905     my($word,$line,$pos) = @_;
2906     $word ||= "";
2907     my(@words) = split " ", $line;
2908     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2909     my(@ok) = qw(cpan index);
2910     return @ok if @words == 1;
2911     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2912 }
2913
2914 #-> sub CPAN::Complete::cpl_option ;
2915 sub cpl_option {
2916     my($word,$line,$pos) = @_;
2917     $word ||= "";
2918     my(@words) = split " ", $line;
2919     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2920     my(@ok) = qw(conf debug);
2921     return @ok if @words == 1;
2922     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2923     if (0) {
2924     } elsif ($words[1] eq 'index') {
2925         return ();
2926     } elsif ($words[1] eq 'conf') {
2927         return CPAN::Config::cpl(@_);
2928     } elsif ($words[1] eq 'debug') {
2929         return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2930     }
2931 }
2932
2933 package CPAN::Index;
2934
2935 #-> sub CPAN::Index::force_reload ;
2936 sub force_reload {
2937     my($class) = @_;
2938     $CPAN::Index::LAST_TIME = 0;
2939     $class->reload(1);
2940 }
2941
2942 #-> sub CPAN::Index::reload ;
2943 sub reload {
2944     my($cl,$force) = @_;
2945     my $time = time;
2946
2947     # XXX check if a newer one is available. (We currently read it
2948     # from time to time)
2949     for ($CPAN::Config->{index_expire}) {
2950         $_ = 0.001 unless $_ && $_ > 0.001;
2951     }
2952     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2953         # debug here when CPAN doesn't seem to read the Metadata
2954         require Carp;
2955         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2956     }
2957     unless ($CPAN::META->{PROTOCOL}) {
2958         $cl->read_metadata_cache;
2959         $CPAN::META->{PROTOCOL} ||= "1.0";
2960     }
2961     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
2962         # warn "Setting last_time to 0";
2963         $LAST_TIME = 0; # No warning necessary
2964     }
2965     return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
2966         and ! $force;
2967     if (0) {
2968         # IFF we are developing, it helps to wipe out the memory
2969         # between reloads, otherwise it is not what a user expects.
2970         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2971         $CPAN::META = CPAN->new;
2972     }
2973     {
2974         my($debug,$t2);
2975         local $LAST_TIME = $time;
2976         local $CPAN::META->{PROTOCOL} = PROTOCOL;
2977
2978         my $needshort = $^O eq "dos";
2979
2980         $cl->rd_authindex($cl
2981                           ->reload_x(
2982                                      "authors/01mailrc.txt.gz",
2983                                      $needshort ?
2984                                      File::Spec->catfile('authors', '01mailrc.gz') :
2985                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
2986                                      $force));
2987         $t2 = time;
2988         $debug = "timing reading 01[".($t2 - $time)."]";
2989         $time = $t2;
2990         return if $CPAN::Signal; # this is sometimes lengthy
2991         $cl->rd_modpacks($cl
2992                          ->reload_x(
2993                                     "modules/02packages.details.txt.gz",
2994                                     $needshort ?
2995                                     File::Spec->catfile('modules', '02packag.gz') :
2996                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
2997                                     $force));
2998         $t2 = time;
2999         $debug .= "02[".($t2 - $time)."]";
3000         $time = $t2;
3001         return if $CPAN::Signal; # this is sometimes lengthy
3002         $cl->rd_modlist($cl
3003                         ->reload_x(
3004                                    "modules/03modlist.data.gz",
3005                                    $needshort ?
3006                                    File::Spec->catfile('modules', '03mlist.gz') :
3007                                    File::Spec->catfile('modules', '03modlist.data.gz'),
3008                                    $force));
3009         $cl->write_metadata_cache;
3010         $t2 = time;
3011         $debug .= "03[".($t2 - $time)."]";
3012         $time = $t2;
3013         CPAN->debug($debug) if $CPAN::DEBUG;
3014     }
3015     $LAST_TIME = $time;
3016     $CPAN::META->{PROTOCOL} = PROTOCOL;
3017 }
3018
3019 #-> sub CPAN::Index::reload_x ;
3020 sub reload_x {
3021     my($cl,$wanted,$localname,$force) = @_;
3022     $force |= 2; # means we're dealing with an index here
3023     CPAN::Config->load; # we should guarantee loading wherever we rely
3024                         # on Config XXX
3025     $localname ||= $wanted;
3026     my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
3027                                    $localname);
3028     if (
3029         -f $abs_wanted &&
3030         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3031         !($force & 1)
3032        ) {
3033         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3034         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3035                    qq{day$s. I\'ll use that.});
3036         return $abs_wanted;
3037     } else {
3038         $force |= 1; # means we're quite serious about it.
3039     }
3040     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3041 }
3042
3043 #-> sub CPAN::Index::rd_authindex ;
3044 sub rd_authindex {
3045     my($cl, $index_target) = @_;
3046     my @lines;
3047     return unless defined $index_target;
3048     $CPAN::Frontend->myprint("Going to read $index_target\n");
3049     local(*FH);
3050     tie *FH, CPAN::Tarzip, $index_target;
3051     local($/) = "\n";
3052     push @lines, split /\012/ while <FH>;
3053     foreach (@lines) {
3054         my($userid,$fullname,$email) =
3055             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3056         next unless $userid && $fullname && $email;
3057
3058         # instantiate an author object
3059         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3060         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3061         return if $CPAN::Signal;
3062     }
3063 }
3064
3065 sub userid {
3066   my($self,$dist) = @_;
3067   $dist = $self->{'id'} unless defined $dist;
3068   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3069   $ret;
3070 }
3071
3072 #-> sub CPAN::Index::rd_modpacks ;
3073 sub rd_modpacks {
3074     my($self, $index_target) = @_;
3075     my @lines;
3076     return unless defined $index_target;
3077     $CPAN::Frontend->myprint("Going to read $index_target\n");
3078     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3079     local($/) = "\n";
3080     while ($_ = $fh->READLINE) {
3081         s/\012/\n/g;
3082         my @ls = map {"$_\n"} split /\n/, $_;
3083         unshift @ls, "\n" x length($1) if /^(\n+)/;
3084         push @lines, @ls;
3085     }
3086     # read header
3087     my($line_count,$last_updated);
3088     while (@lines) {
3089         my $shift = shift(@lines);
3090         last if $shift =~ /^\s*$/;
3091         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3092         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3093     }
3094     if (not defined $line_count) {
3095
3096         warn qq{Warning: Your $index_target does not contain a Line-Count header.
3097 Please check the validity of the index file by comparing it to more
3098 than one CPAN mirror. I'll continue but problems seem likely to
3099 happen.\a
3100 };
3101
3102         sleep 5;
3103     } elsif ($line_count != scalar @lines) {
3104
3105         warn sprintf qq{Warning: Your %s
3106 contains a Line-Count header of %d but I see %d lines there. Please
3107 check the validity of the index file by comparing it to more than one
3108 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3109 $index_target, $line_count, scalar(@lines);
3110
3111     }
3112     if (not defined $last_updated) {
3113
3114         warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3115 Please check the validity of the index file by comparing it to more
3116 than one CPAN mirror. I'll continue but problems seem likely to
3117 happen.\a
3118 };
3119
3120         sleep 5;
3121     } else {
3122
3123         $CPAN::Frontend
3124             ->myprint(sprintf qq{  Database was generated on %s\n},
3125                       $last_updated);
3126         $DATE_OF_02 = $last_updated;
3127
3128         if ($CPAN::META->has_inst(HTTP::Date)) {
3129             require HTTP::Date;
3130             my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3131             if ($age > 30) {
3132
3133                 $CPAN::Frontend
3134                     ->mywarn(sprintf
3135                              qq{Warning: This index file is %d days old.
3136   Please check the host you chose as your CPAN mirror for staleness.
3137   I'll continue but problems seem likely to happen.\a\n},
3138                              $age);
3139
3140             }
3141         } else {
3142             $CPAN::Frontend->myprint("  HTTP::Date not available\n");
3143         }
3144     }
3145
3146
3147     # A necessity since we have metadata_cache: delete what isn't
3148     # there anymore
3149     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3150     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3151     my(%exists);
3152     foreach (@lines) {
3153         chomp;
3154         # before 1.56 we split into 3 and discarded the rest. From
3155         # 1.57 we assign remaining text to $comment thus allowing to
3156         # influence isa_perl
3157         my($mod,$version,$dist,$comment) = split " ", $_, 4;
3158         my($bundle,$id,$userid);
3159
3160         if ($mod eq 'CPAN' &&
3161             ! (
3162                CPAN::Queue->exists('Bundle::CPAN') ||
3163                CPAN::Queue->exists('CPAN')
3164               )
3165            ) {
3166             local($^W)= 0;
3167             if ($version > $CPAN::VERSION){
3168                 $CPAN::Frontend->myprint(qq{
3169   There's a new CPAN.pm version (v$version) available!
3170   [Current version is v$CPAN::VERSION]
3171   You might want to try
3172     install Bundle::CPAN
3173     reload cpan
3174   without quitting the current session. It should be a seamless upgrade
3175   while we are running...
3176 }); #});
3177                 sleep 2;
3178                 $CPAN::Frontend->myprint(qq{\n});
3179             }
3180             last if $CPAN::Signal;
3181         } elsif ($mod =~ /^Bundle::(.*)/) {
3182             $bundle = $1;
3183         }
3184
3185         if ($bundle){
3186             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
3187             # Let's make it a module too, because bundles have so much
3188             # in common with modules.
3189
3190             # Changed in 1.57_63: seems like memory bloat now without
3191             # any value, so commented out
3192
3193             # $CPAN::META->instance('CPAN::Module',$mod);
3194
3195         } else {
3196
3197             # instantiate a module object
3198             $id = $CPAN::META->instance('CPAN::Module',$mod);
3199
3200         }
3201
3202         if ($id->cpan_file ne $dist){ # update only if file is
3203                                       # different. CPAN prohibits same
3204                                       # name with different version
3205             $userid = $self->userid($dist);
3206             $id->set(
3207                      'CPAN_USERID' => $userid,
3208                      'CPAN_VERSION' => $version,
3209                      'CPAN_FILE' => $dist,
3210                     );
3211         }
3212
3213         # instantiate a distribution object
3214         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3215           # we do not need CONTAINSMODS unless we do something with
3216           # this dist, so we better produce it on demand.
3217
3218           ## my $obj = $CPAN::META->instance(
3219           ##                              'CPAN::Distribution' => $dist
3220           ##                             );
3221           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3222         } else {
3223           $CPAN::META->instance(
3224                                 'CPAN::Distribution' => $dist
3225                                )->set(
3226                                       'CPAN_USERID' => $userid,
3227                                       'CPAN_COMMENT' => $comment,
3228                                      );
3229         }
3230         if ($secondtime) {
3231             for my $name ($mod,$dist) {
3232                 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3233                 $exists{$name} = undef;
3234             }
3235         }
3236         return if $CPAN::Signal;
3237     }
3238     undef $fh;
3239     if ($secondtime) {
3240         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3241             for my $o ($CPAN::META->all_objects($class)) {
3242                 next if exists $exists{$o->{ID}};
3243                 $CPAN::META->delete($class,$o->{ID});
3244                 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3245                     if $CPAN::DEBUG;
3246             }
3247         }
3248     }
3249 }
3250
3251 #-> sub CPAN::Index::rd_modlist ;
3252 sub rd_modlist {
3253     my($cl,$index_target) = @_;
3254     return unless defined $index_target;
3255     $CPAN::Frontend->myprint("Going to read $index_target\n");
3256     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3257     my @eval;
3258     local($/) = "\n";
3259     while ($_ = $fh->READLINE) {
3260         s/\012/\n/g;
3261         my @ls = map {"$_\n"} split /\n/, $_;
3262         unshift @ls, "\n" x length($1) if /^(\n+)/;
3263         push @eval, @ls;
3264     }
3265     while (@eval) {
3266         my $shift = shift(@eval);
3267         if ($shift =~ /^Date:\s+(.*)/){
3268             return if $DATE_OF_03 eq $1;
3269             ($DATE_OF_03) = $1;
3270         }
3271         last if $shift =~ /^\s*$/;
3272     }
3273     undef $fh;
3274     push @eval, q{CPAN::Modulelist->data;};
3275     local($^W) = 0;
3276     my($comp) = Safe->new("CPAN::Safe1");
3277     my($eval) = join("", @eval);
3278     my $ret = $comp->reval($eval);
3279     Carp::confess($@) if $@;
3280     return if $CPAN::Signal;
3281     for (keys %$ret) {
3282         my $obj = $CPAN::META->instance("CPAN::Module",$_);
3283         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3284         $obj->set(%{$ret->{$_}});
3285         return if $CPAN::Signal;
3286     }
3287 }
3288
3289 #-> sub CPAN::Index::write_metadata_cache ;
3290 sub write_metadata_cache {
3291     my($self) = @_;
3292     return unless $CPAN::Config->{'cache_metadata'};
3293     return unless $CPAN::META->has_usable("Storable");
3294     my $cache;
3295     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3296                       CPAN::Distribution)) {
3297         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3298     }
3299     my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3300     $cache->{last_time} = $LAST_TIME;
3301     $cache->{DATE_OF_02} = $DATE_OF_02;
3302     $cache->{PROTOCOL} = PROTOCOL;
3303     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3304     eval { Storable::nstore($cache, $metadata_file) };
3305     $CPAN::Frontend->mywarn($@) if $@;
3306 }
3307
3308 #-> sub CPAN::Index::read_metadata_cache ;
3309 sub read_metadata_cache {
3310     my($self) = @_;
3311     return unless $CPAN::Config->{'cache_metadata'};
3312     return unless $CPAN::META->has_usable("Storable");
3313     my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3314     return unless -r $metadata_file and -f $metadata_file;
3315     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3316     my $cache;
3317     eval { $cache = Storable::retrieve($metadata_file) };
3318     $CPAN::Frontend->mywarn($@) if $@;
3319     if (!$cache || ref $cache ne 'HASH'){
3320         $LAST_TIME = 0;
3321         return;
3322     }
3323     if (exists $cache->{PROTOCOL}) {
3324         if (PROTOCOL > $cache->{PROTOCOL}) {
3325             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3326                                             "with protocol v%s, requiring v%s",
3327                                             $cache->{PROTOCOL},
3328                                             PROTOCOL)
3329                                    );
3330             return;
3331         }
3332     } else {
3333         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3334                                 "with protocol v1.0");
3335         return;
3336     }
3337     my $clcnt = 0;
3338     my $idcnt = 0;
3339     while(my($class,$v) = each %$cache) {
3340         next unless $class =~ /^CPAN::/;
3341         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3342         while (my($id,$ro) = each %$v) {
3343             $CPAN::META->{readwrite}{$class}{$id} ||=
3344                 $class->new(ID=>$id, RO=>$ro);
3345             $idcnt++;
3346         }
3347         $clcnt++;
3348     }
3349     unless ($clcnt) { # sanity check
3350         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3351         return;
3352     }
3353     if ($idcnt < 1000) {
3354         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3355                                  "in $metadata_file\n");
3356         return;
3357     }
3358     $CPAN::META->{PROTOCOL} ||=
3359         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3360                             # does initialize to some protocol
3361     $LAST_TIME = $cache->{last_time};
3362     $DATE_OF_02 = $cache->{DATE_OF_02};
3363     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
3364         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3365     return;
3366 }
3367
3368 package CPAN::InfoObj;
3369
3370 # Accessors
3371 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3372 sub id { shift->{ID}; }
3373
3374 #-> sub CPAN::InfoObj::new ;
3375 sub new {
3376     my $this = bless {}, shift;
3377     %$this = @_;
3378     $this
3379 }
3380
3381 # The set method may only be used by code that reads index data or
3382 # otherwise "objective" data from the outside world. All session
3383 # related material may do anything else with instance variables but
3384 # must not touch the hash under the RO attribute. The reason is that
3385 # the RO hash gets written to Metadata file and is thus persistent.
3386
3387 #-> sub CPAN::InfoObj::set ;
3388 sub set {
3389     my($self,%att) = @_;
3390     my $class = ref $self;
3391
3392     # This must be ||=, not ||, because only if we write an empty
3393     # reference, only then the set method will write into the readonly
3394     # area. But for Distributions that spring into existence, maybe
3395     # because of a typo, we do not like it that they are written into
3396     # the readonly area and made permanent (at least for a while) and
3397     # that is why we do not "allow" other places to call ->set.
3398     unless ($self->id) {
3399         CPAN->debug("Bug? Empty ID, rejecting");
3400         return;
3401     }
3402     my $ro = $self->{RO} =
3403         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3404
3405     while (my($k,$v) = each %att) {
3406         $ro->{$k} = $v;
3407     }
3408 }
3409
3410 #-> sub CPAN::InfoObj::as_glimpse ;
3411 sub as_glimpse {
3412     my($self) = @_;
3413     my(@m);
3414     my $class = ref($self);
3415     $class =~ s/^CPAN:://;
3416     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3417     join "", @m;
3418 }
3419
3420 #-> sub CPAN::InfoObj::as_string ;
3421 sub as_string {
3422     my($self) = @_;
3423     my(@m);
3424     my $class = ref($self);
3425     $class =~ s/^CPAN:://;
3426     push @m, $class, " id = $self->{ID}\n";
3427     for (sort keys %{$self->{RO}}) {
3428         # next if m/^(ID|RO)$/;
3429         my $extra = "";
3430         if ($_ eq "CPAN_USERID") {
3431             $extra .= " (".$self->author;
3432             my $email; # old perls!
3433             if ($email = $CPAN::META->instance("CPAN::Author",
3434                                                $self->cpan_userid
3435                                               )->email) {
3436                 $extra .= " <$email>";
3437             } else {
3438                 $extra .= " <no email>";
3439             }
3440             $extra .= ")";
3441         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3442             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
3443             next;
3444         }
3445         next unless defined $self->{RO}{$_};
3446         push @m, sprintf "    %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3447     }
3448     for (sort keys %$self) {
3449         next if m/^(ID|RO)$/;
3450         if (ref($self->{$_}) eq "ARRAY") {
3451           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
3452         } elsif (ref($self->{$_}) eq "HASH") {
3453           push @m, sprintf(
3454                            "    %-12s %s\n",
3455                            $_,
3456                            join(" ",keys %{$self->{$_}}),
3457                           );
3458         } else {
3459           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
3460         }
3461     }
3462     join "", @m, "\n";
3463 }
3464
3465 #-> sub CPAN::InfoObj::author ;
3466 sub author {
3467     my($self) = @_;
3468     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3469 }
3470
3471 #-> sub CPAN::InfoObj::dump ;
3472 sub dump {
3473   my($self) = @_;
3474   require Data::Dumper;
3475   print Data::Dumper::Dumper($self);
3476 }
3477
3478 package CPAN::Author;
3479
3480 #-> sub CPAN::Author::id
3481 sub id {
3482     my $self = shift;
3483     my $id = $self->{ID};
3484     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3485     $id;
3486 }
3487
3488 #-> sub CPAN::Author::as_glimpse ;
3489 sub as_glimpse {
3490     my($self) = @_;
3491     my(@m);
3492     my $class = ref($self);
3493     $class =~ s/^CPAN:://;
3494     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3495                      $class,
3496                      $self->{ID},
3497                      $self->fullname,
3498                      $self->email);
3499     join "", @m;
3500 }
3501
3502 #-> sub CPAN::Author::fullname ;
3503 sub fullname {
3504     shift->{RO}{FULLNAME};
3505 }
3506 *name = \&fullname;
3507
3508 #-> sub CPAN::Author::email ;
3509 sub email    { shift->{RO}{EMAIL}; }
3510
3511 #-> sub CPAN::Author::ls ;
3512 sub ls {
3513     my $self = shift;
3514     my $id = $self->id;
3515
3516     # adapted from CPAN::Distribution::verifyMD5 ;
3517     my(@csf); # chksumfile
3518     @csf = $self->id =~ /(.)(.)(.*)/;
3519     $csf[1] = join "", @csf[0,1];
3520     $csf[2] = join "", @csf[1,2];
3521     my(@dl);
3522     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3523     unless (grep {$_->[2] eq $csf[1]} @dl) {
3524         $CPAN::Frontend->myprint("No files in the directory of $id\n");
3525         return;
3526     }
3527     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3528     unless (grep {$_->[2] eq $csf[2]} @dl) {
3529         $CPAN::Frontend->myprint("No files in the directory of $id\n");
3530         return;
3531     }
3532     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3533     $CPAN::Frontend->myprint(join "", map {
3534         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3535     } sort { $a->[2] cmp $b->[2] } @dl);
3536 }
3537
3538 # returns an array of arrays, the latter contain (size,mtime,filename)
3539 #-> sub CPAN::Author::dir_listing ;
3540 sub dir_listing {
3541     my $self = shift;
3542     my $chksumfile = shift;
3543     my $recursive = shift;
3544     my $lc_want =
3545         MM->catfile($CPAN::Config->{keep_source_where},
3546                     "authors", "id", @$chksumfile);
3547     local($") = "/";
3548     # connect "force" argument with "index_expire".
3549     my $force = 0;
3550     if (my @stat = stat $lc_want) {
3551         $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3552     }
3553     my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3554                                       $lc_want,$force);
3555     unless ($lc_file) {
3556         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3557         $chksumfile->[-1] .= ".gz";
3558         $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3559                                        "$lc_want.gz",1);
3560         if ($lc_file) {
3561             $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3562             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3563         } else {
3564             return;
3565         }
3566     }
3567
3568     # adapted from CPAN::Distribution::MD5_check_file ;
3569     my $fh = FileHandle->new;
3570     my($cksum);
3571     if (open $fh, $lc_file){
3572         local($/);
3573         my $eval = <$fh>;
3574         $eval =~ s/\015?\012/\n/g;
3575         close $fh;
3576         my($comp) = Safe->new();
3577         $cksum = $comp->reval($eval);
3578         if ($@) {
3579             rename $lc_file, "$lc_file.bad";
3580             Carp::confess($@) if $@;
3581         }
3582     } else {
3583         Carp::carp "Could not open $lc_file for reading";
3584     }
3585     my(@result,$f);
3586     for $f (sort keys %$cksum) {
3587         if (exists $cksum->{$f}{isdir}) {
3588             if ($recursive) {
3589                 my(@dir) = @$chksumfile;
3590                 pop @dir;
3591                 push @dir, $f, "CHECKSUMS";
3592                 push @result, map {
3593                     [$_->[0], $_->[1], "$f/$_->[2]"]
3594                 } $self->dir_listing(\@dir,1);
3595             } else {
3596                 push @result, [ 0, "-", $f ];
3597             }
3598         } else {
3599             push @result, [
3600                            ($cksum->{$f}{"size"}||0),
3601                            $cksum->{$f}{"mtime"}||"---",
3602                            $f
3603                           ];
3604         }
3605     }
3606     @result;
3607 }
3608
3609 package CPAN::Distribution;
3610
3611 # Accessors
3612 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3613
3614 sub undelay {
3615     my $self = shift;
3616     delete $self->{later};
3617 }
3618
3619 # CPAN::Distribution::normalize
3620 sub normalize {
3621     my($self,$s) = @_;
3622     $s = $self->id unless defined $s;
3623     if (
3624         $s =~ tr|/|| == 1
3625         or
3626         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3627        ) {
3628         return $s if $s =~ m:^N/A|^Contact Author: ;
3629         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3630             $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3631         CPAN->debug("s[$s]") if $CPAN::DEBUG;
3632     }
3633     $s;
3634 }
3635
3636 #-> sub CPAN::Distribution::color_cmd_tmps ;
3637 sub color_cmd_tmps {
3638     my($self) = shift;
3639     my($depth) = shift || 0;
3640     my($color) = shift || 0;
3641     # a distribution needs to recurse into its prereq_pms
3642
3643     return if exists $self->{incommandcolor}
3644         && $self->{incommandcolor}==$color;
3645     $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3646                                    "color_cmd_tmps depth[%s] self[%s] id[%s]",
3647                                    $depth,
3648                                    $self,
3649                                    $self->id
3650                                   )) if $depth>=100;
3651     ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3652     my $prereq_pm = $self->prereq_pm;
3653     if (defined $prereq_pm) {
3654         for my $pre (keys %$prereq_pm) {
3655             my $premo = CPAN::Shell->expand("Module",$pre);
3656             $premo->color_cmd_tmps($depth+1,$color);
3657         }
3658     }
3659     if ($color==0) {
3660         delete $self->{sponsored_mods};
3661         delete $self->{badtestcnt};
3662     }
3663     $self->{incommandcolor} = $color;
3664 }
3665
3666 #-> sub CPAN::Distribution::as_string ;
3667 sub as_string {
3668   my $self = shift;
3669   $self->containsmods;
3670   $self->SUPER::as_string(@_);
3671 }
3672
3673 #-> sub CPAN::Distribution::containsmods ;
3674 sub containsmods {
3675   my $self = shift;
3676   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3677   my $dist_id = $self->{ID};
3678   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3679     my $mod_file = $mod->cpan_file or next;
3680     my $mod_id = $mod->{ID} or next;
3681     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3682     # sleep 1;
3683     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3684   }
3685   keys %{$self->{CONTAINSMODS}};
3686 }
3687
3688 #-> sub CPAN::Distribution::uptodate ;
3689 sub uptodate {
3690     my($self) = @_;
3691     my $c;
3692     foreach $c ($self->containsmods) {
3693         my $obj = CPAN::Shell->expandany($c);
3694         return 0 unless $obj->uptodate;
3695     }
3696     return 1;
3697 }
3698
3699 #-> sub CPAN::Distribution::called_for ;
3700 sub called_for {
3701     my($self,$id) = @_;
3702     $self->{CALLED_FOR} = $id if defined $id;
3703     return $self->{CALLED_FOR};
3704 }
3705
3706 #-> sub CPAN::Distribution::safe_chdir ;
3707 sub safe_chdir {
3708     my($self,$todir) = @_;
3709     # we die if we cannot chdir and we are debuggable
3710     Carp::confess("safe_chdir called without todir argument")
3711           unless defined $todir and length $todir;
3712     if (chdir $todir) {
3713         $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3714             if $CPAN::DEBUG;
3715     } else {
3716         my $cwd = CPAN::anycwd();
3717         $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3718                                qq{to todir[$todir]: $!});
3719     }
3720 }
3721
3722 #-> sub CPAN::Distribution::get ;
3723 sub get {
3724     my($self) = @_;
3725   EXCUSE: {
3726         my @e;
3727         exists $self->{'build_dir'} and push @e,
3728             "Is already unwrapped into directory $self->{'build_dir'}";
3729         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3730     }
3731     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3732
3733     #
3734     # Get the file on local disk
3735     #
3736
3737     my($local_file);
3738     my($local_wanted) =
3739         MM->catfile(
3740                     $CPAN::Config->{keep_source_where},
3741                     "authors",
3742                     "id",
3743                     split("/",$self->id)
3744                    );
3745
3746     $self->debug("Doing localize") if $CPAN::DEBUG;
3747     unless ($local_file =
3748             CPAN::FTP->localize("authors/id/$self->{ID}",
3749                                 $local_wanted)) {
3750         my $note = "";
3751         if ($CPAN::Index::DATE_OF_02) {
3752             $note = "Note: Current database in memory was generated ".
3753                 "on $CPAN::Index::DATE_OF_02\n";
3754         }
3755         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3756     }
3757     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3758     $self->{localfile} = $local_file;
3759     return if $CPAN::Signal;
3760
3761     #
3762     # Check integrity
3763     #
3764     if ($CPAN::META->has_inst("MD5")) {
3765         $self->debug("MD5 is installed, verifying");
3766         $self->verifyMD5;
3767     } else {
3768         $self->debug("MD5 is NOT installed");
3769     }
3770     return if $CPAN::Signal;
3771
3772     #
3773     # Create a clean room and go there
3774     #
3775     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3776     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3777     $self->safe_chdir($builddir);
3778     $self->debug("Removing tmp") if $CPAN::DEBUG;
3779     File::Path::rmtree("tmp");
3780     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3781     if ($CPAN::Signal){
3782         $self->safe_chdir($sub_wd);
3783         return;
3784     }
3785     $self->safe_chdir("tmp");
3786
3787     #
3788     # Unpack the goods
3789     #
3790     if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3791         $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3792         $self->untar_me($local_file);
3793     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3794         $self->unzip_me($local_file);
3795     } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3796         $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3797         $self->pm2dir_me($local_file);
3798     } else {
3799         $self->{archived} = "NO";
3800         $self->safe_chdir($sub_wd);
3801         return;
3802     }
3803
3804     # we are still in the tmp directory!
3805     # Let's check if the package has its own directory.
3806     my $dh = DirHandle->new(File::Spec->curdir)
3807         or Carp::croak("Couldn't opendir .: $!");
3808     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3809     $dh->close;
3810     my ($distdir,$packagedir);
3811     if (@readdir == 1 && -d $readdir[0]) {
3812         $distdir = $readdir[0];
3813         $packagedir = MM->catdir($builddir,$distdir);
3814         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3815             if $CPAN::DEBUG;
3816         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3817                                                     "$packagedir\n");
3818         File::Path::rmtree($packagedir);
3819         rename($distdir,$packagedir) or
3820             Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3821         $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3822                              $distdir,
3823                              $packagedir,
3824                              -e $packagedir,
3825                              -d $packagedir,
3826                             )) if $CPAN::DEBUG;
3827     } else {
3828         my $userid = $self->cpan_userid;
3829         unless ($userid) {
3830             CPAN->debug("no userid? self[$self]");
3831             $userid = "anon";
3832         }
3833         my $pragmatic_dir = $userid . '000';
3834         $pragmatic_dir =~ s/\W_//g;
3835         $pragmatic_dir++ while -d "../$pragmatic_dir";
3836         $packagedir = MM->catdir($builddir,$pragmatic_dir);
3837         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3838         File::Path::mkpath($packagedir);
3839         my($f);
3840         for $f (@readdir) { # is already without "." and ".."
3841             my $to = MM->catdir($packagedir,$f);
3842             rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3843         }
3844     }
3845     if ($CPAN::Signal){
3846         $self->safe_chdir($sub_wd);
3847         return;
3848     }
3849
3850     $self->{'build_dir'} = $packagedir;
3851     $self->safe_chdir(File::Spec->updir);
3852     File::Path::rmtree("tmp");
3853
3854     my($mpl) = MM->catfile($packagedir,"Makefile.PL");
3855     my($mpl_exists) = -f $mpl;
3856     unless ($mpl_exists) {
3857         # NFS has been reported to have racing problems after the
3858         # renaming of a directory in some environments.
3859         # This trick helps.
3860         sleep 1;
3861         my $mpldh = DirHandle->new($packagedir)
3862             or Carp::croak("Couldn't opendir $packagedir: $!");
3863         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3864         $mpldh->close;
3865     }
3866     unless ($mpl_exists) {
3867         $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3868                              $mpl,
3869                              CPAN::anycwd(),
3870                             )) if $CPAN::DEBUG;
3871         my($configure) = MM->catfile($packagedir,"Configure");
3872         if (-f $configure) {
3873             # do we have anything to do?
3874             $self->{'configure'} = $configure;
3875         } elsif (-f MM->catfile($packagedir,"Makefile")) {
3876             $CPAN::Frontend->myprint(qq{
3877 Package comes with a Makefile and without a Makefile.PL.
3878 We\'ll try to build it with that Makefile then.
3879 });
3880             $self->{writemakefile} = "YES";
3881             sleep 2;
3882         } else {
3883             my $cf = $self->called_for || "unknown";
3884             if ($cf =~ m|/|) {
3885                 $cf =~ s|.*/||;
3886                 $cf =~ s|\W.*||;
3887             }
3888             $cf =~ s|[/\\:]||g; # risk of filesystem damage
3889             $cf = "unknown" unless length($cf);
3890             $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3891   (The test -f "$mpl" returned false.)
3892   Writing one on our own (setting NAME to $cf)\a\n});
3893             $self->{had_no_makefile_pl}++;
3894             sleep 3;
3895
3896             # Writing our own Makefile.PL
3897
3898             my $fh = FileHandle->new;
3899             $fh->open(">$mpl")
3900                 or Carp::croak("Could not open >$mpl: $!");
3901             $fh->print(
3902 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3903 # because there was no Makefile.PL supplied.
3904 # Autogenerated on: }.scalar localtime().qq{
3905
3906 use ExtUtils::MakeMaker;
3907 WriteMakefile(NAME => q[$cf]);
3908
3909 });
3910             $fh->close;
3911         }
3912     }
3913
3914     return $self;
3915 }
3916
3917 # CPAN::Distribution::untar_me ;
3918 sub untar_me {
3919     my($self,$local_file) = @_;
3920     $self->{archived} = "tar";
3921     if (CPAN::Tarzip->untar($local_file)) {
3922         $self->{unwrapped} = "YES";
3923     } else {
3924         $self->{unwrapped} = "NO";
3925     }
3926 }
3927
3928 # CPAN::Distribution::unzip_me ;
3929 sub unzip_me {
3930     my($self,$local_file) = @_;
3931     $self->{archived} = "zip";
3932     if (CPAN::Tarzip->unzip($local_file)) {
3933         $self->{unwrapped} = "YES";
3934     } else {
3935         $self->{unwrapped} = "NO";
3936     }
3937     return;
3938 }
3939
3940 sub pm2dir_me {
3941     my($self,$local_file) = @_;
3942     $self->{archived} = "pm";
3943     my $to = File::Basename::basename($local_file);
3944     $to =~ s/\.(gz|Z)(?!\n)\Z//;
3945     if (CPAN::Tarzip->gunzip($local_file,$to)) {
3946         $self->{unwrapped} = "YES";
3947     } else {
3948         $self->{unwrapped} = "NO";
3949     }
3950 }
3951
3952 #-> sub CPAN::Distribution::new ;
3953 sub new {
3954     my($class,%att) = @_;
3955
3956     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3957
3958     my $this = { %att };
3959     return bless $this, $class;
3960 }
3961
3962 #-> sub CPAN::Distribution::look ;
3963 sub look {
3964     my($self) = @_;
3965
3966     if ($^O eq 'MacOS') {
3967       $self->ExtUtils::MM_MacOS::look;
3968       return;
3969     }
3970
3971     if (  $CPAN::Config->{'shell'} ) {
3972         $CPAN::Frontend->myprint(qq{
3973 Trying to open a subshell in the build directory...
3974 });
3975     } else {
3976         $CPAN::Frontend->myprint(qq{
3977 Your configuration does not define a value for subshells.
3978 Please define it with "o conf shell <your shell>"
3979 });
3980         return;
3981     }
3982     my $dist = $self->id;
3983     my $dir;
3984     unless ($dir = $self->dir) {
3985         $self->get;
3986     }
3987     unless ($dir ||= $self->dir) {
3988         $CPAN::Frontend->mywarn(qq{
3989 Could not determine which directory to use for looking at $dist.
3990 });
3991         return;
3992     }
3993     my $pwd  = CPAN::anycwd();
3994     $self->safe_chdir($dir);
3995     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3996     system($CPAN::Config->{'shell'}) == 0
3997         or $CPAN::Frontend->mydie("Subprocess shell error");
3998     $self->safe_chdir($pwd);
3999 }
4000
4001 # CPAN::Distribution::cvs_import ;
4002 sub cvs_import {
4003     my($self) = @_;
4004     $self->get;
4005     my $dir = $self->dir;
4006
4007     my $package = $self->called_for;
4008     my $module = $CPAN::META->instance('CPAN::Module', $package);
4009     my $version = $module->cpan_version;
4010
4011     my $userid = $self->cpan_userid;
4012
4013     my $cvs_dir = (split '/', $dir)[-1];
4014     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4015     my $cvs_root =
4016       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4017     my $cvs_site_perl =
4018       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4019     if ($cvs_site_perl) {
4020         $cvs_dir = "$cvs_site_perl/$cvs_dir";
4021     }
4022     my $cvs_log = qq{"imported $package $version sources"};
4023     $version =~ s/\./_/g;
4024     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4025                "$cvs_dir", $userid, "v$version");
4026
4027     my $pwd  = CPAN::anycwd();
4028     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4029
4030     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4031
4032     $CPAN::Frontend->myprint(qq{@cmd\n});
4033     system(@cmd) == 0 or
4034         $CPAN::Frontend->mydie("cvs import failed");
4035     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4036 }
4037
4038 #-> sub CPAN::Distribution::readme ;
4039 sub readme {
4040     my($self) = @_;
4041     my($dist) = $self->id;
4042     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4043     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4044     my($local_file);
4045     my($local_wanted) =
4046          MM->catfile(
4047                         $CPAN::Config->{keep_source_where},
4048                         "authors",
4049                         "id",
4050                         split("/","$sans.readme"),
4051                        );
4052     $self->debug("Doing localize") if $CPAN::DEBUG;
4053     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4054                                       $local_wanted)
4055         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4056
4057     if ($^O eq 'MacOS') {
4058         ExtUtils::MM_MacOS::launch_file($local_file);
4059         return;
4060     }
4061
4062     my $fh_pager = FileHandle->new;
4063     local($SIG{PIPE}) = "IGNORE";
4064     $fh_pager->open("|$CPAN::Config->{'pager'}")
4065         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4066     my $fh_readme = FileHandle->new;
4067     $fh_readme->open($local_file)
4068         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4069     $CPAN::Frontend->myprint(qq{
4070 Displaying file
4071   $local_file
4072 with pager "$CPAN::Config->{'pager'}"
4073 });
4074     sleep 2;
4075     $fh_pager->print(<$fh_readme>);
4076 }
4077
4078 #-> sub CPAN::Distribution::verifyMD5 ;
4079 sub verifyMD5 {
4080     my($self) = @_;
4081   EXCUSE: {
4082         my @e;
4083         $self->{MD5_STATUS} ||= "";
4084         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4085         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4086     }
4087     my($lc_want,$lc_file,@local,$basename);
4088     @local = split("/",$self->id);
4089     pop @local;
4090     push @local, "CHECKSUMS";
4091     $lc_want =
4092         MM->catfile($CPAN::Config->{keep_source_where},
4093                       "authors", "id", @local);
4094     local($") = "/";
4095     if (
4096         -s $lc_want
4097         &&
4098         $self->MD5_check_file($lc_want)
4099        ) {
4100         return $self->{MD5_STATUS} = "OK";
4101     }
4102     $lc_file = CPAN::FTP->localize("authors/id/@local",
4103                                    $lc_want,1);
4104     unless ($lc_file) {
4105         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4106         $local[-1] .= ".gz";
4107         $lc_file = CPAN::FTP->localize("authors/id/@local",
4108                                        "$lc_want.gz",1);
4109         if ($lc_file) {
4110             $lc_file =~ s/\.gz(?!\n)\Z//;
4111             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4112         } else {
4113             return;
4114         }
4115     }
4116     $self->MD5_check_file($lc_file);
4117 }
4118
4119 #-> sub CPAN::Distribution::MD5_check_file ;
4120 sub MD5_check_file {
4121     my($self,$chk_file) = @_;
4122     my($cksum,$file,$basename);
4123     $file = $self->{localfile};
4124     $basename = File::Basename::basename($file);
4125     my $fh = FileHandle->new;
4126     if (open $fh, $chk_file){
4127         local($/);
4128         my $eval = <$fh>;
4129         $eval =~ s/\015?\012/\n/g;
4130         close $fh;
4131         my($comp) = Safe->new();
4132         $cksum = $comp->reval($eval);
4133         if ($@) {
4134             rename $chk_file, "$chk_file.bad";
4135             Carp::confess($@) if $@;
4136         }
4137     } else {
4138         Carp::carp "Could not open $chk_file for reading";
4139     }
4140
4141     if (exists $cksum->{$basename}{md5}) {
4142         $self->debug("Found checksum for $basename:" .
4143                      "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4144
4145         open($fh, $file);
4146         binmode $fh;
4147         my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4148         $fh->close;
4149         $fh = CPAN::Tarzip->TIEHANDLE($file);
4150
4151         unless ($eq) {
4152           # had to inline it, when I tied it, the tiedness got lost on
4153           # the call to eq_MD5. (Jan 1998)
4154           my $md5 = MD5->new;
4155           my($data,$ref);
4156           $ref = \$data;
4157           while ($fh->READ($ref, 4096) > 0){
4158             $md5->add($data);
4159           }
4160           my $hexdigest = $md5->hexdigest;
4161           $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4162         }
4163
4164         if ($eq) {
4165           $CPAN::Frontend->myprint("Checksum for $file ok\n");
4166           return $self->{MD5_STATUS} = "OK";
4167         } else {
4168             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4169                                      qq{distribution file. }.
4170                                      qq{Please investigate.\n\n}.
4171                                      $self->as_string,
4172                                      $CPAN::META->instance(
4173                                                            'CPAN::Author',
4174                                                            $self->cpan_userid
4175                                                           )->as_string);
4176
4177             my $wrap = qq{I\'d recommend removing $file. Its MD5
4178 checksum is incorrect. Maybe you have configured your 'urllist' with
4179 a bad URL. Please check this array with 'o conf urllist', and
4180 retry.};
4181
4182             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4183
4184             # former versions just returned here but this seems a
4185             # serious threat that deserves a die
4186
4187             # $CPAN::Frontend->myprint("\n\n");
4188             # sleep 3;
4189             # return;
4190         }
4191         # close $fh if fileno($fh);
4192     } else {
4193         $self->{MD5_STATUS} ||= "";
4194         if ($self->{MD5_STATUS} eq "NIL") {
4195             $CPAN::Frontend->mywarn(qq{
4196 Warning: No md5 checksum for $basename in $chk_file.
4197
4198 The cause for this may be that the file is very new and the checksum
4199 has not yet been calculated, but it may also be that something is
4200 going awry right now.
4201 });
4202             my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4203             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4204         }
4205         $self->{MD5_STATUS} = "NIL";
4206         return;
4207     }
4208 }
4209
4210 #-> sub CPAN::Distribution::eq_MD5 ;
4211 sub eq_MD5 {
4212     my($self,$fh,$expectMD5) = @_;
4213     my $md5 = MD5->new;
4214     my($data);
4215     while (read($fh, $data, 4096)){
4216       $md5->add($data);
4217     }
4218     # $md5->addfile($fh);
4219     my $hexdigest = $md5->hexdigest;
4220     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4221     $hexdigest eq $expectMD5;
4222 }
4223
4224 #-> sub CPAN::Distribution::force ;
4225
4226 # Both modules and distributions know if "force" is in effect by
4227 # autoinspection, not by inspecting a global variable. One of the
4228 # reason why this was chosen to work that way was the treatment of
4229 # dependencies. They should not autpomatically inherit the force
4230 # status. But this has the downside that ^C and die() will return to
4231 # the prompt but will not be able to reset the force_update
4232 # attributes. We try to correct for it currently in the read_metadata
4233 # routine, and immediately before we check for a Signal. I hope this
4234 # works out in one of v1.57_53ff
4235
4236 sub force {
4237   my($self, $method) = @_;
4238   for my $att (qw(
4239   MD5_STATUS archived build_dir localfile make install unwrapped
4240   writemakefile
4241  )) {
4242     delete $self->{$att};
4243   }
4244   if ($method && $method eq "install") {
4245     $self->{"force_update"}++; # name should probably have been force_install
4246   }
4247 }
4248
4249 #-> sub CPAN::Distribution::unforce ;
4250 sub unforce {
4251   my($self) = @_;
4252   delete $self->{'force_update'};
4253 }
4254
4255 #-> sub CPAN::Distribution::isa_perl ;
4256 sub isa_perl {
4257   my($self) = @_;
4258   my $file = File::Basename::basename($self->id);
4259   if ($file =~ m{ ^ perl
4260                   -?
4261                   (5)
4262                   ([._-])
4263                   (
4264                    \d{3}(_[0-4][0-9])?
4265                    |
4266                    \d*[24680]\.\d+
4267                   )
4268                   \.tar[._-]gz
4269                   (?!\n)\Z
4270                 }xs){
4271     return "$1.$3";
4272   } elsif ($self->cpan_comment
4273            &&
4274            $self->cpan_comment =~ /isa_perl\(.+?\)/){
4275     return $1;
4276   }
4277 }
4278
4279 #-> sub CPAN::Distribution::perl ;
4280 sub perl {
4281     my($self) = @_;
4282     my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
4283     my $pwd  = CPAN::anycwd();
4284     my $candidate = MM->catfile($pwd,$^X);
4285     $perl ||= $candidate if MM->maybe_command($candidate);
4286     unless ($perl) {
4287         my ($component,$perl_name);
4288       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4289             PATH_COMPONENT: foreach $component (MM->path(),
4290                                                 $Config::Config{'binexp'}) {
4291                   next unless defined($component) && $component;
4292                   my($abs) = MM->catfile($component,$perl_name);
4293                   if (MM->maybe_command($abs)) {
4294                       $perl = $abs;
4295                       last DIST_PERLNAME;
4296                   }
4297               }
4298           }
4299     }
4300     $perl;
4301 }
4302
4303 #-> sub CPAN::Distribution::make ;
4304 sub make {
4305     my($self) = @_;
4306     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4307     # Emergency brake if they said install Pippi and get newest perl
4308     if ($self->isa_perl) {
4309       if (
4310           $self->called_for ne $self->id &&
4311           ! $self->{force_update}
4312          ) {
4313         # if we die here, we break bundles
4314         $CPAN::Frontend->mywarn(sprintf qq{
4315 The most recent version "%s" of the module "%s"
4316 comes with the current version of perl (%s).
4317 I\'ll build that only if you ask for something like
4318     force install %s
4319 or
4320     install %s
4321 },
4322                                $CPAN::META->instance(
4323                                                      'CPAN::Module',
4324                                                      $self->called_for
4325                                                     )->cpan_version,
4326                                $self->called_for,
4327                                $self->isa_perl,
4328                                $self->called_for,
4329                                $self->id);
4330         sleep 5; return;
4331       }
4332     }
4333     $self->get;
4334   EXCUSE: {
4335         my @e;
4336         $self->{archived} eq "NO" and push @e,
4337         "Is neither a tar nor a zip archive.";
4338
4339         $self->{unwrapped} eq "NO" and push @e,
4340         "had problems unarchiving. Please build manually";
4341
4342         exists $self->{writemakefile} &&
4343             $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4344                 $1 || "Had some problem writing Makefile";
4345
4346         defined $self->{'make'} and push @e,
4347             "Has already been processed within this session";
4348
4349         exists $self->{later} and length($self->{later}) and
4350             push @e, $self->{later};
4351
4352         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4353     }
4354     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
4355     my $builddir = $self->dir;
4356     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4357     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4358
4359     if ($^O eq 'MacOS') {
4360         ExtUtils::MM_MacOS::make($self);
4361         return;
4362     }
4363
4364     my $system;
4365     if ($self->{'configure'}) {
4366       $system = $self->{'configure'};
4367     } else {
4368         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4369         my $switch = "";
4370 # This needs a handler that can be turned on or off:
4371 #       $switch = "-MExtUtils::MakeMaker ".
4372 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4373 #           if $] > 5.00310;
4374         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4375     }
4376     unless (exists $self->{writemakefile}) {
4377         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4378         my($ret,$pid);
4379         $@ = "";
4380         if ($CPAN::Config->{inactivity_timeout}) {
4381             eval {
4382                 alarm $CPAN::Config->{inactivity_timeout};
4383                 local $SIG{CHLD}; # = sub { wait };
4384                 if (defined($pid = fork)) {
4385                     if ($pid) { #parent
4386                         # wait;
4387                         waitpid $pid, 0;
4388                     } else {    #child
4389                       # note, this exec isn't necessary if
4390                       # inactivity_timeout is 0. On the Mac I'd
4391                       # suggest, we set it always to 0.
4392                       exec $system;
4393                     }
4394                 } else {
4395                     $CPAN::Frontend->myprint("Cannot fork: $!");
4396                     return;
4397                 }
4398             };
4399             alarm 0;
4400             if ($@){
4401                 kill 9, $pid;
4402                 waitpid $pid, 0;
4403                 $CPAN::Frontend->myprint($@);
4404                 $self->{writemakefile} = "NO $@";
4405                 $@ = "";
4406                 return;
4407             }
4408         } else {
4409           $ret = system($system);
4410           if ($ret != 0) {
4411             $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4412             return;
4413           }
4414         }
4415         if (-f "Makefile") {
4416           $self->{writemakefile} = "YES";
4417           delete $self->{make_clean}; # if cleaned before, enable next
4418         } else {
4419           $self->{writemakefile} =
4420               qq{NO Makefile.PL refused to write a Makefile.};
4421           # It's probably worth it to record the reason, so let's retry
4422           # local $/;
4423           # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4424           # $self->{writemakefile} .= <$fh>;
4425         }
4426     }
4427     if ($CPAN::Signal){
4428       delete $self->{force_update};
4429       return;
4430     }
4431     if (my @prereq = $self->unsat_prereq){
4432       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4433     }
4434     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4435     if (system($system) == 0) {
4436          $CPAN::Frontend->myprint("  $system -- OK\n");
4437          $self->{'make'} = "YES";
4438     } else {
4439          $self->{writemakefile} ||= "YES";
4440          $self->{'make'} = "NO";
4441          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4442     }
4443 }
4444
4445 sub follow_prereqs {
4446     my($self) = shift;
4447     my(@prereq) = @_;
4448     my $id = $self->id;
4449     $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4450                              "during [$id] -----\n");
4451
4452     for my $p (@prereq) {
4453         $CPAN::Frontend->myprint("    $p\n");
4454     }
4455     my $follow = 0;
4456     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4457         $follow = 1;
4458     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4459         require ExtUtils::MakeMaker;
4460         my $answer = ExtUtils::MakeMaker::prompt(
4461 "Shall I follow them and prepend them to the queue
4462 of modules we are processing right now?", "yes");
4463         $follow = $answer =~ /^\s*y/i;
4464     } else {
4465         local($") = ", ";
4466         $CPAN::Frontend->
4467             myprint("  Ignoring dependencies on modules @prereq\n");
4468     }
4469     if ($follow) {
4470         # color them as dirty
4471         for my $p (@prereq) {
4472             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4473         }
4474         CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4475         $self->{later} = "Delayed until after prerequisites";
4476         return 1; # signal success to the queuerunner
4477     }
4478 }
4479
4480 #-> sub CPAN::Distribution::unsat_prereq ;
4481 sub unsat_prereq {
4482     my($self) = @_;
4483     my $prereq_pm = $self->prereq_pm or return;
4484     my(@need);
4485   NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4486         my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4487         # we were too demanding:
4488         next if $nmo->uptodate;
4489
4490         # if they have not specified a version, we accept any installed one
4491         if (not defined $need_version or
4492            $need_version == 0 or
4493            $need_version eq "undef") {
4494             next if defined $nmo->inst_file;
4495         }
4496
4497         # We only want to install prereqs if either they're not installed
4498         # or if the installed version is too old. We cannot omit this
4499         # check, because if 'force' is in effect, nobody else will check.
4500         {
4501             local($^W) = 0;
4502             if (
4503                 defined $nmo->inst_file &&
4504                 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4505                ){
4506                 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4507                             $nmo->id,
4508                             $nmo->inst_file,
4509                             $nmo->inst_version,
4510                             CPAN::Version->readable($need_version)
4511                            );
4512                 next NEED;
4513             }
4514         }
4515
4516         if ($self->{sponsored_mods}{$need_module}++){
4517             # We have already sponsored it and for some reason it's still
4518             # not available. So we do nothing. Or what should we do?
4519             # if we push it again, we have a potential infinite loop
4520             next;
4521         }
4522         push @need, $need_module;
4523     }
4524     @need;
4525 }
4526
4527 #-> sub CPAN::Distribution::prereq_pm ;
4528 sub prereq_pm {
4529   my($self) = @_;
4530   return $self->{prereq_pm} if
4531       exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4532   return unless $self->{writemakefile}; # no need to have succeeded
4533                                         # but we must have run it
4534   my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4535   my $makefile = File::Spec->catfile($build_dir,"Makefile");
4536   my(%p) = ();
4537   my $fh;
4538   if (-f $makefile
4539       and
4540       $fh = FileHandle->new("<$makefile\0")) {
4541
4542       local($/) = "\n";
4543
4544       #  A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4545       while (<$fh>) {
4546           last if /MakeMaker post_initialize section/;
4547           my($p) = m{^[\#]
4548                  \s+PREREQ_PM\s+=>\s+(.+)
4549                  }x;
4550           next unless $p;
4551           # warn "Found prereq expr[$p]";
4552
4553           #  Regexp modified by A.Speer to remember actual version of file
4554           #  PREREQ_PM hash key wants, then add to
4555           while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4556               # In case a prereq is mentioned twice, complain.
4557               if ( defined $p{$1} ) {
4558                   warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4559               }
4560               $p{$1} = $2;
4561           }
4562           last;
4563       }
4564   }
4565   $self->{prereq_pm_detected}++;
4566   return $self->{prereq_pm} = \%p;
4567 }
4568
4569 #-> sub CPAN::Distribution::test ;
4570 sub test {
4571     my($self) = @_;
4572     $self->make;
4573     if ($CPAN::Signal){
4574       delete $self->{force_update};
4575       return;
4576     }
4577     $CPAN::Frontend->myprint("Running make test\n");
4578     if (my @prereq = $self->unsat_prereq){
4579       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4580     }
4581   EXCUSE: {
4582         my @e;
4583         exists $self->{make} or exists $self->{later} or push @e,
4584         "Make had some problems, maybe interrupted? Won't test";
4585
4586         exists $self->{'make'} and
4587             $self->{'make'} eq 'NO' and
4588                 push @e, "Can't test without successful make";
4589
4590         exists $self->{build_dir} or push @e, "Has no own directory";
4591         $self->{badtestcnt} ||= 0;
4592         $self->{badtestcnt} > 0 and
4593             push @e, "Won't repeat unsuccessful test during this command";
4594
4595         exists $self->{later} and length($self->{later}) and
4596             push @e, $self->{later};
4597
4598         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4599     }
4600     chdir $self->{'build_dir'} or
4601         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4602     $self->debug("Changed directory to $self->{'build_dir'}")
4603         if $CPAN::DEBUG;
4604
4605     if ($^O eq 'MacOS') {
4606         ExtUtils::MM_MacOS::make_test($self);
4607         return;
4608     }
4609
4610     my $system = join " ", $CPAN::Config->{'make'}, "test";
4611     if (system($system) == 0) {
4612          $CPAN::Frontend->myprint("  $system -- OK\n");
4613          $self->{make_test} = "YES";
4614     } else {
4615          $self->{make_test} = "NO";
4616          $self->{badtestcnt}++;
4617          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4618     }
4619 }
4620
4621 #-> sub CPAN::Distribution::clean ;
4622 sub clean {
4623     my($self) = @_;
4624     $CPAN::Frontend->myprint("Running make clean\n");
4625   EXCUSE: {
4626         my @e;
4627         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4628             push @e, "make clean already called once";
4629         exists $self->{build_dir} or push @e, "Has no own directory";
4630         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4631     }
4632     chdir $self->{'build_dir'} or
4633         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4634     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4635
4636     if ($^O eq 'MacOS') {
4637         ExtUtils::MM_MacOS::make_clean($self);
4638         return;
4639     }
4640
4641     my $system = join " ", $CPAN::Config->{'make'}, "clean";
4642     if (system($system) == 0) {
4643       $CPAN::Frontend->myprint("  $system -- OK\n");
4644
4645       # $self->force;
4646
4647       # Jost Krieger pointed out that this "force" was wrong because
4648       # it has the effect that the next "install" on this distribution
4649       # will untar everything again. Instead we should bring the
4650       # object's state back to where it is after untarring.
4651
4652       delete $self->{force_update};
4653       delete $self->{install};
4654       delete $self->{writemakefile};
4655       delete $self->{make};
4656       delete $self->{make_test}; # no matter if yes or no, tests must be redone
4657       $self->{make_clean} = "YES";
4658
4659     } else {
4660       # Hmmm, what to do if make clean failed?
4661
4662       $CPAN::Frontend->myprint(qq{  $system -- NOT OK
4663
4664 make clean did not succeed, marking directory as unusable for further work.
4665 });
4666       $self->force("make"); # so that this directory won't be used again
4667
4668     }
4669 }
4670
4671 #-> sub CPAN::Distribution::install ;
4672 sub install {
4673     my($self) = @_;
4674     $self->test;
4675     if ($CPAN::Signal){
4676       delete $self->{force_update};
4677       return;
4678     }
4679     $CPAN::Frontend->myprint("Running make install\n");
4680   EXCUSE: {
4681         my @e;
4682         exists $self->{build_dir} or push @e, "Has no own directory";
4683
4684         exists $self->{make} or exists $self->{later} or push @e,
4685         "Make had some problems, maybe interrupted? Won't install";
4686
4687         exists $self->{'make'} and
4688             $self->{'make'} eq 'NO' and
4689                 push @e, "make had returned bad status, install seems impossible";
4690
4691         push @e, "make test had returned bad status, ".
4692             "won't install without force"
4693             if exists $self->{'make_test'} and
4694             $self->{'make_test'} eq 'NO' and
4695             ! $self->{'force_update'};
4696
4697         exists $self->{'install'} and push @e,
4698         $self->{'install'} eq "YES" ?
4699             "Already done" : "Already tried without success";
4700
4701         exists $self->{later} and length($self->{later}) and
4702             push @e, $self->{later};
4703
4704         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4705     }
4706     chdir $self->{'build_dir'} or
4707         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4708     $self->debug("Changed directory to $self->{'build_dir'}")
4709         if $CPAN::DEBUG;
4710
4711     if ($^O eq 'MacOS') {
4712         ExtUtils::MM_MacOS::make_install($self);
4713         return;
4714     }
4715
4716     my $system = join(" ", $CPAN::Config->{'make'},
4717                       "install", $CPAN::Config->{make_install_arg});
4718     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4719     my($pipe) = FileHandle->new("$system $stderr |");
4720     my($makeout) = "";
4721     while (<$pipe>){
4722         $CPAN::Frontend->myprint($_);
4723         $makeout .= $_;
4724     }
4725     $pipe->close;
4726     if ($?==0) {
4727          $CPAN::Frontend->myprint("  $system -- OK\n");
4728          return $self->{'install'} = "YES";
4729     } else {
4730          $self->{'install'} = "NO";
4731          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4732          if ($makeout =~ /permission/s && $> > 0) {
4733              $CPAN::Frontend->myprint(qq{    You may have to su }.
4734                                       qq{to root to install the package\n});
4735          }
4736     }
4737     delete $self->{force_update};
4738 }
4739
4740 #-> sub CPAN::Distribution::dir ;
4741 sub dir {
4742     shift->{'build_dir'};
4743 }
4744
4745 package CPAN::Bundle;
4746
4747 sub undelay {
4748     my $self = shift;
4749     delete $self->{later};
4750     for my $c ( $self->contains ) {
4751         my $obj = CPAN::Shell->expandany($c) or next;
4752         $obj->undelay;
4753     }
4754 }
4755
4756 #-> sub CPAN::Bundle::color_cmd_tmps ;
4757 sub color_cmd_tmps {
4758     my($self) = shift;
4759     my($depth) = shift || 0;
4760     my($color) = shift || 0;
4761     # a module needs to recurse to its cpan_file, a distribution needs
4762     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4763
4764     return if exists $self->{incommandcolor}
4765         && $self->{incommandcolor}==$color;
4766     $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4767                                    "color_cmd_tmps depth[%s] self[%s] id[%s]",
4768                                    $depth,
4769                                    $self,
4770                                    $self->id
4771                                   )) if $depth>=100;
4772     ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4773
4774     for my $c ( $self->contains ) {
4775         my $obj = CPAN::Shell->expandany($c) or next;
4776         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4777         $obj->color_cmd_tmps($depth+1,$color);
4778     }
4779     if ($color==0) {
4780         delete $self->{badtestcnt};
4781     }
4782     $self->{incommandcolor} = $color;
4783 }
4784
4785 #-> sub CPAN::Bundle::as_string ;
4786 sub as_string {
4787     my($self) = @_;
4788     $self->contains;
4789     # following line must be "=", not "||=" because we have a moving target
4790     $self->{INST_VERSION} = $self->inst_version;
4791     return $self->SUPER::as_string;
4792 }
4793
4794 #-> sub CPAN::Bundle::contains ;
4795 sub contains {
4796     my($self) = @_;
4797     my($inst_file) = $self->inst_file || "";
4798     my($id) = $self->id;
4799     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4800     unless ($inst_file) {
4801         # Try to get at it in the cpan directory
4802         $self->debug("no inst_file") if $CPAN::DEBUG;
4803         my $cpan_file;
4804         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4805               $cpan_file = $self->cpan_file;
4806         if ($cpan_file eq "N/A") {
4807             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4808   Maybe stale symlink? Maybe removed during session? Giving up.\n");
4809         }
4810         my $dist = $CPAN::META->instance('CPAN::Distribution',
4811                                          $self->cpan_file);
4812         $dist->get;
4813         $self->debug($dist->as_string) if $CPAN::DEBUG;
4814         my($todir) = $CPAN::Config->{'cpan_home'};
4815         my(@me,$from,$to,$me);
4816         @me = split /::/, $self->id;
4817         $me[-1] .= ".pm";
4818         $me = MM->catfile(@me);
4819         $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4820         $to = MM->catfile($todir,$me);
4821         File::Path::mkpath(File::Basename::dirname($to));
4822         File::Copy::copy($from, $to)
4823               or Carp::confess("Couldn't copy $from to $to: $!");
4824         $inst_file = $to;
4825     }
4826     my @result;
4827     my $fh = FileHandle->new;
4828     local $/ = "\n";
4829     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4830     my $in_cont = 0;
4831     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4832     while (<$fh>) {
4833         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4834             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4835         next unless $in_cont;
4836         next if /^=/;
4837         s/\#.*//;
4838         next if /^\s+$/;
4839         chomp;
4840         push @result, (split " ", $_, 2)[0];
4841     }
4842     close $fh;
4843     delete $self->{STATUS};
4844     $self->{CONTAINS} = \@result;
4845     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4846     unless (@result) {
4847         $CPAN::Frontend->mywarn(qq{
4848 The bundle file "$inst_file" may be a broken
4849 bundlefile. It seems not to contain any bundle definition.
4850 Please check the file and if it is bogus, please delete it.
4851 Sorry for the inconvenience.
4852 });
4853     }
4854     @result;
4855 }
4856
4857 #-> sub CPAN::Bundle::find_bundle_file
4858 sub find_bundle_file {
4859     my($self,$where,$what) = @_;
4860     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4861 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4862 ###    my $bu = MM->catfile($where,$what);
4863 ###    return $bu if -f $bu;
4864     my $manifest = MM->catfile($where,"MANIFEST");
4865     unless (-f $manifest) {
4866         require ExtUtils::Manifest;
4867         my $cwd = CPAN::anycwd();
4868         chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4869         ExtUtils::Manifest::mkmanifest();
4870         chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4871     }
4872     my $fh = FileHandle->new($manifest)
4873         or Carp::croak("Couldn't open $manifest: $!");
4874     local($/) = "\n";
4875     my $what2 = $what;
4876     if ($^O eq 'MacOS') {
4877       $what =~ s/^://;
4878       $what2 =~ tr|:|/|;
4879       $what2 =~ s/:Bundle://;
4880       $what2 =~ tr|:|/|;
4881     } else {
4882         $what2 =~ s|Bundle[/\\]||;
4883     }
4884     my $bu;
4885     while (<$fh>) {
4886         next if /^\s*\#/;
4887         my($file) = /(\S+)/;
4888         if ($file =~ m|\Q$what\E$|) {
4889             $bu = $file;
4890             # return MM->catfile($where,$bu); # bad
4891             last;
4892         }
4893         # retry if she managed to
4894         # have no Bundle directory
4895         $bu = $file if $file =~ m|\Q$what2\E$|;
4896     }
4897     $bu =~ tr|/|:| if $^O eq 'MacOS';
4898     return MM->catfile($where, $bu) if $bu;
4899     Carp::croak("Couldn't find a Bundle file in $where");
4900 }
4901
4902 # needs to work quite differently from Module::inst_file because of
4903 # cpan_home/Bundle/ directory and the possibility that we have
4904 # shadowing effect. As it makes no sense to take the first in @INC for
4905 # Bundles, we parse them all for $VERSION and take the newest.
4906
4907 #-> sub CPAN::Bundle::inst_file ;
4908 sub inst_file {
4909     my($self) = @_;
4910     my($inst_file);
4911     my(@me);
4912     @me = split /::/, $self->id;
4913     $me[-1] .= ".pm";
4914     my($incdir,$bestv);
4915     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4916         my $bfile = MM->catfile($incdir, @me);
4917         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4918         next unless -f $bfile;
4919         my $foundv = MM->parse_version($bfile);
4920         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4921             $self->{INST_FILE} = $bfile;
4922             $self->{INST_VERSION} = $bestv = $foundv;
4923         }
4924     }
4925     $self->{INST_FILE};
4926 }
4927
4928 #-> sub CPAN::Bundle::inst_version ;
4929 sub inst_version {
4930     my($self) = @_;
4931     $self->inst_file; # finds INST_VERSION as side effect
4932     $self->{INST_VERSION};
4933 }
4934
4935 #-> sub CPAN::Bundle::rematein ;
4936 sub rematein {
4937     my($self,$meth) = @_;
4938     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4939     my($id) = $self->id;
4940     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4941         unless $self->inst_file || $self->cpan_file;
4942     my($s,%fail);
4943     for $s ($self->contains) {
4944         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4945             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4946         if ($type eq 'CPAN::Distribution') {
4947             $CPAN::Frontend->mywarn(qq{
4948 The Bundle }.$self->id.qq{ contains
4949 explicitly a file $s.
4950 });
4951             sleep 3;
4952         }
4953         # possibly noisy action:
4954         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4955         my $obj = $CPAN::META->instance($type,$s);
4956         $obj->$meth();
4957         if ($obj->isa(CPAN::Bundle)
4958             &&
4959             exists $obj->{install_failed}
4960             &&
4961             ref($obj->{install_failed}) eq "HASH"
4962            ) {
4963           for (keys %{$obj->{install_failed}}) {
4964             $self->{install_failed}{$_} = undef; # propagate faiure up
4965                                                  # to me in a
4966                                                  # recursive call
4967             $fail{$s} = 1; # the bundle itself may have succeeded but
4968                            # not all children
4969           }
4970         } else {
4971           my $success;
4972           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4973           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4974           if ($success) {
4975             delete $self->{install_failed}{$s};
4976           } else {
4977             $fail{$s} = 1;
4978           }
4979         }
4980     }
4981
4982     # recap with less noise
4983     if ( $meth eq "install" ) {
4984         if (%fail) {
4985             require Text::Wrap;
4986             my $raw = sprintf(qq{Bundle summary:
4987 The following items in bundle %s had installation problems:},
4988                               $self->id
4989                              );
4990             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4991             $CPAN::Frontend->myprint("\n");
4992             my $paragraph = "";
4993             my %reported;
4994             for $s ($self->contains) {
4995               if ($fail{$s}){
4996                 $paragraph .= "$s ";
4997                 $self->{install_failed}{$s} = undef;
4998                 $reported{$s} = undef;
4999               }
5000             }
5001             my $report_propagated;
5002             for $s (sort keys %{$self->{install_failed}}) {
5003               next if exists $reported{$s};
5004               $paragraph .= "and the following items had problems
5005 during recursive bundle calls: " unless $report_propagated++;
5006               $paragraph .= "$s ";
5007             }
5008             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
5009             $CPAN::Frontend->myprint("\n");
5010         } else {
5011             $self->{'install'} = 'YES';
5012         }
5013     }
5014 }
5015
5016 #sub CPAN::Bundle::xs_file
5017 sub xs_file {
5018     # If a bundle contains another that contains an xs_file we have
5019     # here, we just don't bother I suppose
5020     return 0;
5021 }
5022
5023 #-> sub CPAN::Bundle::force ;
5024 sub force   { shift->rematein('force',@_); }
5025 #-> sub CPAN::Bundle::get ;
5026 sub get     { shift->rematein('get',@_); }
5027 #-> sub CPAN::Bundle::make ;
5028 sub make    { shift->rematein('make',@_); }
5029 #-> sub CPAN::Bundle::test ;
5030 sub test    {
5031     my $self = shift;
5032     $self->{badtestcnt} ||= 0;
5033     $self->rematein('test',@_);
5034 }
5035 #-> sub CPAN::Bundle::install ;
5036 sub install {
5037   my $self = shift;
5038   $self->rematein('install',@_);
5039 }
5040 #-> sub CPAN::Bundle::clean ;
5041 sub clean   { shift->rematein('clean',@_); }
5042
5043 #-> sub CPAN::Bundle::uptodate ;
5044 sub uptodate {
5045     my($self) = @_;
5046     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5047     my $c;
5048     foreach $c ($self->contains) {
5049         my $obj = CPAN::Shell->expandany($c);
5050         return 0 unless $obj->uptodate;
5051     }
5052     return 1;
5053 }
5054
5055 #-> sub CPAN::Bundle::readme ;
5056 sub readme  {
5057     my($self) = @_;
5058     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5059 No File found for bundle } . $self->id . qq{\n}), return;
5060     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5061     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5062 }
5063
5064 package CPAN::Module;
5065
5066 # Accessors
5067 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5068 sub userid {
5069     my $self = shift;
5070     return unless exists $self->{RO}; # should never happen
5071     return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5072 }
5073 sub description { shift->{RO}{description} }
5074
5075 sub undelay {
5076     my $self = shift;
5077     delete $self->{later};
5078     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5079         $dist->undelay;
5080     }
5081 }
5082
5083 #-> sub CPAN::Module::color_cmd_tmps ;
5084 sub color_cmd_tmps {
5085     my($self) = shift;
5086     my($depth) = shift || 0;
5087     my($color) = shift || 0;
5088     # a module needs to recurse to its cpan_file
5089
5090     return if exists $self->{incommandcolor}
5091         && $self->{incommandcolor}==$color;
5092     $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5093                                    "color_cmd_tmps depth[%s] self[%s] id[%s]",
5094                                    $depth,
5095                                    $self,
5096                                    $self->id
5097                                   )) if $depth>=100;
5098     ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5099
5100     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5101         $dist->color_cmd_tmps($depth+1,$color);
5102     }
5103     if ($color==0) {
5104         delete $self->{badtestcnt};
5105     }
5106     $self->{incommandcolor} = $color;
5107 }
5108
5109 #-> sub CPAN::Module::as_glimpse ;
5110 sub as_glimpse {
5111     my($self) = @_;
5112     my(@m);
5113     my $class = ref($self);
5114     $class =~ s/^CPAN:://;
5115     my $color_on = "";
5116     my $color_off = "";
5117     if (
5118         $CPAN::Shell::COLOR_REGISTERED
5119         &&
5120         $CPAN::META->has_inst("Term::ANSIColor")
5121         &&
5122         $self->{RO}{description}
5123        ) {
5124         $color_on = Term::ANSIColor::color("green");
5125         $color_off = Term::ANSIColor::color("reset");
5126     }
5127     push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5128                      $class,
5129                      $color_on,
5130                      $self->id,
5131                      $color_off,
5132                      $self->cpan_file);
5133     join "", @m;
5134 }
5135
5136 #-> sub CPAN::Module::as_string ;
5137 sub as_string {
5138     my($self) = @_;
5139     my(@m);
5140     CPAN->debug($self) if $CPAN::DEBUG;
5141     my $class = ref($self);
5142     $class =~ s/^CPAN:://;
5143     local($^W) = 0;
5144     push @m, $class, " id = $self->{ID}\n";
5145     my $sprintf = "    %-12s %s\n";
5146     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5147         if $self->description;
5148     my $sprintf2 = "    %-12s %s (%s)\n";
5149     my($userid);
5150     if ($userid = $self->cpan_userid || $self->userid){
5151         my $author;
5152         if ($author = CPAN::Shell->expand('Author',$userid)) {
5153           my $email = "";
5154           my $m; # old perls
5155           if ($m = $author->email) {
5156             $email = " <$m>";
5157           }
5158           push @m, sprintf(
5159                            $sprintf2,
5160                            'CPAN_USERID',
5161                            $userid,
5162                            $author->fullname . $email
5163                           );
5164         }
5165     }
5166     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5167         if $self->cpan_version;
5168     push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5169         if $self->cpan_file;
5170     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5171     my(%statd,%stats,%statl,%stati);
5172     @statd{qw,? i c a b R M S,} = qw,unknown idea
5173         pre-alpha alpha beta released mature standard,;
5174     @stats{qw,? m d u n,}       = qw,unknown mailing-list
5175         developer comp.lang.perl.* none,;
5176     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
5177     @stati{qw,? f r O h,}         = qw,unknown functions
5178         references+ties object-oriented hybrid,;
5179     $statd{' '} = 'unknown';
5180     $stats{' '} = 'unknown';
5181     $statl{' '} = 'unknown';
5182     $stati{' '} = 'unknown';
5183     push @m, sprintf(
5184                      $sprintf3,
5185                      'DSLI_STATUS',
5186                      $self->{RO}{statd},
5187                      $self->{RO}{stats},
5188                      $self->{RO}{statl},
5189                      $self->{RO}{stati},
5190                      $statd{$self->{RO}{statd}},
5191                      $stats{$self->{RO}{stats}},
5192                      $statl{$self->{RO}{statl}},
5193                      $stati{$self->{RO}{stati}}
5194                     ) if $self->{RO}{statd};
5195     my $local_file = $self->inst_file;
5196     unless ($self->{MANPAGE}) {
5197         if ($local_file) {
5198             $self->{MANPAGE} = $self->manpage_headline($local_file);
5199         } else {
5200             # If we have already untarred it, we should look there
5201             my $dist = $CPAN::META->instance('CPAN::Distribution',
5202                                              $self->cpan_file);
5203             # warn "dist[$dist]";
5204             # mff=manifest file; mfh=manifest handle
5205             my($mff,$mfh);
5206             if (
5207                 $dist->{build_dir}
5208                 and
5209                 (-f  ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")))
5210                 and
5211                 $mfh = FileHandle->new($mff)
5212                ) {
5213                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5214                 my $lfre = $self->id; # local file RE
5215                 $lfre =~ s/::/./g;
5216                 $lfre .= "\\.pm\$";
5217                 my($lfl); # local file file
5218                 local $/ = "\n";
5219                 my(@mflines) = <$mfh>;
5220                 for (@mflines) {
5221                     s/^\s+//;
5222                     s/\s.*//s;
5223                 }
5224                 while (length($lfre)>5 and !$lfl) {
5225                     ($lfl) = grep /$lfre/, @mflines;
5226                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5227                     $lfre =~ s/.+?\.//;
5228                 }
5229                 $lfl =~ s/\s.*//; # remove comments
5230                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5231                 my $lfl_abs = MM->catfile($dist->{build_dir},$lfl);
5232                 # warn "lfl_abs[$lfl_abs]";
5233                 if (-f $lfl_abs) {
5234                     $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5235                 }
5236             }
5237         }
5238     }
5239     my($item);
5240     for $item (qw/MANPAGE/) {
5241         push @m, sprintf($sprintf, $item, $self->{$item})
5242             if exists $self->{$item};
5243     }
5244     for $item (qw/CONTAINS/) {
5245         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5246             if exists $self->{$item} && @{$self->{$item}};
5247     }
5248     push @m, sprintf($sprintf, 'INST_FILE',
5249                      $local_file || "(not installed)");
5250     push @m, sprintf($sprintf, 'INST_VERSION',
5251                      $self->inst_version) if $local_file;
5252     join "", @m, "\n";
5253 }
5254
5255 sub manpage_headline {
5256   my($self,$local_file) = @_;
5257   my(@local_file) = $local_file;
5258   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5259   push @local_file, $local_file;
5260   my(@result,$locf);
5261   for $locf (@local_file) {
5262     next unless -f $locf;
5263     my $fh = FileHandle->new($locf)
5264         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5265     my $inpod = 0;
5266     local $/ = "\n";
5267     while (<$fh>) {
5268       $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
5269           m/^=head1\s+NAME/ ? 1 : $inpod;
5270       next unless $inpod;
5271       next if /^=/;
5272       next if /^\s+$/;
5273       chomp;
5274       push @result, $_;
5275     }
5276     close $fh;
5277     last if @result;
5278   }
5279   join " ", @result;
5280 }
5281
5282 #-> sub CPAN::Module::cpan_file ;
5283 # Note: also inherited by CPAN::Bundle
5284 sub cpan_file {
5285     my $self = shift;
5286     CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5287     unless (defined $self->{RO}{CPAN_FILE}) {
5288         CPAN::Index->reload;
5289     }
5290     if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5291         return $self->{RO}{CPAN_FILE};
5292     } else {
5293         my $userid = $self->userid;
5294         if ( $userid ) {
5295             if ($CPAN::META->exists("CPAN::Author",$userid)) {
5296                 my $author = $CPAN::META->instance("CPAN::Author",
5297                                                    $userid);
5298                 my $fullname = $author->fullname;
5299                 my $email = $author->email;
5300                 unless (defined $fullname && defined $email) {
5301                     return sprintf("Contact Author %s",
5302                                    $userid,
5303                                   );
5304                 }
5305                 return "Contact Author $fullname <$email>";
5306             } else {
5307                 return "UserID $userid";
5308             }
5309         } else {
5310             return "N/A";
5311         }
5312     }
5313 }
5314
5315 #-> sub CPAN::Module::cpan_version ;
5316 sub cpan_version {
5317     my $self = shift;
5318
5319     $self->{RO}{CPAN_VERSION} = 'undef'
5320         unless defined $self->{RO}{CPAN_VERSION};
5321     # I believe this is always a bug in the index and should be reported
5322     # as such, but usually I find out such an error and do not want to
5323     # provoke too many bugreports
5324
5325     $self->{RO}{CPAN_VERSION};
5326 }
5327
5328 #-> sub CPAN::Module::force ;
5329 sub force {
5330     my($self) = @_;
5331     $self->{'force_update'}++;
5332 }
5333
5334 #-> sub CPAN::Module::rematein ;
5335 sub rematein {
5336     my($self,$meth) = @_;
5337     $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5338                                      $meth,
5339                                      $self->id));
5340     my $cpan_file = $self->cpan_file;
5341     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5342       $CPAN::Frontend->mywarn(sprintf qq{
5343   The module %s isn\'t available on CPAN.
5344
5345   Either the module has not yet been uploaded to CPAN, or it is
5346   temporary unavailable. Please contact the author to find out
5347   more about the status. Try 'i %s'.
5348 },
5349                               $self->id,
5350                               $self->id,
5351                              );
5352       return;
5353     }
5354     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5355     $pack->called_for($self->id);
5356     $pack->force($meth) if exists $self->{'force_update'};
5357     $pack->$meth();
5358     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5359     delete $self->{'force_update'};
5360 }
5361
5362 #-> sub CPAN::Module::readme ;
5363 sub readme { shift->rematein('readme') }
5364 #-> sub CPAN::Module::look ;
5365 sub look { shift->rematein('look') }
5366 #-> sub CPAN::Module::cvs_import ;
5367 sub cvs_import { shift->rematein('cvs_import') }
5368 #-> sub CPAN::Module::get ;
5369 sub get    { shift->rematein('get',@_); }
5370 #-> sub CPAN::Module::make ;
5371 sub make   {
5372     my $self = shift;
5373     $self->rematein('make');
5374 }
5375 #-> sub CPAN::Module::test ;
5376 sub test   {
5377     my $self = shift;
5378     $self->{badtestcnt} ||= 0;
5379     $self->rematein('test',@_);
5380 }
5381 #-> sub CPAN::Module::uptodate ;
5382 sub uptodate {
5383     my($self) = @_;
5384     my($latest) = $self->cpan_version;
5385     $latest ||= 0;
5386     my($inst_file) = $self->inst_file;
5387     my($have) = 0;
5388     if (defined $inst_file) {
5389         $have = $self->inst_version;
5390     }
5391     local($^W)=0;
5392     if ($inst_file
5393         &&
5394         ! CPAN::Version->vgt($latest, $have)
5395        ) {
5396         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5397                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
5398         return 1;
5399     }
5400     return;
5401 }
5402 #-> sub CPAN::Module::install ;
5403 sub install {
5404     my($self) = @_;
5405     my($doit) = 0;
5406     if ($self->uptodate
5407         &&
5408         not exists $self->{'force_update'}
5409        ) {
5410         $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5411     } else {
5412         $doit = 1;
5413     }
5414     $self->rematein('install') if $doit;
5415 }
5416 #-> sub CPAN::Module::clean ;
5417 sub clean  { shift->rematein('clean') }
5418
5419 #-> sub CPAN::Module::inst_file ;
5420 sub inst_file {
5421     my($self) = @_;
5422     my($dir,@packpath);
5423     @packpath = split /::/, $self->{ID};
5424     $packpath[-1] .= ".pm";
5425     foreach $dir (@INC) {
5426         my $pmfile = MM->catfile($dir,@packpath);
5427         if (-f $pmfile){
5428             return $pmfile;
5429         }
5430     }
5431     return;
5432 }
5433
5434 #-> sub CPAN::Module::xs_file ;
5435 sub xs_file {
5436     my($self) = @_;
5437     my($dir,@packpath);
5438     @packpath = split /::/, $self->{ID};
5439     push @packpath, $packpath[-1];
5440     $packpath[-1] .= "." . $Config::Config{'dlext'};
5441     foreach $dir (@INC) {
5442         my $xsfile = MM->catfile($dir,'auto',@packpath);
5443         if (-f $xsfile){
5444             return $xsfile;
5445         }
5446     }
5447     return;
5448 }
5449
5450 #-> sub CPAN::Module::inst_version ;
5451 sub inst_version {
5452     my($self) = @_;
5453     my $parsefile = $self->inst_file or return;
5454     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5455     my $have;
5456
5457     # there was a bug in 5.6.0 that let lots of unini warnings out of
5458     # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5459     # the following workaround after 5.6.1 is out.
5460     local($SIG{__WARN__}) =  sub { my $w = shift;
5461                                    return if $w =~ /uninitialized/i;
5462                                    warn $w;
5463                                  };
5464
5465     $have = MM->parse_version($parsefile) || "undef";
5466     $have =~ s/^ //; # since the %vd hack these two lines here are needed
5467     $have =~ s/ $//; # trailing whitespace happens all the time
5468
5469     # My thoughts about why %vd processing should happen here
5470
5471     # Alt1 maintain it as string with leading v:
5472     # read index files     do nothing
5473     # compare it           use utility for compare
5474     # print it             do nothing
5475
5476     # Alt2 maintain it as what is is
5477     # read index files     convert
5478     # compare it           use utility because there's still a ">" vs "gt" issue
5479     # print it             use CPAN::Version for print
5480
5481     # Seems cleaner to hold it in memory as a string starting with a "v"
5482
5483     # If the author of this module made a mistake and wrote a quoted
5484     # "v1.13" instead of v1.13, we simply leave it at that with the
5485     # effect that *we* will treat it like a v-tring while the rest of
5486     # perl won't. Seems sensible when we consider that any action we
5487     # could take now would just add complexity.
5488
5489     $have = CPAN::Version->readable($have);
5490
5491     $have =~ s/\s*//g; # stringify to float around floating point issues
5492     $have; # no stringify needed, \s* above matches always
5493 }
5494
5495 package CPAN::Tarzip;
5496
5497 # CPAN::Tarzip::gzip
5498 sub gzip {
5499   my($class,$read,$write) = @_;
5500   if ($CPAN::META->has_inst("Compress::Zlib")) {
5501     my($buffer,$fhw);
5502     $fhw = FileHandle->new($read)
5503         or $CPAN::Frontend->mydie("Could not open $read: $!");
5504     my $gz = Compress::Zlib::gzopen($write, "wb")
5505         or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5506     $gz->gzwrite($buffer)
5507         while read($fhw,$buffer,4096) > 0 ;
5508     $gz->gzclose() ;
5509     $fhw->close;
5510     return 1;
5511   } else {
5512     system("$CPAN::Config->{gzip} -c $read > $write")==0;
5513   }
5514 }
5515
5516
5517 # CPAN::Tarzip::gunzip
5518 sub gunzip {
5519   my($class,$read,$write) = @_;
5520   if ($CPAN::META->has_inst("Compress::Zlib")) {
5521     my($buffer,$fhw);
5522     $fhw = FileHandle->new(">$write")
5523         or $CPAN::Frontend->mydie("Could not open >$write: $!");
5524     my $gz = Compress::Zlib::gzopen($read, "rb")
5525         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5526     $fhw->print($buffer)
5527         while $gz->gzread($buffer) > 0 ;
5528     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5529         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5530     $gz->gzclose() ;
5531     $fhw->close;
5532     return 1;
5533   } else {
5534     system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5535   }
5536 }
5537
5538
5539 # CPAN::Tarzip::gtest
5540 sub gtest {
5541   my($class,$read) = @_;
5542   # After I had reread the documentation in zlib.h, I discovered that
5543   # uncompressed files do not lead to an gzerror (anymore?).
5544   if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5545     my($buffer,$len);
5546     $len = 0;
5547     my $gz = Compress::Zlib::gzopen($read, "rb")
5548         or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5549                                           $read,
5550                                           $Compress::Zlib::gzerrno));
5551     while ($gz->gzread($buffer) > 0 ){
5552         $len += length($buffer);
5553         $buffer = "";
5554     }
5555     my $err = $gz->gzerror;
5556     my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5557     if ($len == -s $read){
5558         $success = 0;
5559         CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5560     }
5561     $gz->gzclose();
5562     CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5563     return $success;
5564   } else {
5565       return system("$CPAN::Config->{gzip} -dt $read")==0;
5566   }
5567 }
5568
5569
5570 # CPAN::Tarzip::TIEHANDLE
5571 sub TIEHANDLE {
5572   my($class,$file) = @_;
5573   my $ret;
5574   $class->debug("file[$file]");
5575   if ($CPAN::META->has_inst("Compress::Zlib")) {
5576     my $gz = Compress::Zlib::gzopen($file,"rb") or
5577         die "Could not gzopen $file";
5578     $ret = bless {GZ => $gz}, $class;
5579   } else {
5580     my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5581     my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5582     binmode $fh;
5583     $ret = bless {FH => $fh}, $class;
5584   }
5585   $ret;
5586 }
5587
5588
5589 # CPAN::Tarzip::READLINE
5590 sub READLINE {
5591   my($self) = @_;
5592   if (exists $self->{GZ}) {
5593     my $gz = $self->{GZ};
5594     my($line,$bytesread);
5595     $bytesread = $gz->gzreadline($line);
5596     return undef if $bytesread <= 0;
5597     return $line;
5598   } else {
5599     my $fh = $self->{FH};
5600     return scalar <$fh>;
5601   }
5602 }
5603
5604
5605 # CPAN::Tarzip::READ
5606 sub READ {
5607   my($self,$ref,$length,$offset) = @_;
5608   die "read with offset not implemented" if defined $offset;
5609   if (exists $self->{GZ}) {
5610     my $gz = $self->{GZ};
5611     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5612     return $byteread;
5613   } else {
5614     my $fh = $self->{FH};
5615     return read($fh,$$ref,$length);
5616   }
5617 }
5618
5619
5620 # CPAN::Tarzip::DESTROY
5621 sub DESTROY {
5622     my($self) = @_;
5623     if (exists $self->{GZ}) {
5624         my $gz = $self->{GZ};
5625         $gz->gzclose() if defined $gz; # hard to say if it is allowed
5626                                        # to be undef ever. AK, 2000-09
5627     } else {
5628         my $fh = $self->{FH};
5629         $fh->close if defined $fh;
5630     }
5631     undef $self;
5632 }
5633
5634
5635 # CPAN::Tarzip::untar
5636 sub untar {
5637   my($class,$file) = @_;
5638   my($prefer) = 0;
5639
5640   if (0) { # makes changing order easier
5641   } elsif ($BUGHUNTING){
5642       $prefer=2;
5643   } elsif (MM->maybe_command($CPAN::Config->{gzip})
5644            &&
5645            MM->maybe_command($CPAN::Config->{'tar'})) {
5646       # should be default until Archive::Tar is fixed
5647       $prefer = 1;
5648   } elsif (
5649            $CPAN::META->has_inst("Archive::Tar")
5650            &&
5651            $CPAN::META->has_inst("Compress::Zlib") ) {
5652       $prefer = 2;
5653   } else {
5654     $CPAN::Frontend->mydie(qq{
5655 CPAN.pm needs either both external programs tar and gzip installed or
5656 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5657 is available. Can\'t continue.
5658 });
5659   }
5660   if ($prefer==1) { # 1 => external gzip+tar
5661     my($system);
5662     my $is_compressed = $class->gtest($file);
5663     if ($is_compressed) {
5664         $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5665             "< $file | $CPAN::Config->{tar} xvf -";
5666     } else {
5667         $system = "$CPAN::Config->{tar} xvf $file";
5668     }
5669     if (system($system) != 0) {
5670         # people find the most curious tar binaries that cannot handle
5671         # pipes
5672         if ($is_compressed) {
5673             (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5674             if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5675                 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5676             } else {
5677                 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5678             }
5679             $file = $ungzf;
5680         }
5681         $system = "$CPAN::Config->{tar} xvf $file";
5682         $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5683         if (system($system)==0) {
5684             $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5685         } else {
5686             $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5687         }
5688         return 1;
5689     } else {
5690         return 1;
5691     }
5692   } elsif ($prefer==2) { # 2 => modules
5693     my $tar = Archive::Tar->new($file,1);
5694     my $af; # archive file
5695     my @af;
5696     if ($BUGHUNTING) {
5697         # RCS 1.337 had this code, it turned out unacceptable slow but
5698         # it revealed a bug in Archive::Tar. Code is only here to hunt
5699         # the bug again. It should never be enabled in published code.
5700         # GDGraph3d-0.53 was an interesting case according to Larry
5701         # Virden.
5702         warn(">>>Bughunting code enabled<<< " x 20);
5703         for $af ($tar->list_files) {
5704             if ($af =~ m!^(/|\.\./)!) {
5705                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5706                                        "illegal member [$af]");
5707             }
5708             $CPAN::Frontend->myprint("$af\n");
5709             $tar->extract($af); # slow but effective for finding the bug
5710             return if $CPAN::Signal;
5711         }
5712     } else {
5713         for $af ($tar->list_files) {
5714             if ($af =~ m!^(/|\.\./)!) {
5715                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5716                                        "illegal member [$af]");
5717             }
5718             $CPAN::Frontend->myprint("$af\n");
5719             push @af, $af;
5720             return if $CPAN::Signal;
5721         }
5722         $tar->extract(@af);
5723     }
5724
5725     ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
5726         if ($^O eq 'MacOS');
5727
5728     return 1;
5729   }
5730 }
5731
5732 sub unzip {
5733     my($class,$file) = @_;
5734     if ($CPAN::META->has_inst("Archive::Zip")) {
5735         # blueprint of the code from Archive::Zip::Tree::extractTree();
5736         my $zip = Archive::Zip->new();
5737         my $status;
5738         $status = $zip->read($file);
5739         die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5740         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5741         my @members = $zip->members();
5742         for my $member ( @members ) {
5743             my $af = $member->fileName();
5744             if ($af =~ m!^(/|\.\./)!) {
5745                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5746                                        "illegal member [$af]");
5747             }
5748             my $status = $member->extractToFileNamed( $af );
5749             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5750             die "Extracting of file[$af] from zipfile[$file] failed\n" if
5751                 $status != Archive::Zip::AZ_OK();
5752             return if $CPAN::Signal;
5753         }
5754         return 1;
5755     } else {
5756         my $unzip = $CPAN::Config->{unzip} or
5757             $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5758         my @system = ($unzip, $file);
5759         return system(@system) == 0;
5760     }
5761 }
5762
5763
5764 package CPAN::Version;
5765 # CPAN::Version::vcmp courtesy Jost Krieger
5766 sub vcmp {
5767   my($self,$l,$r) = @_;
5768   local($^W) = 0;
5769   CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5770
5771   return 0 if $l eq $r; # short circuit for quicker success
5772
5773   if ($l=~/^v/ <=> $r=~/^v/) {
5774       for ($l,$r) {
5775           next if /^v/;
5776           $_ = $self->float2vv($_);
5777       }
5778   }
5779
5780   return
5781       ($l ne "undef") <=> ($r ne "undef") ||
5782           ($] >= 5.006 &&
5783            $l =~ /^v/ &&
5784            $r =~ /^v/ &&
5785            $self->vstring($l) cmp $self->vstring($r)) ||
5786                $l <=> $r ||
5787                    $l cmp $r;
5788 }
5789
5790 sub vgt {
5791   my($self,$l,$r) = @_;
5792   $self->vcmp($l,$r) > 0;
5793 }
5794
5795 sub vstring {
5796   my($self,$n) = @_;
5797   $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5798   pack "U*", split /\./, $n;
5799 }
5800
5801 # vv => visible vstring
5802 sub float2vv {
5803     my($self,$n) = @_;
5804     my($rev) = int($n);
5805     $rev ||= 0;
5806     my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5807                                           # architecture influence
5808     $mantissa ||= 0;
5809     $mantissa .= "0" while length($mantissa)%3;
5810     my $ret = "v" . $rev;
5811     while ($mantissa) {
5812         $mantissa =~ s/(\d{1,3})// or
5813             die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5814         $ret .= ".".int($1);
5815     }
5816     # warn "n[$n]ret[$ret]";
5817     $ret;
5818 }
5819
5820 sub readable {
5821   my($self,$n) = @_;
5822   $n =~ /^([\w\-\+\.]+)/;
5823
5824   return $1 if defined $1 && length($1)>0;
5825   # if the first user reaches version v43, he will be treated as "+".
5826   # We'll have to decide about a new rule here then, depending on what
5827   # will be the prevailing versioning behavior then.
5828
5829   if ($] < 5.006) { # or whenever v-strings were introduced
5830     # we get them wrong anyway, whatever we do, because 5.005 will
5831     # have already interpreted 0.2.4 to be "0.24". So even if he
5832     # indexer sends us something like "v0.2.4" we compare wrongly.
5833
5834     # And if they say v1.2, then the old perl takes it as "v12"
5835
5836     $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5837     return $n;
5838   }
5839   my $better = sprintf "v%vd", $n;
5840   CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5841   return $better;
5842 }
5843
5844 package CPAN;
5845
5846 1;
5847
5848 __END__
5849
5850 =head1 NAME
5851
5852 CPAN - query, download and build perl modules from CPAN sites
5853
5854 =head1 SYNOPSIS
5855
5856 Interactive mode:
5857
5858   perl -MCPAN -e shell;
5859
5860 Batch mode:
5861
5862   use CPAN;
5863
5864   autobundle, clean, install, make, recompile, test
5865
5866 =head1 DESCRIPTION
5867
5868 The CPAN module is designed to automate the make and install of perl
5869 modules and extensions. It includes some searching capabilities and
5870 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5871 to fetch the raw data from the net.
5872
5873 Modules are fetched from one or more of the mirrored CPAN
5874 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5875 directory.
5876
5877 The CPAN module also supports the concept of named and versioned
5878 I<bundles> of modules. Bundles simplify the handling of sets of
5879 related modules. See Bundles below.
5880
5881 The package contains a session manager and a cache manager. There is
5882 no status retained between sessions. The session manager keeps track
5883 of what has been fetched, built and installed in the current
5884 session. The cache manager keeps track of the disk space occupied by
5885 the make processes and deletes excess space according to a simple FIFO
5886 mechanism.
5887
5888 For extended searching capabilities there's a plugin for CPAN available,
5889 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5890 that indexes all documents available in CPAN authors directories. If
5891 C<CPAN::WAIT> is installed on your system, the interactive shell of
5892 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5893 which send queries to the WAIT server that has been configured for your
5894 installation.
5895
5896 All other methods provided are accessible in a programmer style and in an
5897 interactive shell style.
5898
5899 =head2 Interactive Mode
5900
5901 The interactive mode is entered by running
5902
5903     perl -MCPAN -e shell
5904
5905 which puts you into a readline interface. You will have the most fun if
5906 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5907 command completion.
5908
5909 Once you are on the command line, type 'h' and the rest should be
5910 self-explanatory.
5911
5912 The function call C<shell> takes two optional arguments, one is the
5913 prompt, the second is the default initial command line (the latter
5914 only works if a real ReadLine interface module is installed).
5915
5916 The most common uses of the interactive modes are
5917
5918 =over 2
5919
5920 =item Searching for authors, bundles, distribution files and modules
5921
5922 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5923 for each of the four categories and another, C<i> for any of the
5924 mentioned four. Each of the four entities is implemented as a class
5925 with slightly differing methods for displaying an object.
5926
5927 Arguments you pass to these commands are either strings exactly matching
5928 the identification string of an object or regular expressions that are
5929 then matched case-insensitively against various attributes of the
5930 objects. The parser recognizes a regular expression only if you
5931 enclose it between two slashes.
5932
5933 The principle is that the number of found objects influences how an
5934 item is displayed. If the search finds one item, the result is
5935 displayed with the rather verbose method C<as_string>, but if we find
5936 more than one, we display each object with the terse method
5937 <as_glimpse>.
5938
5939 =item make, test, install, clean  modules or distributions
5940
5941 These commands take any number of arguments and investigate what is
5942 necessary to perform the action. If the argument is a distribution
5943 file name (recognized by embedded slashes), it is processed. If it is
5944 a module, CPAN determines the distribution file in which this module
5945 is included and processes that, following any dependencies named in
5946 the module's Makefile.PL (this behavior is controlled by
5947 I<prerequisites_policy>.)
5948
5949 Any C<make> or C<test> are run unconditionally. An
5950
5951   install <distribution_file>
5952
5953 also is run unconditionally. But for
5954
5955   install <module>
5956
5957 CPAN checks if an install is actually needed for it and prints
5958 I<module up to date> in the case that the distribution file containing
5959 the module doesn't need to be updated.
5960
5961 CPAN also keeps track of what it has done within the current session
5962 and doesn't try to build a package a second time regardless if it
5963 succeeded or not. The C<force> command takes as a first argument the
5964 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5965 command from scratch.
5966
5967 Example:
5968
5969     cpan> install OpenGL
5970     OpenGL is up to date.
5971     cpan> force install OpenGL
5972     Running make
5973     OpenGL-0.4/
5974     OpenGL-0.4/COPYRIGHT
5975     [...]
5976
5977 A C<clean> command results in a
5978
5979   make clean
5980
5981 being executed within the distribution file's working directory.
5982
5983 =item get, readme, look module or distribution
5984
5985 C<get> downloads a distribution file without further action. C<readme>
5986 displays the README file of the associated distribution. C<Look> gets
5987 and untars (if not yet done) the distribution file, changes to the
5988 appropriate directory and opens a subshell process in that directory.
5989
5990 =item ls author
5991
5992 C<ls> lists all distribution files in and below an author's CPAN
5993 directory. Only those files that contain modules are listed and if
5994 there is more than one for any given module, only the most recent one
5995 is listed.
5996
5997 =item Signals
5998
5999 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6000 in the cpan-shell it is intended that you can press C<^C> anytime and
6001 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6002 to clean up and leave the shell loop. You can emulate the effect of a
6003 SIGTERM by sending two consecutive SIGINTs, which usually means by
6004 pressing C<^C> twice.
6005
6006 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6007 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6008
6009 =back
6010
6011 =head2 CPAN::Shell
6012
6013 The commands that are available in the shell interface are methods in
6014 the package CPAN::Shell. If you enter the shell command, all your
6015 input is split by the Text::ParseWords::shellwords() routine which
6016 acts like most shells do. The first word is being interpreted as the
6017 method to be called and the rest of the words are treated as arguments
6018 to this method. Continuation lines are supported if a line ends with a
6019 literal backslash.
6020
6021 =head2 autobundle
6022
6023 C<autobundle> writes a bundle file into the
6024 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6025 a list of all modules that are both available from CPAN and currently
6026 installed within @INC. The name of the bundle file is based on the
6027 current date and a counter.
6028
6029 =head2 recompile
6030
6031 recompile() is a very special command in that it takes no argument and
6032 runs the make/test/install cycle with brute force over all installed
6033 dynamically loadable extensions (aka XS modules) with 'force' in
6034 effect. The primary purpose of this command is to finish a network
6035 installation. Imagine, you have a common source tree for two different
6036 architectures. You decide to do a completely independent fresh
6037 installation. You start on one architecture with the help of a Bundle
6038 file produced earlier. CPAN installs the whole Bundle for you, but
6039 when you try to repeat the job on the second architecture, CPAN
6040 responds with a C<"Foo up to date"> message for all modules. So you
6041 invoke CPAN's recompile on the second architecture and you're done.
6042
6043 Another popular use for C<recompile> is to act as a rescue in case your
6044 perl breaks binary compatibility. If one of the modules that CPAN uses
6045 is in turn depending on binary compatibility (so you cannot run CPAN
6046 commands), then you should try the CPAN::Nox module for recovery.
6047
6048 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6049
6050 Although it may be considered internal, the class hierarchy does matter
6051 for both users and programmer. CPAN.pm deals with above mentioned four
6052 classes, and all those classes share a set of methods. A classical
6053 single polymorphism is in effect. A metaclass object registers all
6054 objects of all kinds and indexes them with a string. The strings
6055 referencing objects have a separated namespace (well, not completely
6056 separated):
6057
6058          Namespace                         Class
6059
6060    words containing a "/" (slash)      Distribution
6061     words starting with Bundle::          Bundle
6062           everything else            Module or Author
6063
6064 Modules know their associated Distribution objects. They always refer
6065 to the most recent official release. Developers may mark their releases
6066 as unstable development versions (by inserting an underbar into the
6067 module version number which will also be reflected in the distribution
6068 name when you run 'make dist'), so the really hottest and newest
6069 distribution is not always the default.  If a module Foo circulates
6070 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6071 way to install version 1.23 by saying
6072
6073     install Foo
6074
6075 This would install the complete distribution file (say
6076 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6077 like to install version 1.23_90, you need to know where the
6078 distribution file resides on CPAN relative to the authors/id/
6079 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6080 so you would have to say
6081
6082     install BAR/Foo-1.23_90.tar.gz
6083
6084 The first example will be driven by an object of the class
6085 CPAN::Module, the second by an object of class CPAN::Distribution.
6086
6087 =head2 Programmer's interface
6088
6089 If you do not enter the shell, the available shell commands are both
6090 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6091 functions in the calling package (C<install(...)>).
6092
6093 There's currently only one class that has a stable interface -
6094 CPAN::Shell. All commands that are available in the CPAN shell are
6095 methods of the class CPAN::Shell. Each of the commands that produce
6096 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6097 the IDs of all modules within the list.
6098
6099 =over 2
6100
6101 =item expand($type,@things)
6102
6103 The IDs of all objects available within a program are strings that can
6104 be expanded to the corresponding real objects with the
6105 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6106 list of CPAN::Module objects according to the C<@things> arguments
6107 given. In scalar context it only returns the first element of the
6108 list.
6109
6110 =item expandany(@things)
6111
6112 Like expand, but returns objects of the appropriate type, i.e.
6113 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6114 CPAN::Distribution objects fro distributions.
6115
6116 =item Programming Examples
6117
6118 This enables the programmer to do operations that combine
6119 functionalities that are available in the shell.
6120
6121     # install everything that is outdated on my disk:
6122     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6123
6124     # install my favorite programs if necessary:
6125     for $mod (qw(Net::FTP MD5 Data::Dumper)){
6126         my $obj = CPAN::Shell->expand('Module',$mod);
6127         $obj->install;
6128     }
6129
6130     # list all modules on my disk that have no VERSION number
6131     for $mod (CPAN::Shell->expand("Module","/./")){
6132         next unless $mod->inst_file;
6133         # MakeMaker convention for undefined $VERSION:
6134         next unless $mod->inst_version eq "undef";
6135         print "No VERSION in ", $mod->id, "\n";
6136     }
6137
6138     # find out which distribution on CPAN contains a module:
6139     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6140
6141 Or if you want to write a cronjob to watch The CPAN, you could list
6142 all modules that need updating. First a quick and dirty way:
6143
6144     perl -e 'use CPAN; CPAN::Shell->r;'
6145
6146 If you don't want to get any output in the case that all modules are
6147 up to date, you can parse the output of above command for the regular
6148 expression //modules are up to date// and decide to mail the output
6149 only if it doesn't match. Ick?
6150
6151 If you prefer to do it more in a programmer style in one single
6152 process, maybe something like this suits you better:
6153
6154   # list all modules on my disk that have newer versions on CPAN
6155   for $mod (CPAN::Shell->expand("Module","/./")){
6156     next unless $mod->inst_file;
6157     next if $mod->uptodate;
6158     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6159         $mod->id, $mod->inst_version, $mod->cpan_version;
6160   }
6161
6162 If that gives you too much output every day, you maybe only want to
6163 watch for three modules. You can write
6164
6165   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6166
6167 as the first line instead. Or you can combine some of the above
6168 tricks:
6169
6170   # watch only for a new mod_perl module
6171   $mod = CPAN::Shell->expand("Module","mod_perl");
6172   exit if $mod->uptodate;
6173   # new mod_perl arrived, let me know all update recommendations
6174   CPAN::Shell->r;
6175
6176 =back
6177
6178 =head2 Methods in the other Classes
6179
6180 The programming interface for the classes CPAN::Module,
6181 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6182 beta and partially even alpha. In the following paragraphs only those
6183 methods are documented that have proven useful over a longer time and
6184 thus are unlikely to change.
6185
6186 =over 4
6187
6188 =item CPAN::Author::as_glimpse()
6189
6190 Returns a one-line description of the author
6191
6192 =item CPAN::Author::as_string()
6193
6194 Returns a multi-line description of the author
6195
6196 =item CPAN::Author::email()
6197
6198 Returns the author's email address
6199
6200 =item CPAN::Author::fullname()
6201
6202 Returns the author's name
6203
6204 =item CPAN::Author::name()
6205
6206 An alias for fullname
6207
6208 =item CPAN::Bundle::as_glimpse()
6209
6210 Returns a one-line description of the bundle
6211
6212 =item CPAN::Bundle::as_string()
6213
6214 Returns a multi-line description of the bundle
6215
6216 =item CPAN::Bundle::clean()
6217
6218 Recursively runs the C<clean> method on all items contained in the bundle.
6219
6220 =item CPAN::Bundle::contains()
6221
6222 Returns a list of objects' IDs contained in a bundle. The associated
6223 objects may be bundles, modules or distributions.
6224
6225 =item CPAN::Bundle::force($method,@args)
6226
6227 Forces CPAN to perform a task that normally would have failed. Force
6228 takes as arguments a method name to be called and any number of
6229 additional arguments that should be passed to the called method. The
6230 internals of the object get the needed changes so that CPAN.pm does
6231 not refuse to take the action. The C<force> is passed recursively to
6232 all contained objects.
6233
6234 =item CPAN::Bundle::get()
6235
6236 Recursively runs the C<get> method on all items contained in the bundle
6237
6238 =item CPAN::Bundle::inst_file()
6239
6240 Returns the highest installed version of the bundle in either @INC or
6241 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6242 CPAN::Module::inst_file.
6243
6244 =item CPAN::Bundle::inst_version()
6245
6246 Like CPAN::Bundle::inst_file, but returns the $VERSION
6247
6248 =item CPAN::Bundle::uptodate()
6249
6250 Returns 1 if the bundle itself and all its members are uptodate.
6251
6252 =item CPAN::Bundle::install()
6253
6254 Recursively runs the C<install> method on all items contained in the bundle
6255
6256 =item CPAN::Bundle::make()
6257
6258 Recursively runs the C<make> method on all items contained in the bundle
6259
6260 =item CPAN::Bundle::readme()
6261
6262 Recursively runs the C<readme> method on all items contained in the bundle
6263
6264 =item CPAN::Bundle::test()
6265
6266 Recursively runs the C<test> method on all items contained in the bundle
6267
6268 =item CPAN::Distribution::as_glimpse()
6269
6270 Returns a one-line description of the distribution
6271
6272 =item CPAN::Distribution::as_string()
6273
6274 Returns a multi-line description of the distribution
6275
6276 =item CPAN::Distribution::clean()
6277
6278 Changes to the directory where the distribution has been unpacked and
6279 runs C<make clean> there.
6280
6281 =item CPAN::Distribution::containsmods()
6282
6283 Returns a list of IDs of modules contained in a distribution file.
6284 Only works for distributions listed in the 02packages.details.txt.gz
6285 file. This typically means that only the most recent version of a
6286 distribution is covered.
6287
6288 =item CPAN::Distribution::cvs_import()
6289
6290 Changes to the directory where the distribution has been unpacked and
6291 runs something like
6292
6293     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6294
6295 there.
6296
6297 =item CPAN::Distribution::dir()
6298
6299 Returns the directory into which this distribution has been unpacked.
6300
6301 =item CPAN::Distribution::force($method,@args)
6302
6303 Forces CPAN to perform a task that normally would have failed. Force
6304 takes as arguments a method name to be called and any number of
6305 additional arguments that should be passed to the called method. The
6306 internals of the object get the needed changes so that CPAN.pm does
6307 not refuse to take the action.
6308
6309 =item CPAN::Distribution::get()
6310
6311 Downloads the distribution from CPAN and unpacks it. Does nothing if
6312 the distribution has already been downloaded and unpacked within the
6313 current session.
6314
6315 =item CPAN::Distribution::install()
6316
6317 Changes to the directory where the distribution has been unpacked and
6318 runs the external command C<make install> there. If C<make> has not
6319 yet been run, it will be run first. A C<make test> will be issued in
6320 any case and if this fails, the install will be cancelled. The
6321 cancellation can be avoided by letting C<force> run the C<install> for
6322 you.
6323
6324 =item CPAN::Distribution::isa_perl()
6325
6326 Returns 1 if this distribution file seems to be a perl distribution.
6327 Normally this is derived from the file name only, but the index from
6328 CPAN can contain a hint to achieve a return value of true for other
6329 filenames too.
6330
6331 =item CPAN::Distribution::look()
6332
6333 Changes to the directory where the distribution has been unpacked and
6334 opens a subshell there. Exiting the subshell returns.
6335
6336 =item CPAN::Distribution::make()
6337
6338 First runs the C<get> method to make sure the distribution is
6339 downloaded and unpacked. Changes to the directory where the
6340 distribution has been unpacked and runs the external commands C<perl
6341 Makefile.PL> and C<make> there.
6342
6343 =item CPAN::Distribution::prereq_pm()
6344
6345 Returns the hash reference that has been announced by a distribution
6346 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6347 attempt has been made to C<make> the distribution. Returns undef
6348 otherwise.
6349
6350 =item CPAN::Distribution::readme()
6351
6352 Downloads the README file associated with a distribution and runs it
6353 through the pager specified in C<$CPAN::Config->{pager}>.
6354
6355 =item CPAN::Distribution::test()
6356
6357 Changes to the directory where the distribution has been unpacked and
6358 runs C<make test> there.
6359
6360 =item CPAN::Distribution::uptodate()
6361
6362 Returns 1 if all the modules contained in the distribution are
6363 uptodate. Relies on containsmods.
6364
6365 =item CPAN::Index::force_reload()
6366
6367 Forces a reload of all indices.
6368
6369 =item CPAN::Index::reload()
6370
6371 Reloads all indices if they have been read more than
6372 C<$CPAN::Config->{index_expire}> days.
6373
6374 =item CPAN::InfoObj::dump()
6375
6376 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6377 inherit this method. It prints the data structure associated with an
6378 object. Useful for debugging. Note: the data structure is considered
6379 internal and thus subject to change without notice.
6380
6381 =item CPAN::Module::as_glimpse()
6382
6383 Returns a one-line description of the module
6384
6385 =item CPAN::Module::as_string()
6386
6387 Returns a multi-line description of the module
6388
6389 =item CPAN::Module::clean()
6390
6391 Runs a clean on the distribution associated with this module.
6392
6393 =item CPAN::Module::cpan_file()
6394
6395 Returns the filename on CPAN that is associated with the module.
6396
6397 =item CPAN::Module::cpan_version()
6398
6399 Returns the latest version of this module available on CPAN.
6400
6401 =item CPAN::Module::cvs_import()
6402
6403 Runs a cvs_import on the distribution associated with this module.
6404
6405 =item CPAN::Module::description()
6406
6407 Returns a 44 chracter description of this module. Only available for
6408 modules listed in The Module List (CPAN/modules/00modlist.long.html
6409 or 00modlist.long.txt.gz)
6410
6411 =item CPAN::Module::force($method,@args)
6412
6413 Forces CPAN to perform a task that normally would have failed. Force
6414 takes as arguments a method name to be called and any number of
6415 additional arguments that should be passed to the called method. The
6416 internals of the object get the needed changes so that CPAN.pm does
6417 not refuse to take the action.
6418
6419 =item CPAN::Module::get()
6420
6421 Runs a get on the distribution associated with this module.
6422
6423 =item CPAN::Module::inst_file()
6424
6425 Returns the filename of the module found in @INC. The first file found
6426 is reported just like perl itself stops searching @INC when it finds a
6427 module.
6428
6429 =item CPAN::Module::inst_version()
6430
6431 Returns the version number of the module in readable format.
6432
6433 =item CPAN::Module::install()
6434
6435 Runs an C<install> on the distribution associated with this module.
6436
6437 =item CPAN::Module::look()
6438
6439 Changes to the directory where the distribution assoicated with this
6440 module has been unpacked and opens a subshell there. Exiting the
6441 subshell returns.
6442
6443 =item CPAN::Module::make()
6444
6445 Runs a C<make> on the distribution associated with this module.
6446
6447 =item CPAN::Module::manpage_headline()
6448
6449 If module is installed, peeks into the module's manpage, reads the
6450 headline and returns it. Moreover, if the module has been downloaded
6451 within this session, does the equivalent on the downloaded module even
6452 if it is not installed.
6453
6454 =item CPAN::Module::readme()
6455
6456 Runs a C<readme> on the distribution associated with this module.
6457
6458 =item CPAN::Module::test()
6459
6460 Runs a C<test> on the distribution associated with this module.
6461
6462 =item CPAN::Module::uptodate()
6463
6464 Returns 1 if the module is installed and up-to-date.
6465
6466 =item CPAN::Module::userid()
6467
6468 Returns the author's ID of the module.
6469
6470 =back
6471
6472 =head2 Cache Manager
6473
6474 Currently the cache manager only keeps track of the build directory
6475 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6476 deletes complete directories below C<build_dir> as soon as the size of
6477 all directories there gets bigger than $CPAN::Config->{build_cache}
6478 (in MB). The contents of this cache may be used for later
6479 re-installations that you intend to do manually, but will never be
6480 trusted by CPAN itself. This is due to the fact that the user might
6481 use these directories for building modules on different architectures.
6482
6483 There is another directory ($CPAN::Config->{keep_source_where}) where
6484 the original distribution files are kept. This directory is not
6485 covered by the cache manager and must be controlled by the user. If
6486 you choose to have the same directory as build_dir and as
6487 keep_source_where directory, then your sources will be deleted with
6488 the same fifo mechanism.
6489
6490 =head2 Bundles
6491
6492 A bundle is just a perl module in the namespace Bundle:: that does not
6493 define any functions or methods. It usually only contains documentation.
6494
6495 It starts like a perl module with a package declaration and a $VERSION
6496 variable. After that the pod section looks like any other pod with the
6497 only difference being that I<one special pod section> exists starting with
6498 (verbatim):
6499
6500         =head1 CONTENTS
6501
6502 In this pod section each line obeys the format
6503
6504         Module_Name [Version_String] [- optional text]
6505
6506 The only required part is the first field, the name of a module
6507 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6508 of the line is optional. The comment part is delimited by a dash just
6509 as in the man page header.
6510
6511 The distribution of a bundle should follow the same convention as
6512 other distributions.
6513
6514 Bundles are treated specially in the CPAN package. If you say 'install
6515 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6516 the modules in the CONTENTS section of the pod. You can install your
6517 own Bundles locally by placing a conformant Bundle file somewhere into
6518 your @INC path. The autobundle() command which is available in the
6519 shell interface does that for you by including all currently installed
6520 modules in a snapshot bundle file.
6521
6522 =head2 Prerequisites
6523
6524 If you have a local mirror of CPAN and can access all files with
6525 "file:" URLs, then you only need a perl better than perl5.003 to run
6526 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6527 required for non-UNIX systems or if your nearest CPAN site is
6528 associated with an URL that is not C<ftp:>.
6529
6530 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6531 implemented for an external ftp command or for an external lynx
6532 command.
6533
6534 =head2 Finding packages and VERSION
6535
6536 This module presumes that all packages on CPAN
6537
6538 =over 2
6539
6540 =item *
6541
6542 declare their $VERSION variable in an easy to parse manner. This
6543 prerequisite can hardly be relaxed because it consumes far too much
6544 memory to load all packages into the running program just to determine
6545 the $VERSION variable. Currently all programs that are dealing with
6546 version use something like this
6547
6548     perl -MExtUtils::MakeMaker -le \
6549         'print MM->parse_version(shift)' filename
6550
6551 If you are author of a package and wonder if your $VERSION can be
6552 parsed, please try the above method.
6553
6554 =item *
6555
6556 come as compressed or gzipped tarfiles or as zip files and contain a
6557 Makefile.PL (well, we try to handle a bit more, but without much
6558 enthusiasm).
6559
6560 =back
6561
6562 =head2 Debugging
6563
6564 The debugging of this module is a bit complex, because we have
6565 interferences of the software producing the indices on CPAN, of the
6566 mirroring process on CPAN, of packaging, of configuration, of
6567 synchronicity, and of bugs within CPAN.pm.
6568
6569 For code debugging in interactive mode you can try "o debug" which
6570 will list options for debugging the various parts of the code. You
6571 should know that "o debug" has built-in completion support.
6572
6573 For data debugging there is the C<dump> command which takes the same
6574 arguments as make/test/install and outputs the object's Data::Dumper
6575 dump.
6576
6577 =head2 Floppy, Zip, Offline Mode
6578
6579 CPAN.pm works nicely without network too. If you maintain machines
6580 that are not networked at all, you should consider working with file:
6581 URLs. Of course, you have to collect your modules somewhere first. So
6582 you might use CPAN.pm to put together all you need on a networked
6583 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6584 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6585 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6586 with this floppy. See also below the paragraph about CD-ROM support.
6587
6588 =head1 CONFIGURATION
6589
6590 When the CPAN module is installed, a site wide configuration file is
6591 created as CPAN/Config.pm. The default values defined there can be
6592 overridden in another configuration file: CPAN/MyConfig.pm. You can
6593 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6594 $HOME/.cpan is added to the search path of the CPAN module before the
6595 use() or require() statements.
6596
6597 Currently the following keys in the hash reference $CPAN::Config are
6598 defined:
6599
6600   build_cache        size of cache for directories to build modules
6601   build_dir          locally accessible directory to build modules
6602   index_expire       after this many days refetch index files
6603   cache_metadata     use serializer to cache metadata
6604   cpan_home          local directory reserved for this package
6605   dontload_hash      anonymous hash: modules in the keys will not be
6606                      loaded by the CPAN::has_inst() routine
6607   gzip               location of external program gzip
6608   inactivity_timeout breaks interactive Makefile.PLs after this
6609                      many seconds inactivity. Set to 0 to never break.
6610   inhibit_startup_message
6611                      if true, does not print the startup message
6612   keep_source_where  directory in which to keep the source (if we do)
6613   make               location of external make program
6614   make_arg           arguments that should always be passed to 'make'
6615   make_install_arg   same as make_arg for 'make install'
6616   makepl_arg         arguments passed to 'perl Makefile.PL'
6617   pager              location of external program more (or any pager)
6618   prerequisites_policy
6619                      what to do if you are missing module prerequisites
6620                      ('follow' automatically, 'ask' me, or 'ignore')
6621   proxy_user         username for accessing an authenticating proxy
6622   proxy_pass         password for accessing an authenticating proxy
6623   scan_cache         controls scanning of cache ('atstart' or 'never')
6624   tar                location of external program tar
6625   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
6626                      (and nonsense for characters outside latin range)
6627   unzip              location of external program unzip
6628   urllist            arrayref to nearby CPAN sites (or equivalent locations)
6629   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
6630   ftp_proxy,      }  the three usual variables for configuring
6631     http_proxy,   }  proxy requests. Both as CPAN::Config variables
6632     no_proxy      }  and as environment variables configurable.
6633
6634 You can set and query each of these options interactively in the cpan
6635 shell with the command set defined within the C<o conf> command:
6636
6637 =over 2
6638
6639 =item C<o conf E<lt>scalar optionE<gt>>
6640
6641 prints the current value of the I<scalar option>
6642
6643 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6644
6645 Sets the value of the I<scalar option> to I<value>
6646
6647 =item C<o conf E<lt>list optionE<gt>>
6648
6649 prints the current value of the I<list option> in MakeMaker's
6650 neatvalue format.
6651
6652 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6653
6654 shifts or pops the array in the I<list option> variable
6655
6656 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6657
6658 works like the corresponding perl commands.
6659
6660 =back
6661
6662 =head2 Note on urllist parameter's format
6663
6664 urllist parameters are URLs according to RFC 1738. We do a little
6665 guessing if your URL is not compliant, but if you have problems with
6666 file URLs, please try the correct format. Either:
6667
6668     file://localhost/whatever/ftp/pub/CPAN/
6669
6670 or
6671
6672     file:///home/ftp/pub/CPAN/
6673
6674 =head2 urllist parameter has CD-ROM support
6675
6676 The C<urllist> parameter of the configuration table contains a list of
6677 URLs that are to be used for downloading. If the list contains any
6678 C<file> URLs, CPAN always tries to get files from there first. This
6679 feature is disabled for index files. So the recommendation for the
6680 owner of a CD-ROM with CPAN contents is: include your local, possibly
6681 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6682
6683   o conf urllist push file://localhost/CDROM/CPAN
6684
6685 CPAN.pm will then fetch the index files from one of the CPAN sites
6686 that come at the beginning of urllist. It will later check for each
6687 module if there is a local copy of the most recent version.
6688
6689 Another peculiarity of urllist is that the site that we could
6690 successfully fetch the last file from automatically gets a preference
6691 token and is tried as the first site for the next request. So if you
6692 add a new site at runtime it may happen that the previously preferred
6693 site will be tried another time. This means that if you want to disallow
6694 a site for the next transfer, it must be explicitly removed from
6695 urllist.
6696
6697 =head1 SECURITY
6698
6699 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6700 install foreign, unmasked, unsigned code on your machine. We compare
6701 to a checksum that comes from the net just as the distribution file
6702 itself. If somebody has managed to tamper with the distribution file,
6703 they may have as well tampered with the CHECKSUMS file. Future
6704 development will go towards strong authentication.
6705
6706 =head1 EXPORT
6707
6708 Most functions in package CPAN are exported per default. The reason
6709 for this is that the primary use is intended for the cpan shell or for
6710 oneliners.
6711
6712 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6713
6714 Populating a freshly installed perl with my favorite modules is pretty
6715 easy if you maintain a private bundle definition file. To get a useful
6716 blueprint of a bundle definition file, the command autobundle can be used
6717 on the CPAN shell command line. This command writes a bundle definition
6718 file for all modules that are installed for the currently running perl
6719 interpreter. It's recommended to run this command only once and from then
6720 on maintain the file manually under a private name, say
6721 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6722
6723     cpan> install Bundle::my_bundle
6724
6725 then answer a few questions and then go out for a coffee.
6726
6727 Maintaining a bundle definition file means keeping track of two
6728 things: dependencies and interactivity. CPAN.pm sometimes fails on
6729 calculating dependencies because not all modules define all MakeMaker
6730 attributes correctly, so a bundle definition file should specify
6731 prerequisites as early as possible. On the other hand, it's a bit
6732 annoying that many distributions need some interactive configuring. So
6733 what I try to accomplish in my private bundle file is to have the
6734 packages that need to be configured early in the file and the gentle
6735 ones later, so I can go out after a few minutes and leave CPAN.pm
6736 untended.
6737
6738 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6739
6740 Thanks to Graham Barr for contributing the following paragraphs about
6741 the interaction between perl, and various firewall configurations. For
6742 further informations on firewalls, it is recommended to consult the
6743 documentation that comes with the ncftp program. If you are unable to
6744 go through the firewall with a simple Perl setup, it is very likely
6745 that you can configure ncftp so that it works for your firewall.
6746
6747 =head2 Three basic types of firewalls
6748
6749 Firewalls can be categorized into three basic types.
6750
6751 =over 4
6752
6753 =item http firewall
6754
6755 This is where the firewall machine runs a web server and to access the
6756 outside world you must do it via the web server. If you set environment
6757 variables like http_proxy or ftp_proxy to a values beginning with http://
6758 or in your web browser you have to set proxy information then you know
6759 you are running a http firewall.
6760
6761 To access servers outside these types of firewalls with perl (even for
6762 ftp) you will need to use LWP.
6763
6764 =item ftp firewall
6765
6766 This where the firewall machine runs a ftp server. This kind of
6767 firewall will only let you access ftp servers outside the firewall.
6768 This is usually done by connecting to the firewall with ftp, then
6769 entering a username like "user@outside.host.com"
6770
6771 To access servers outside these type of firewalls with perl you
6772 will need to use Net::FTP.
6773
6774 =item One way visibility
6775
6776 I say one way visibility as these firewalls try to make themselve look
6777 invisible to the users inside the firewall. An FTP data connection is
6778 normally created by sending the remote server your IP address and then
6779 listening for the connection. But the remote server will not be able to
6780 connect to you because of the firewall. So for these types of firewall
6781 FTP connections need to be done in a passive mode.
6782
6783 There are two that I can think off.
6784
6785 =over 4
6786
6787 =item SOCKS
6788
6789 If you are using a SOCKS firewall you will need to compile perl and link
6790 it with the SOCKS library, this is what is normally called a 'socksified'
6791 perl. With this executable you will be able to connect to servers outside
6792 the firewall as if it is not there.
6793
6794 =item IP Masquerade
6795
6796 This is the firewall implemented in the Linux kernel, it allows you to
6797 hide a complete network behind one IP address. With this firewall no
6798 special compiling is needed as you can access hosts directly.
6799
6800 =back
6801
6802 =back
6803
6804 =head2 Configuring lynx or ncftp for going through a firewall
6805
6806 If you can go through your firewall with e.g. lynx, presumably with a
6807 command such as
6808
6809     /usr/local/bin/lynx -pscott:tiger
6810
6811 then you would configure CPAN.pm with the command
6812
6813     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6814
6815 That's all. Similarly for ncftp or ftp, you would configure something
6816 like
6817
6818     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6819
6820 Your milage may vary...
6821
6822 =head1 FAQ
6823
6824 =over 4
6825
6826 =item 1)
6827
6828 I installed a new version of module X but CPAN keeps saying,
6829 I have the old version installed
6830
6831 Most probably you B<do> have the old version installed. This can
6832 happen if a module installs itself into a different directory in the
6833 @INC path than it was previously installed. This is not really a
6834 CPAN.pm problem, you would have the same problem when installing the
6835 module manually. The easiest way to prevent this behaviour is to add
6836 the argument C<UNINST=1> to the C<make install> call, and that is why
6837 many people add this argument permanently by configuring
6838
6839   o conf make_install_arg UNINST=1
6840
6841 =item 2)
6842
6843 So why is UNINST=1 not the default?
6844
6845 Because there are people who have their precise expectations about who
6846 may install where in the @INC path and who uses which @INC array. In
6847 fine tuned environments C<UNINST=1> can cause damage.
6848
6849 =item 3)
6850
6851 I want to clean up my mess, and install a new perl along with
6852 all modules I have. How do I go about it?
6853
6854 Run the autobundle command for your old perl and optionally rename the
6855 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6856 with the Configure option prefix, e.g.
6857
6858     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6859
6860 Install the bundle file you produced in the first step with something like
6861
6862     cpan> install Bundle::mybundle
6863
6864 and you're done.
6865
6866 =item 4)
6867
6868 When I install bundles or multiple modules with one command
6869 there is too much output to keep track of.
6870
6871 You may want to configure something like
6872
6873   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6874   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6875
6876 so that STDOUT is captured in a file for later inspection.
6877
6878
6879 =item 5)
6880
6881 I am not root, how can I install a module in a personal directory?
6882
6883 You will most probably like something like this:
6884
6885   o conf makepl_arg "LIB=~/myperl/lib \
6886                     INSTALLMAN1DIR=~/myperl/man/man1 \
6887                     INSTALLMAN3DIR=~/myperl/man/man3"
6888   install Sybase::Sybperl
6889
6890 You can make this setting permanent like all C<o conf> settings with
6891 C<o conf commit>.
6892
6893 You will have to add ~/myperl/man to the MANPATH environment variable
6894 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6895 including
6896
6897   use lib "$ENV{HOME}/myperl/lib";
6898
6899 or setting the PERL5LIB environment variable.
6900
6901 Another thing you should bear in mind is that the UNINST parameter
6902 should never be set if you are not root.
6903
6904 =item 6)
6905
6906 How to get a package, unwrap it, and make a change before building it?
6907
6908   look Sybase::Sybperl
6909
6910 =item 7)
6911
6912 I installed a Bundle and had a couple of fails. When I
6913 retried, everything resolved nicely. Can this be fixed to work
6914 on first try?
6915
6916 The reason for this is that CPAN does not know the dependencies of all
6917 modules when it starts out. To decide about the additional items to
6918 install, it just uses data found in the generated Makefile. An
6919 undetected missing piece breaks the process. But it may well be that
6920 your Bundle installs some prerequisite later than some depending item
6921 and thus your second try is able to resolve everything. Please note,
6922 CPAN.pm does not know the dependency tree in advance and cannot sort
6923 the queue of things to install in a topologically correct order. It
6924 resolves perfectly well IFF all modules declare the prerequisites
6925 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6926 fail and you need to install often, it is recommended sort the Bundle
6927 definition file manually. It is planned to improve the metadata
6928 situation for dependencies on CPAN in general, but this will still
6929 take some time.
6930
6931 =item 8)
6932
6933 In our intranet we have many modules for internal use. How
6934 can I integrate these modules with CPAN.pm but without uploading
6935 the modules to CPAN?
6936
6937 Have a look at the CPAN::Site module.
6938
6939 =item 9)
6940
6941 When I run CPAN's shell, I get error msg about line 1 to 4,
6942 setting meta input/output via the /etc/inputrc file.
6943
6944 Some versions of readline are picky about capitalization in the
6945 /etc/inputrc file and specifically RedHat 6.2 comes with a
6946 /etc/inputrc that contains the word C<on> in lowercase. Change the
6947 occurrences of C<on> to C<On> and the bug should disappear.
6948
6949 =item 10)
6950
6951 Some authors have strange characters in their names.
6952
6953 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
6954 expecting ISO-8859-1 charset, a converter can be activated by setting
6955 term_is_latin to a true value in your config file. One way of doing so
6956 would be
6957
6958     cpan> ! $CPAN::Config->{term_is_latin}=1
6959
6960 Extended support for converters will be made available as soon as perl
6961 becomes stable with regard to charset issues.
6962
6963 =back
6964
6965 =head1 BUGS
6966
6967 We should give coverage for B<all> of the CPAN and not just the PAUSE
6968 part, right? In this discussion CPAN and PAUSE have become equal --
6969 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6970 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6971
6972 Future development should be directed towards a better integration of
6973 the other parts.
6974
6975 If a Makefile.PL requires special customization of libraries, prompts
6976 the user for special input, etc. then you may find CPAN is not able to
6977 build the distribution. In that case, you should attempt the
6978 traditional method of building a Perl module package from a shell.
6979
6980 =head1 AUTHOR
6981
6982 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
6983
6984 =head1 TRANSLATIONS
6985
6986 Kawai,Takanori provides a Japanese translation of this manpage at
6987 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
6988
6989 =head1 SEE ALSO
6990
6991 perl(1), CPAN::Nox(3)
6992
6993 =cut
6994