lib/CPAN.pm

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