lib/CPAN.pm

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