lib/CPAN.pm

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