lib/CPAN.pm

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