lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 package CPAN;
   3 $VERSION = '1.76_60';
   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 FileHandle ();
  18 use Safe ();
  19 use Text::ParseWords ();
  20 use Text::Wrap;
  21 use File::Spec;
  22 use File::Temp ();
  23 use Sys::Hostname;
  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) = [at]_;
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             CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$p
1685 wd'")
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     if ($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) = [at]_;
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
3806 $silent ;
3807         return;
3808     }
3809     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
3810     unless (grep {$_->[2] eq $csf[2]} @dl) {
3811         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $sil
3812 ent;
3813         return;
3814     }
3815     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
3816     $CPAN::Frontend->myprint(join "", map {
3817         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3818     } sort { $a->[2] cmp $b->[2] } @dl) unless $silent;
3819 }
3820
3821 # returns an array of arrays, the latter contain (size,mtime,filename)
3822 #-> sub CPAN::Author::dir_listing ;
3823 sub dir_listing {
3824     my $self = shift;
3825     my $chksumfile = shift;
3826     my $recursive = shift;
3827     my $may_ftp = shift;
3828     my $lc_want =
3829         File::Spec->catfile($CPAN::Config->{keep_source_where},
3830                             "authors", "id", @$chksumfile);
3831
3832     my $fh;
3833
3834     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
3835     # hazard.  (Without GPG installed they are not that much better,
3836     # though.)
3837     $fh = FileHandle->new;
3838     if (open($fh, $lc_want)) {
3839         my $line = <$fh>; close $fh;
3840         unlink($lc_want) unless $line =~ /PGP/;
3841     }
3842     local($") = "/";
3843     # connect "force" argument with "index_expire".
3844     my $force = 0;
3845     if (my @stat = stat $lc_want) {
3846         $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3847     }
3848     my $lc_file;
3849     if ($may_ftp) {
3850         $lc_file = CPAN::FTP->localize(
3851                                        "authors/id/@$chksumfile",
3852                                        $lc_want,
3853                                        $force,
3854                                       );
3855         unless ($lc_file) {
3856             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3857             $chksumfile->[-1] .= ".gz";
3858             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3859                                            "$lc_want.gz",1);
3860             if ($lc_file) {
3861                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3862                 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3863             } else {
3864                 return;
3865             }
3866         }
3867     } else {
3868         $lc_file = $lc_want;
3869         # we *could* second-guess and if the user has a file: URL,
3870         # then we could look there. But on the other hand, if they do
3871         # have a file: URL, wy did they choose to set
3872         # $CPAN::Config->{show_upload_date} to false?
3873     }
3874
3875     # adapted from CPAN::Distribution::MD5_check_file ;
3876     $fh = FileHandle->new;
3877     my($cksum);
3878     if (open $fh, $lc_file){
3879         local($/);
3880         my $eval = <$fh>;
3881         $eval =~ s/\015?\012/\n/g;
3882         close $fh;
3883         my($comp) = Safe->new();
3884         $cksum = $comp->reval($eval);
3885         if ($@) {
3886             rename $lc_file, "$lc_file.bad";
3887             Carp::confess($@) if $@;
3888         }
3889     } elsif ($may_ftp) {
3890         Carp::carp "Could not open $lc_file for reading.";
3891     } else {
3892         # Maybe should warn: "You may want to set show_upload_date to a true value"
3893         return;
3894     }
3895     my(@result,$f);
3896     for $f (sort keys %$cksum) {
3897         if (exists $cksum->{$f}{isdir}) {
3898             if ($recursive) {
3899                 my(@dir) = @$chksumfile;
3900                 pop @dir;
3901                 push @dir, $f, "CHECKSUMS";
3902                 push @result, map {
3903                     [$_->[0], $_->[1], "$f/$_->[2]"]
3904                 } $self->dir_listing(\@dir,1,$may_ftp);
3905             } else {
3906                 push @result, [ 0, "-", $f ];
3907             }
3908         } else {
3909             push @result, [
3910                            ($cksum->{$f}{"size"}||0),
3911                            $cksum->{$f}{"mtime"}||"---",
3912                            $f
3913                           ];
3914         }
3915     }
3916     @result;
3917 }
3918
3919 package CPAN::Distribution;
3920
3921 # Accessors
3922 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3923
3924 sub undelay {
3925     my $self = shift;
3926     delete $self->{later};
3927 }
3928
3929 # CPAN::Distribution::normalize
3930 sub normalize {
3931     my($self,$s) = @_;
3932     $s = $self->id unless defined $s;
3933     if (
3934         $s =~ tr|/|| == 1
3935         or
3936         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3937        ) {
3938         return $s if $s =~ m:^N/A|^Contact Author: ;
3939         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3940             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3941         CPAN->debug("s[$s]") if $CPAN::DEBUG;
3942     }
3943     $s;
3944 }
3945
3946 #-> sub CPAN::Distribution::color_cmd_tmps ;
3947 sub color_cmd_tmps {
3948     my($self) = shift;
3949     my($depth) = shift || 0;
3950     my($color) = shift || 0;
3951     my($ancestors) = shift || [];
3952     # a distribution needs to recurse into its prereq_pms
3953
3954     return if exists $self->{incommandcolor}
3955         && $self->{incommandcolor}==$color;
3956     if ($depth>=100){
3957         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3958     }
3959     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3960     my $prereq_pm = $self->prereq_pm;
3961     if (defined $prereq_pm) {
3962         for my $pre (keys %$prereq_pm) {
3963             my $premo = CPAN::Shell->expand("Module",$pre);
3964             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3965         }
3966     }
3967     if ($color==0) {
3968         delete $self->{sponsored_mods};
3969         delete $self->{badtestcnt};
3970     }
3971     $self->{incommandcolor} = $color;
3972 }
3973
3974 #-> sub CPAN::Distribution::as_string ;
3975 sub as_string {
3976   my $self = shift;
3977   $self->containsmods;
3978   $self->upload_date;
3979   $self->SUPER::as_string(@_);
3980 }
3981
3982 #-> sub CPAN::Distribution::containsmods ;
3983 sub containsmods {
3984   my $self = shift;
3985   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3986   my $dist_id = $self->{ID};
3987   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3988     my $mod_file = $mod->cpan_file or next;
3989     my $mod_id = $mod->{ID} or next;
3990     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3991     # sleep 1;
3992     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3993   }
3994   keys %{$self->{CONTAINSMODS}};
3995 }
3996
3997 #-> sub CPAN::Distribution::upload_date ;
3998 sub upload_date {
3999   my $self = shift;
4000   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4001   my(@local_wanted) = split(/\//,$self->id);
4002   my $filename = pop [at]local_wanted;
4003   push [at]local_wanted, "CHECKSUMS";
4004   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4005   return unless $author;
4006   my [at]dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4007   return unless [at]dl;
4008   my($dirent) = grep { $_->[2] eq $filename } [at]dl;
4009   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4010   return unless $dirent->[1];
4011   return $self->{UPLOAD_DATE} = $dirent->[1];
4012 }
4013
4014 #-> sub CPAN::Distribution::uptodate ;
4015 sub uptodate {
4016     my($self) = @_;
4017     my $c;
4018     foreach $c ($self->containsmods) {
4019         my $obj = CPAN::Shell->expandany($c);
4020         return 0 unless $obj->uptodate;
4021     }
4022     return 1;
4023 }
4024
4025 #-> sub CPAN::Distribution::called_for ;
4026 sub called_for {
4027     my($self,$id) = @_;
4028     $self->{CALLED_FOR} = $id if defined $id;
4029     return $self->{CALLED_FOR};
4030 }
4031
4032 #-> sub CPAN::Distribution::safe_chdir ;
4033 sub safe_chdir {
4034     my($self,$todir) = @_;
4035     # we die if we cannot chdir and we are debuggable
4036     Carp::confess("safe_chdir called without todir argument")
4037           unless defined $todir and length $todir;
4038     if (chdir $todir) {
4039         $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4040             if $CPAN::DEBUG;
4041     } else {
4042         my $cwd = CPAN::anycwd();
4043         $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4044                                qq{to todir[$todir]: $!});
4045     }
4046 }
4047
4048 #-> sub CPAN::Distribution::get ;
4049 sub get {
4050     my($self) = @_;
4051   EXCUSE: {
4052         my @e;
4053         exists $self->{'build_dir'} and push @e,
4054             "Is already unwrapped into directory $self->{'build_dir'}";
4055         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4056     }
4057     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4058
4059     #
4060     # Get the file on local disk
4061     #
4062
4063     my($local_file);
4064     my($local_wanted) =
4065         File::Spec->catfile(
4066                             $CPAN::Config->{keep_source_where},
4067                             "authors",
4068                             "id",
4069                             split(/\//,$self->id)
4070                            );
4071
4072     $self->debug("Doing localize") if $CPAN::DEBUG;
4073     unless ($local_file =
4074             CPAN::FTP->localize("authors/id/$self->{ID}",
4075                                 $local_wanted)) {
4076         my $note = "";
4077         if ($CPAN::Index::DATE_OF_02) {
4078             $note = "Note: Current database in memory was generated ".
4079                 "on $CPAN::Index::DATE_OF_02\n";
4080         }
4081         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4082     }
4083     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4084     $self->{localfile} = $local_file;
4085     return if $CPAN::Signal;
4086
4087     #
4088     # Check integrity
4089     #
4090     if ($CPAN::META->has_inst("Digest::MD5")) {
4091         $self->debug("Digest::MD5 is installed, verifying");
4092         $self->verifyMD5;
4093     } else {
4094         $self->debug("Digest::MD5 is NOT installed");
4095     }
4096     return if $CPAN::Signal;
4097
4098     #
4099     # Create a clean room and go there
4100     #
4101     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4102     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4103     $self->safe_chdir($builddir);
4104     $self->debug("Removing tmp") if $CPAN::DEBUG;
4105     File::Path::rmtree("tmp");
4106     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
4107     if ($CPAN::Signal){
4108         $self->safe_chdir($sub_wd);
4109         return;
4110     }
4111     $self->safe_chdir("tmp");
4112
4113     #
4114     # Unpack the goods
4115     #
4116     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4117     if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
4118         $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
4119         $self->untar_me($local_file);
4120     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4121         $self->unzip_me($local_file);
4122     } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
4123         $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
4124         $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
4125         $self->pm2dir_me($local_file);
4126     } else {
4127         $self->{archived} = "NO";
4128         $self->safe_chdir($sub_wd);
4129         return;
4130     }
4131
4132     # we are still in the tmp directory!
4133     # Let's check if the package has its own directory.
4134     my $dh = DirHandle->new(File::Spec->curdir)
4135         or Carp::croak("Couldn't opendir .: $!");
4136     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4137     $dh->close;
4138     my ($distdir,$packagedir);
4139     if (@readdir == 1 && -d $readdir[0]) {
4140         $distdir = $readdir[0];
4141         $packagedir = File::Spec->catdir($builddir,$distdir);
4142         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4143             if $CPAN::DEBUG;
4144         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4145                                                     "$packagedir\n");
4146         File::Path::rmtree($packagedir);
4147         File::Copy::move($distdir,$packagedir) or
4148             Carp::confess("Couldn't move $distdir to $packagedir: $!");
4149         $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4150                              $distdir,
4151                              $packagedir,
4152                              -e $packagedir,
4153                              -d $packagedir,
4154                             )) if $CPAN::DEBUG;
4155     } else {
4156         my $userid = $self->cpan_userid;
4157         unless ($userid) {
4158             CPAN->debug("no userid? self[$self]");
4159             $userid = "anon";
4160         }
4161         my $pragmatic_dir = $userid . '000';
4162         $pragmatic_dir =~ s/\W_//g;
4163         $pragmatic_dir++ while -d "../$pragmatic_dir";
4164         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4165         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4166         File::Path::mkpath($packagedir);
4167         my($f);
4168         for $f (@readdir) { # is already without "." and ".."
4169             my $to = File::Spec->catdir($packagedir,$f);
4170             File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4171         }
4172     }
4173     if ($CPAN::Signal){
4174         $self->safe_chdir($sub_wd);
4175         return;
4176     }
4177
4178     $self->{'build_dir'} = $packagedir;
4179     $self->safe_chdir($builddir);
4180     File::Path::rmtree("tmp");
4181
4182     $self->safe_chdir($packagedir);
4183     if ($CPAN::META->has_inst("Module::Signature")) {
4184         if (-f "SIGNATURE") {
4185             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4186             my $rv = Module::Signature::verify();
4187             if ($rv != Module::Signature::SIGNATURE_OK() and
4188                 $rv != Module::Signature::SIGNATURE_MISSING()) {
4189                 $CPAN::Frontend->myprint(
4190                                          qq{\nSignature invalid for }.
4191                                          qq{distribution file. }.
4192                                          qq{Please investigate.\n\n}.
4193                                          $self->as_string,
4194                                          $CPAN::META->instance(
4195                                                                'CPAN::Author',
4196                                                                $self->cpan_userid,
4197                                                               )->as_string
4198                                         );
4199
4200                 my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
4201 is invalid. Maybe you have configured your 'urllist' with
4202 a bad URL. Please check this array with 'o conf urllist', and
4203 retry.};
4204                 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4205             }
4206         } else {
4207             $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
4208         }
4209     } else {
4210         $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4211     }
4212     $self->safe_chdir($builddir);
4213     return if $CPAN::Signal;
4214
4215
4216
4217     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4218     my($mpl_exists) = -f $mpl;
4219     unless ($mpl_exists) {
4220         # NFS has been reported to have racing problems after the
4221         # renaming of a directory in some environments.
4222         # This trick helps.
4223         sleep 1;
4224         my $mpldh = DirHandle->new($packagedir)
4225             or Carp::croak("Couldn't opendir $packagedir: $!");
4226         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4227         $mpldh->close;
4228     }
4229     unless ($mpl_exists) {
4230         $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4231                              $mpl,
4232                              CPAN::anycwd(),
4233                             )) if $CPAN::DEBUG;
4234         my($configure) = File::Spec->catfile($packagedir,"Configure");
4235         if (-f $configure) {
4236             # do we have anything to do?
4237             $self->{'configure'} = $configure;
4238         } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4239             $CPAN::Frontend->myprint(qq{
4240 Package comes with a Makefile and without a Makefile.PL.
4241 We\'ll try to build it with that Makefile then.
4242 });
4243             $self->{writemakefile} = "YES";
4244             sleep 2;
4245         } else {
4246             my $cf = $self->called_for || "unknown";
4247             if ($cf =~ m|/|) {
4248                 $cf =~ s|.*/||;
4249                 $cf =~ s|\W.*||;
4250             }
4251             $cf =~ s|[/\\:]||g; # risk of filesystem damage
4252             $cf = "unknown" unless length($cf);
4253             $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4254   (The test -f "$mpl" returned false.)
4255   Writing one on our own (setting NAME to $cf)\a\n});
4256             $self->{had_no_makefile_pl}++;
4257             sleep 3;
4258
4259             # Writing our own Makefile.PL
4260
4261             my $fh = FileHandle->new;
4262             $fh->open(">$mpl")
4263                 or Carp::croak("Could not open >$mpl: $!");
4264             $fh->print(
4265 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4266 # because there was no Makefile.PL supplied.
4267 # Autogenerated on: }.scalar localtime().qq{
4268
4269 use ExtUtils::MakeMaker;
4270 WriteMakefile(NAME => q[$cf]);
4271
4272 });
4273             $fh->close;
4274         }
4275     }
4276
4277     return $self;
4278 }
4279
4280 # CPAN::Distribution::untar_me ;
4281 sub untar_me {
4282     my($self,$local_file) = @_;
4283     $self->{archived} = "tar";
4284     if (CPAN::Tarzip->untar($local_file)) {
4285         $self->{unwrapped} = "YES";
4286     } else {
4287         $self->{unwrapped} = "NO";
4288     }
4289 }
4290
4291 # CPAN::Distribution::unzip_me ;
4292 sub unzip_me {
4293     my($self,$local_file) = @_;
4294     $self->{archived} = "zip";
4295     if (CPAN::Tarzip->unzip($local_file)) {
4296         $self->{unwrapped} = "YES";
4297     } else {
4298         $self->{unwrapped} = "NO";
4299     }
4300     return;
4301 }
4302
4303 sub pm2dir_me {
4304     my($self,$local_file) = @_;
4305     $self->{archived} = "pm";
4306     my $to = File::Basename::basename($local_file);
4307     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4308         if (CPAN::Tarzip->gunzip($local_file,$to)) {
4309             $self->{unwrapped} = "YES";
4310         } else {
4311             $self->{unwrapped} = "NO";
4312         }
4313     } else {
4314         File::Copy::cp($local_file,".");
4315         $self->{unwrapped} = "YES";
4316     }
4317 }
4318
4319 #-> sub CPAN::Distribution::new ;
4320 sub new {
4321     my($class,%att) = @_;
4322
4323     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4324
4325     my $this = { %att };
4326     return bless $this, $class;
4327 }
4328
4329 #-> sub CPAN::Distribution::look ;
4330 sub look {
4331     my($self) = @_;
4332
4333     if ($^O eq 'MacOS') {
4334       $self->Mac::BuildTools::look;
4335       return;
4336     }
4337
4338     if (  $CPAN::Config->{'shell'} ) {
4339         $CPAN::Frontend->myprint(qq{
4340 Trying to open a subshell in the build directory...
4341 });
4342     } else {
4343         $CPAN::Frontend->myprint(qq{
4344 Your configuration does not define a value for subshells.
4345 Please define it with "o conf shell <your shell>"
4346 });
4347         return;
4348     }
4349     my $dist = $self->id;
4350     my $dir;
4351     unless ($dir = $self->dir) {
4352         $self->get;
4353     }
4354     unless ($dir ||= $self->dir) {
4355         $CPAN::Frontend->mywarn(qq{
4356 Could not determine which directory to use for looking at $dist.
4357 });
4358         return;
4359     }
4360     my $pwd  = CPAN::anycwd();
4361     $self->safe_chdir($dir);
4362     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4363     unless (system($CPAN::Config->{'shell'}) == 0) {
4364         my $code = $? >> 8;
4365         $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4366     }
4367     $self->safe_chdir($pwd);
4368 }
4369
4370 # CPAN::Distribution::cvs_import ;
4371 sub cvs_import {
4372     my($self) = @_;
4373     $self->get;
4374     my $dir = $self->dir;
4375
4376     my $package = $self->called_for;
4377     my $module = $CPAN::META->instance('CPAN::Module', $package);
4378     my $version = $module->cpan_version;
4379
4380     my $userid = $self->cpan_userid;
4381
4382     my $cvs_dir = (split /\//, $dir)[-1];
4383     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4384     my $cvs_root =
4385       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4386     my $cvs_site_perl =
4387       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4388     if ($cvs_site_perl) {
4389         $cvs_dir = "$cvs_site_perl/$cvs_dir";
4390     }
4391     my $cvs_log = qq{"imported $package $version sources"};
4392     $version =~ s/\./_/g;
4393     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4394                "$cvs_dir", $userid, "v$version");
4395
4396     my $pwd  = CPAN::anycwd();
4397     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4398
4399     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4400
4401     $CPAN::Frontend->myprint(qq{@cmd\n});
4402     system(@cmd) == 0 or
4403         $CPAN::Frontend->mydie("cvs import failed");
4404     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4405 }
4406
4407 #-> sub CPAN::Distribution::readme ;
4408 sub readme {
4409     my($self) = @_;
4410     my($dist) = $self->id;
4411     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4412     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4413     my($local_file);
4414     my($local_wanted) =
4415          File::Spec->catfile(
4416                              $CPAN::Config->{keep_source_where},
4417                              "authors",
4418                              "id",
4419                              split(/\//,"$sans.readme"),
4420                             );
4421     $self->debug("Doing localize") if $CPAN::DEBUG;
4422     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4423                                       $local_wanted)
4424         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4425
4426     if ($^O eq 'MacOS') {
4427         Mac::BuildTools::launch_file($local_file);
4428         return;
4429     }
4430
4431     my $fh_pager = FileHandle->new;
4432     local($SIG{PIPE}) = "IGNORE";
4433     $fh_pager->open("|$CPAN::Config->{'pager'}")
4434         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4435     my $fh_readme = FileHandle->new;
4436     $fh_readme->open($local_file)
4437         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4438     $CPAN::Frontend->myprint(qq{
4439 Displaying file
4440   $local_file
4441 with pager "$CPAN::Config->{'pager'}"
4442 });
4443     sleep 2;
4444     $fh_pager->print(<$fh_readme>);
4445     $fh_pager->close;
4446 }
4447
4448 #-> sub CPAN::Distribution::verifyMD5 ;
4449 sub verifyMD5 {
4450     my($self) = @_;
4451   EXCUSE: {
4452         my @e;
4453         $self->{MD5_STATUS} ||= "";
4454         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4455         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4456     }
4457     my($lc_want,$lc_file,@local,$basename);
4458     @local = split(/\//,$self->id);
4459     pop @local;
4460     push @local, "CHECKSUMS";
4461     $lc_want =
4462         File::Spec->catfile($CPAN::Config->{keep_source_where},
4463                             "authors", "id", @local);
4464     local($") = "/";
4465     if (
4466         -s $lc_want
4467         &&
4468         $self->MD5_check_file($lc_want)
4469        ) {
4470         return $self->{MD5_STATUS} = "OK";
4471     }
4472     $lc_file = CPAN::FTP->localize("authors/id/@local",
4473                                    $lc_want,1);
4474     unless ($lc_file) {
4475         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4476         $local[-1] .= ".gz";
4477         $lc_file = CPAN::FTP->localize("authors/id/@local",
4478                                        "$lc_want.gz",1);
4479         if ($lc_file) {
4480             $lc_file =~ s/\.gz(?!\n)\Z//;
4481             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4482         } else {
4483             return;
4484         }
4485     }
4486     $self->MD5_check_file($lc_file);
4487 }
4488
4489 sub SIG_check_file {
4490     my($self,$chk_file) = @_;
4491     my $rv = eval { Module::Signature::_verify($chk_file) };
4492
4493     if ($rv == Module::Signature::SIGNATURE_OK()) {
4494         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
4495         return $self->{SIG_STATUS} = "OK";
4496     } else {
4497         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
4498                                  qq{distribution file. }.
4499                                  qq{Please investigate.\n\n}.
4500                                  $self->as_string,
4501                                 $CPAN::META->instance(
4502                                                         'CPAN::Author',
4503                                                         $self->cpan_userid
4504                                                         )->as_string);
4505
4506         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
4507 is invalid. Maybe you have configured your 'urllist' with
4508 a bad URL. Please check this array with 'o conf urllist', and
4509 retry.};
4510
4511         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4512     }
4513 }
4514
4515 #-> sub CPAN::Distribution::MD5_check_file ;
4516 sub MD5_check_file {
4517     my($self,$chk_file) = @_;
4518     my($cksum,$file,$basename);
4519
4520     if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
4521         $self->debug("Module::Signature is installed, verifying");
4522         $self->SIG_check_file($chk_file);
4523     } else {
4524         $self->debug("Module::Signature is NOT installed");
4525     }
4526
4527     $file = $self->{localfile};
4528     $basename = File::Basename::basename($file);
4529     my $fh = FileHandle->new;
4530     if (open $fh, $chk_file){
4531         local($/);
4532         my $eval = <$fh>;
4533         $eval =~ s/\015?\012/\n/g;
4534         close $fh;
4535         my($comp) = Safe->new();
4536         $cksum = $comp->reval($eval);
4537         if ($@) {
4538             rename $chk_file, "$chk_file.bad";
4539             Carp::confess($@) if $@;
4540         }
4541     } else {
4542         Carp::carp "Could not open $chk_file for reading";
4543     }
4544
4545     if (exists $cksum->{$basename}{md5}) {
4546         $self->debug("Found checksum for $basename:" .
4547                      "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4548
4549         open($fh, $file);
4550         binmode $fh;
4551         my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4552         $fh->close;
4553         $fh = CPAN::Tarzip->TIEHANDLE($file);
4554
4555         unless ($eq) {
4556           # had to inline it, when I tied it, the tiedness got lost on
4557           # the call to eq_MD5. (Jan 1998)
4558           my $md5 = Digest::MD5->new;
4559           my($data,$ref);
4560           $ref = \$data;
4561           while ($fh->READ($ref, 4096) > 0){
4562             $md5->add($data);
4563           }
4564           my $hexdigest = $md5->hexdigest;
4565           $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4566         }
4567
4568         if ($eq) {
4569           $CPAN::Frontend->myprint("Checksum for $file ok\n");
4570           return $self->{MD5_STATUS} = "OK";
4571         } else {
4572             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4573                                      qq{distribution file. }.
4574                                      qq{Please investigate.\n\n}.
4575                                      $self->as_string,
4576                                      $CPAN::META->instance(
4577                                                            'CPAN::Author',
4578                                                            $self->cpan_userid
4579                                                           )->as_string);
4580
4581             my $wrap = qq{I\'d recommend removing $file. Its MD5
4582 checksum is incorrect. Maybe you have configured your 'urllist' with
4583 a bad URL. Please check this array with 'o conf urllist', and
4584 retry.};
4585
4586             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4587
4588             # former versions just returned here but this seems a
4589             # serious threat that deserves a die
4590
4591             # $CPAN::Frontend->myprint("\n\n");
4592             # sleep 3;
4593             # return;
4594         }
4595         # close $fh if fileno($fh);
4596     } else {
4597         $self->{MD5_STATUS} ||= "";
4598         if ($self->{MD5_STATUS} eq "NIL") {
4599             $CPAN::Frontend->mywarn(qq{
4600 Warning: No md5 checksum for $basename in $chk_file.
4601
4602 The cause for this may be that the file is very new and the checksum
4603 has not yet been calculated, but it may also be that something is
4604 going awry right now.
4605 });
4606             my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4607             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4608         }
4609         $self->{MD5_STATUS} = "NIL";
4610         return;
4611     }
4612 }
4613
4614 #-> sub CPAN::Distribution::eq_MD5 ;
4615 sub eq_MD5 {
4616     my($self,$fh,$expectMD5) = @_;
4617     my $md5 = Digest::MD5->new;
4618     my($data);
4619     while (read($fh, $data, 4096)){
4620       $md5->add($data);
4621     }
4622     # $md5->addfile($fh);
4623     my $hexdigest = $md5->hexdigest;
4624     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4625     $hexdigest eq $expectMD5;
4626 }
4627
4628 #-> sub CPAN::Distribution::force ;
4629
4630 # Both modules and distributions know if "force" is in effect by
4631 # autoinspection, not by inspecting a global variable. One of the
4632 # reason why this was chosen to work that way was the treatment of
4633 # dependencies. They should not autpomatically inherit the force
4634 # status. But this has the downside that ^C and die() will return to
4635 # the prompt but will not be able to reset the force_update
4636 # attributes. We try to correct for it currently in the read_metadata
4637 # routine, and immediately before we check for a Signal. I hope this
4638 # works out in one of v1.57_53ff
4639
4640 sub force {
4641   my($self, $method) = @_;
4642   for my $att (qw(
4643   MD5_STATUS archived build_dir localfile make install unwrapped
4644   writemakefile
4645  )) {
4646     delete $self->{$att};
4647   }
4648   if ($method && $method eq "install") {
4649     $self->{"force_update"}++; # name should probably have been force_install
4650   }
4651 }
4652
4653 sub notest {
4654   my($self, $method) = [at]_;
4655   # warn "XDEBUG: set notest for $self $method";
4656   $self->{"notest"}++; # name should probably have been force_install
4657 }
4658
4659 sub unnotest {
4660   my($self) = [at]_;
4661   # warn "XDEBUG: deleting notest";
4662   delete $self->{'notest'};
4663 }
4664
4665 #-> sub CPAN::Distribution::unforce ;
4666 sub unforce {
4667   my($self) = @_;
4668   delete $self->{'force_update'};
4669 }
4670
4671 #-> sub CPAN::Distribution::isa_perl ;
4672 sub isa_perl {
4673   my($self) = @_;
4674   my $file = File::Basename::basename($self->id);
4675   if ($file =~ m{ ^ perl
4676                   -?
4677                   (5)
4678                   ([._-])
4679                   (
4680                    \d{3}(_[0-4][0-9])?
4681                    |
4682                    \d*[24680]\.\d+
4683                   )
4684                   \.tar[._-]gz
4685                   (?!\n)\Z
4686                 }xs){
4687     return "$1.$3";
4688   } elsif ($self->cpan_comment
4689            &&
4690            $self->cpan_comment =~ /isa_perl\(.+?\)/){
4691     return $1;
4692   }
4693 }
4694
4695
4696 #-> sub CPAN::Distribution::perl ;
4697 sub perl {
4698     return $CPAN::Perl;
4699 }
4700
4701
4702 #-> sub CPAN::Distribution::make ;
4703 sub make {
4704     my($self) = @_;
4705     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4706     # Emergency brake if they said install Pippi and get newest perl
4707     if ($self->isa_perl) {
4708       if (
4709           $self->called_for ne $self->id &&
4710           ! $self->{force_update}
4711          ) {
4712         # if we die here, we break bundles
4713         $CPAN::Frontend->mywarn(sprintf qq{
4714 The most recent version "%s" of the module "%s"
4715 comes with the current version of perl (%s).
4716 I\'ll build that only if you ask for something like
4717     force install %s
4718 or
4719     install %s
4720 },
4721                                $CPAN::META->instance(
4722                                                      'CPAN::Module',
4723                                                      $self->called_for
4724                                                     )->cpan_version,
4725                                $self->called_for,
4726                                $self->isa_perl,
4727                                $self->called_for,
4728                                $self->id);
4729         sleep 5; return;
4730       }
4731     }
4732     $self->get;
4733   EXCUSE: {
4734         my @e;
4735         $self->{archived} eq "NO" and push @e,
4736         "Is neither a tar nor a zip archive.";
4737
4738         $self->{unwrapped} eq "NO" and push @e,
4739         "had problems unarchiving. Please build manually";
4740
4741         exists $self->{writemakefile} &&
4742             $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4743                 $1 || "Had some problem writing Makefile";
4744
4745         defined $self->{'make'} and push @e,
4746             "Has already been processed within this session";
4747
4748         exists $self->{later} and length($self->{later}) and
4749             push @e, $self->{later};
4750
4751         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4752     }
4753     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
4754     my $builddir = $self->dir;
4755     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4756     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4757
4758     if ($^O eq 'MacOS') {
4759         Mac::BuildTools::make($self);
4760         return;
4761     }
4762
4763     my $system;
4764     if ($self->{'configure'}) {
4765       $system = $self->{'configure'};
4766     } else {
4767         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4768         my $switch = "";
4769 # This needs a handler that can be turned on or off:
4770 #       $switch = "-MExtUtils::MakeMaker ".
4771 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4772 #           if $] > 5.00310;
4773         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4774     }
4775     unless (exists $self->{writemakefile}) {
4776         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4777         my($ret,$pid);
4778         $@ = "";
4779         if ($CPAN::Config->{inactivity_timeout}) {
4780             eval {
4781                 alarm $CPAN::Config->{inactivity_timeout};
4782                 local $SIG{CHLD}; # = sub { wait };
4783                 if (defined($pid = fork)) {
4784                     if ($pid) { #parent
4785                         # wait;
4786                         waitpid $pid, 0;
4787                     } else {    #child
4788                       # note, this exec isn't necessary if
4789                       # inactivity_timeout is 0. On the Mac I'd
4790                       # suggest, we set it always to 0.
4791                       exec $system;
4792                     }
4793                 } else {
4794                     $CPAN::Frontend->myprint("Cannot fork: $!");
4795                     return;
4796                 }
4797             };
4798             alarm 0;
4799             if ($@){
4800                 kill 9, $pid;
4801                 waitpid $pid, 0;
4802                 $CPAN::Frontend->myprint($@);
4803                 $self->{writemakefile} = "NO $@";
4804                 $@ = "";
4805                 return;
4806             }
4807         } else {
4808           $ret = system($system);
4809           if ($ret != 0) {
4810             $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4811             return;
4812           }
4813         }
4814         if (-f "Makefile") {
4815           $self->{writemakefile} = "YES";
4816           delete $self->{make_clean}; # if cleaned before, enable next
4817         } else {
4818           $self->{writemakefile} =
4819               qq{NO Makefile.PL refused to write a Makefile.};
4820           # It's probably worth it to record the reason, so let's retry
4821           # local $/;
4822           # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4823           # $self->{writemakefile} .= <$fh>;
4824         }
4825     }
4826     if ($CPAN::Signal){
4827       delete $self->{force_update};
4828       return;
4829     }
4830     if (my @prereq = $self->unsat_prereq){
4831       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4832     }
4833     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4834     if (system($system) == 0) {
4835          $CPAN::Frontend->myprint("  $system -- OK\n");
4836          $self->{'make'} = "YES";
4837     } else {
4838          $self->{writemakefile} ||= "YES";
4839          $self->{'make'} = "NO";
4840          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4841     }
4842 }
4843
4844 sub follow_prereqs {
4845     my($self) = shift;
4846     my(@prereq) = @_;
4847     my $id = $self->id;
4848     $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4849                              "during [$id] -----\n");
4850
4851     for my $p (@prereq) {
4852         $CPAN::Frontend->myprint("    $p\n");
4853     }
4854     my $follow = 0;
4855     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4856         $follow = 1;
4857     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4858         require ExtUtils::MakeMaker;
4859         my $answer = ExtUtils::MakeMaker::prompt(
4860 "Shall I follow them and prepend them to the queue
4861 of modules we are processing right now?", "yes");
4862         $follow = $answer =~ /^\s*y/i;
4863     } else {
4864         local($") = ", ";
4865         $CPAN::Frontend->
4866             myprint("  Ignoring dependencies on modules @prereq\n");
4867     }
4868     if ($follow) {
4869         # color them as dirty
4870         for my $p (@prereq) {
4871             # warn "calling color_cmd_tmps(0,1)";
4872             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4873         }
4874         CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4875         $self->{later} = "Delayed until after prerequisites";
4876         return 1; # signal success to the queuerunner
4877     }
4878 }
4879
4880 #-> sub CPAN::Distribution::unsat_prereq ;
4881 sub unsat_prereq {
4882     my($self) = @_;
4883     my $prereq_pm = $self->prereq_pm or return;
4884     my(@need);
4885   NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4886         my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4887         # we were too demanding:
4888         next if $nmo->uptodate;
4889
4890         # if they have not specified a version, we accept any installed one
4891         if (not defined $need_version or
4892            $need_version == 0 or
4893            $need_version eq "undef") {
4894             next if defined $nmo->inst_file;
4895         }
4896
4897         # We only want to install prereqs if either they're not installed
4898         # or if the installed version is too old. We cannot omit this
4899         # check, because if 'force' is in effect, nobody else will check.
4900         {
4901             local($^W) = 0;
4902             if (
4903                 defined $nmo->inst_file &&
4904                 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4905                ){
4906                 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4907                             $nmo->id,
4908                             $nmo->inst_file,
4909                             $nmo->inst_version,
4910                             CPAN::Version->readable($need_version)
4911                            );
4912                 next NEED;
4913             }
4914         }
4915
4916         if ($self->{sponsored_mods}{$need_module}++){
4917             # We have already sponsored it and for some reason it's still
4918             # not available. So we do nothing. Or what should we do?
4919             # if we push it again, we have a potential infinite loop
4920             next;
4921         }
4922         push @need, $need_module;
4923     }
4924     @need;
4925 }
4926
4927 #-> sub CPAN::Distribution::prereq_pm ;
4928 sub prereq_pm {
4929   my($self) = @_;
4930   return $self->{prereq_pm} if
4931       exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4932   return unless $self->{writemakefile}; # no need to have succeeded
4933                                         # but we must have run it
4934   my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4935   my $makefile = File::Spec->catfile($build_dir,"Makefile");
4936   my(%p) = ();
4937   my $fh;
4938   if (-f $makefile
4939       and
4940       $fh = FileHandle->new("<$makefile\0")) {
4941
4942       local($/) = "\n";
4943
4944       #  A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4945       while (<$fh>) {
4946           last if /MakeMaker post_initialize section/;
4947           my($p) = m{^[\#]
4948                  \s+PREREQ_PM\s+=>\s+(.+)
4949                  }x;
4950           next unless $p;
4951           # warn "Found prereq expr[$p]";
4952
4953           #  Regexp modified by A.Speer to remember actual version of file
4954           #  PREREQ_PM hash key wants, then add to
4955           while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4956               # In case a prereq is mentioned twice, complain.
4957               if ( defined $p{$1} ) {
4958                   warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4959               }
4960               $p{$1} = $2;
4961           }
4962           last;
4963       }
4964   }
4965   $self->{prereq_pm_detected}++;
4966   return $self->{prereq_pm} = \%p;
4967 }
4968
4969 #-> sub CPAN::Distribution::test ;
4970 sub test {
4971     my($self) = @_;
4972     $self->make;
4973     if ($CPAN::Signal){
4974       delete $self->{force_update};
4975       return;
4976     }
4977     # warn "XDEBUG: checking for notest: $self->{notest} $self";
4978     if ($self->{notest}) {
4979         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
4980         return 1;
4981     }
4982
4983     $CPAN::Frontend->myprint("Running make test\n");
4984     if (my @prereq = $self->unsat_prereq){
4985       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4986     }
4987   EXCUSE: {
4988         my @e;
4989         exists $self->{make} or exists $self->{later} or push @e,
4990         "Make had some problems, maybe interrupted? Won't test";
4991
4992         exists $self->{'make'} and
4993             $self->{'make'} eq 'NO' and
4994                 push @e, "Can't test without successful make";
4995
4996         exists $self->{build_dir} or push @e, "Has no own directory";
4997         $self->{badtestcnt} ||= 0;
4998         $self->{badtestcnt} > 0 and
4999             push @e, "Won't repeat unsuccessful test during this command";
5000
5001         exists $self->{later} and length($self->{later}) and
5002             push @e, $self->{later};
5003
5004         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5005     }
5006     chdir $self->{'build_dir'} or
5007         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5008     $self->debug("Changed directory to $self->{'build_dir'}")
5009         if $CPAN::DEBUG;
5010
5011     if ($^O eq 'MacOS') {
5012         Mac::BuildTools::make_test($self);
5013         return;
5014     }
5015
5016     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5017                            ? $ENV{PERL5LIB}
5018                            : ($ENV{PERLLIB} || "");
5019
5020     $CPAN::META->set_perl5lib;
5021     my $system = join " ", $CPAN::Config->{'make'}, "test";
5022     if (system($system) == 0) {
5023          $CPAN::Frontend->myprint("  $system -- OK\n");
5024          $CPAN::META->is_tested($self->{'build_dir'});
5025          $self->{make_test} = "YES";
5026     } else {
5027          $self->{make_test} = "NO";
5028          $self->{badtestcnt}++;
5029          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
5030     }
5031 }
5032
5033 #-> sub CPAN::Distribution::clean ;
5034 sub clean {
5035     my($self) = @_;
5036     $CPAN::Frontend->myprint("Running make clean\n");
5037   EXCUSE: {
5038         my @e;
5039         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
5040             push @e, "make clean already called once";
5041         exists $self->{build_dir} or push @e, "Has no own directory";
5042         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5043     }
5044     chdir $self->{'build_dir'} or
5045         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5046     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
5047
5048     if ($^O eq 'MacOS') {
5049         Mac::BuildTools::make_clean($self);
5050         return;
5051     }
5052
5053     my $system = join " ", $CPAN::Config->{'make'}, "clean";
5054     if (system($system) == 0) {
5055       $CPAN::Frontend->myprint("  $system -- OK\n");
5056
5057       # $self->force;
5058
5059       # Jost Krieger pointed out that this "force" was wrong because
5060       # it has the effect that the next "install" on this distribution
5061       # will untar everything again. Instead we should bring the
5062       # object's state back to where it is after untarring.
5063
5064       delete $self->{force_update};
5065       delete $self->{install};
5066       delete $self->{writemakefile};
5067       delete $self->{make};
5068       delete $self->{make_test}; # no matter if yes or no, tests must be redone
5069       $self->{make_clean} = "YES";
5070
5071     } else {
5072       # Hmmm, what to do if make clean failed?
5073
5074       $CPAN::Frontend->myprint(qq{  $system -- NOT OK
5075
5076 make clean did not succeed, marking directory as unusable for further work.
5077 });
5078       $self->force("make"); # so that this directory won't be used again
5079
5080     }
5081 }
5082
5083 #-> sub CPAN::Distribution::install ;
5084 sub install {
5085     my($self) = @_;
5086     $self->test;
5087     if ($CPAN::Signal){
5088       delete $self->{force_update};
5089       return;
5090     }
5091     $CPAN::Frontend->myprint("Running make install\n");
5092   EXCUSE: {
5093         my @e;
5094         exists $self->{build_dir} or push @e, "Has no own directory";
5095
5096         exists $self->{make} or exists $self->{later} or push @e,
5097         "Make had some problems, maybe interrupted? Won't install";
5098
5099         exists $self->{'make'} and
5100             $self->{'make'} eq 'NO' and
5101                 push @e, "make had returned bad status, install seems impossible";
5102
5103         push @e, "make test had returned bad status, ".
5104             "won't install without force"
5105             if exists $self->{'make_test'} and
5106             $self->{'make_test'} eq 'NO' and
5107             ! $self->{'force_update'};
5108
5109         exists $self->{'install'} and push @e,
5110         $self->{'install'} eq "YES" ?
5111             "Already done" : "Already tried without success";
5112
5113         exists $self->{later} and length($self->{later}) and
5114             push @e, $self->{later};
5115
5116         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5117     }
5118     chdir $self->{'build_dir'} or
5119         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5120     $self->debug("Changed directory to $self->{'build_dir'}")
5121         if $CPAN::DEBUG;
5122
5123     if ($^O eq 'MacOS') {
5124         Mac::BuildTools::make_install($self);
5125         return;
5126     }
5127
5128     my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
5129         $CPAN::Config->{'make'};
5130
5131     my($system) = join(" ",
5132                        $make_install_make_command,
5133                        "install",
5134                        $CPAN::Config->{make_install_arg},
5135                       );
5136     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
5137     my($pipe) = FileHandle->new("$system $stderr |");
5138     my($makeout) = "";
5139     while (<$pipe>){
5140         $CPAN::Frontend->myprint($_);
5141         $makeout .= $_;
5142     }
5143     $pipe->close;
5144     if ($?==0) {
5145          $CPAN::Frontend->myprint("  $system -- OK\n");
5146          $CPAN::META->is_installed($self->{'build_dir'});
5147          return $self->{'install'} = "YES";
5148     } else {
5149          $self->{'install'} = "NO";
5150          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
5151          if (
5152              $makeout =~ /permission/s
5153              && $> > 0
5154              && (
5155                  ! $CPAN::Config->{make_install_make_command}
5156                  || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
5157                 )
5158             ) {
5159              $CPAN::Frontend->myprint(
5160                                       qq{----\n}.
5161                                       qq{  You may have to su }.
5162                                       qq{to root to install the package\n}.
5163                                       qq{  (Or you may want to run something like\n}.
5164                                       qq{    o conf make_install_make_command 'sudo make'\n}.
5165                                       qq{  to raise your permissions.}
5166                                      );
5167          }
5168     }
5169     delete $self->{force_update};
5170 }
5171
5172 #-> sub CPAN::Distribution::dir ;
5173 sub dir {
5174     shift->{'build_dir'};
5175 }
5176
5177 #-> sub CPAN::Distribution::perldoc ;
5178 sub perldoc {
5179     my($self) = [at]_;
5180
5181     my($dist) = $self->id;
5182     my $package = $self->called_for;
5183
5184     $self->_display_url( $CPAN::Defaultdocs . $package );
5185 }
5186
5187 #-> sub CPAN::Distribution::_check_binary ;
5188 sub _check_binary {
5189     my ($dist,$shell,$binary) = [at]_;
5190     my ($pid,$readme,$out);
5191
5192     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
5193       if $CPAN::DEBUG;
5194
5195     $pid = open $readme, "-|", "which", $binary
5196       or $CPAN::Frontend->mydie(qq{Could not fork $binary: $!});
5197     while (<$readme>) {
5198         $out .= $_;
5199     }
5200     close $readme;
5201
5202     $CPAN::Frontend->myprint(qq{   + $out \n})
5203       if $CPAN::DEBUG && $out;
5204
5205     return $out;
5206 }
5207
5208 #-> sub CPAN::Distribution::_display_url ;
5209 sub _display_url {
5210     my($self,$url) = [at]_;
5211     my($res,$saved_file,$pid,$readme,$out);
5212
5213     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
5214       if $CPAN::DEBUG;
5215
5216     # should we define it in the config instead?
5217     my $html_converter = "html2text";
5218
5219     my $web_browser = $CPAN::Config->{'lynx'} || undef;
5220     my $web_browser_out = $web_browser
5221       ? CPAN::Distribution->_check_binary($self,$web_browser)
5222         : undef;
5223
5224     my ($tmpout,$tmperr);
5225     if (not $web_browser_out) {
5226         # web browser not found, let's try text only
5227         my $html_converter_out =
5228           CPAN::Distribution->_check_binary($self,$html_converter);
5229
5230         if ($html_converter_out ) {
5231             # html2text found, run it
5232             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
5233             $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
5234               unless defined($saved_file);
5235
5236             $pid = open $readme, "-|", $html_converter, $saved_file
5237               or $CPAN::Frontend->mydie(qq{
5238 Could not fork $html_converter $saved_file: $!});
5239             my $fh = File::Temp->new(
5240                                      template => 'cpan_htmlconvert_XXXX',
5241                                      suffix => '.txt',
5242                                      unlink => 0,
5243                                     );
5244             while (<$readme>) {
5245                 $fh->print($_);
5246             }
5247             close $readme
5248               or $CPAN::Frontend->mydie(qq{Could not close file handle: $!});
5249             my $tmpin = $fh->filename;
5250             $CPAN::Frontend->myprint(sprintf(qq{
5251 Run '%s %s' and
5252 saved output to %s\n},
5253                                              $html_converter,
5254                                              $saved_file,
5255                                              $tmpin,
5256                                             )) if $CPAN::DEBUG;
5257             close $fh; undef $fh;
5258             open $fh, $tmpin
5259               or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
5260             my $fh_pager = FileHandle->new;
5261             local($SIG{PIPE}) = "IGNORE";
5262             $fh_pager->open("|$CPAN::Config->{'pager'}")
5263               or $CPAN::Frontend->mydie(qq{
5264 Could not open pager $CPAN::Config->{'pager'}: $!});
5265             $CPAN::Frontend->myprint(qq{
5266 Displaying URL
5267   $url
5268 with pager "$CPAN::Config->{'pager'}"
5269 });
5270             sleep 2;
5271             $fh_pager->print(<$fh>);
5272             $fh_pager->close;
5273         } else {
5274             # coldn't find the web browser or html converter
5275             $CPAN::Frontend->myprint(qq{
5276 You need to install lynx or $html_converter to use this feature.});
5277         }
5278     } else {
5279         # web browser found, run the action
5280         my $browser = $CPAN::Config->{'lynx'};
5281         $CPAN::Frontend->myprint(qq{system[$browser $url]})
5282           if $CPAN::DEBUG;
5283         $CPAN::Frontend->myprint(qq{
5284 Displaying URL
5285   $url
5286 with browser $browser
5287 });
5288         sleep 2;
5289         system("$browser $url");
5290         if ($saved_file) { 1 while unlink($saved_file) }
5291     }
5292 }
5293
5294 #-> sub CPAN::Distribution::_getsave_url ;
5295 sub _getsave_url {
5296     my($dist, $shell, $url) = [at]_;
5297
5298     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
5299       if $CPAN::DEBUG;
5300
5301     my $fh  = File::Temp->new(
5302                               template => "cpan_getsave_url_XXXX",
5303                               suffix => ".html",
5304                               unlink => 0,
5305                              );
5306     my $tmpin = $fh->filename;
5307     if ($CPAN::META->has_usable('LWP')) {
5308         $CPAN::Frontend->myprint("Fetching with LWP:
5309   $url
5310 ");
5311         my $Ua;
5312         CPAN::LWP::UserAgent->config;
5313         eval { $Ua = CPAN::LWP::UserAgent->new; };
5314         if ($@) {
5315             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
5316             return;
5317         } else {
5318             my($var);
5319             $Ua->proxy('http', $var)
5320                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
5321             $Ua->no_proxy($var)
5322                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
5323         }
5324
5325         my $req = HTTP::Request->new(GET => $url);
5326         $req->header('Accept' => 'text/html');
5327         my $res = $Ua->request($req);
5328         if ($res->is_success) {
5329             $CPAN::Frontend->myprint(" + request successful.\n")
5330                 if $CPAN::DEBUG;
5331             print $fh $res->content;
5332             close $fh;
5333             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
5334                 if $CPAN::DEBUG;
5335             return $tmpin;
5336         } else {
5337             $CPAN::Frontend->myprint(sprintf(
5338                                              "LWP failed with code[%s], message[%s]\n",
5339                                              $res->code,
5340                                              $res->message,
5341                                             ));
5342             return;
5343         }
5344     } else {
5345         $CPAN::Frontend->myprint("LWP not available\n");
5346         return;
5347     }
5348 }
5349
5350 package CPAN::Bundle;
5351
5352 sub look {
5353     my $self = shift;
5354     $CPAN::Frontend->myprint($self->as_string);
5355 }
5356
5357 sub undelay {
5358     my $self = shift;
5359     delete $self->{later};
5360     for my $c ( $self->contains ) {
5361         my $obj = CPAN::Shell->expandany($c) or next;
5362         $obj->undelay;
5363     }
5364 }
5365
5366 #-> sub CPAN::Bundle::color_cmd_tmps ;
5367 sub color_cmd_tmps {
5368     my($self) = shift;
5369     my($depth) = shift || 0;
5370     my($color) = shift || 0;
5371     my($ancestors) = shift || [];
5372     # a module needs to recurse to its cpan_file, a distribution needs
5373     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
5374
5375     return if exists $self->{incommandcolor}
5376         && $self->{incommandcolor}==$color;
5377     if ($depth>=100){
5378         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5379     }
5380     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5381
5382     for my $c ( $self->contains ) {
5383         my $obj = CPAN::Shell->expandany($c) or next;
5384         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
5385         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5386     }
5387     if ($color==0) {
5388         delete $self->{badtestcnt};
5389     }
5390     $self->{incommandcolor} = $color;
5391 }
5392
5393 #-> sub CPAN::Bundle::as_string ;
5394 sub as_string {
5395     my($self) = @_;
5396     $self->contains;
5397     # following line must be "=", not "||=" because we have a moving target
5398     $self->{INST_VERSION} = $self->inst_version;
5399     return $self->SUPER::as_string;
5400 }
5401
5402 #-> sub CPAN::Bundle::contains ;
5403 sub contains {
5404     my($self) = @_;
5405     my($inst_file) = $self->inst_file || "";
5406     my($id) = $self->id;
5407     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
5408     unless ($inst_file) {
5409         # Try to get at it in the cpan directory
5410         $self->debug("no inst_file") if $CPAN::DEBUG;
5411         my $cpan_file;
5412         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
5413               $cpan_file = $self->cpan_file;
5414         if ($cpan_file eq "N/A") {
5415             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
5416   Maybe stale symlink? Maybe removed during session? Giving up.\n");
5417         }
5418         my $dist = $CPAN::META->instance('CPAN::Distribution',
5419                                          $self->cpan_file);
5420         $dist->get;
5421         $self->debug($dist->as_string) if $CPAN::DEBUG;
5422         my($todir) = $CPAN::Config->{'cpan_home'};
5423         my(@me,$from,$to,$me);
5424         @me = split /::/, $self->id;
5425         $me[-1] .= ".pm";
5426         $me = File::Spec->catfile(@me);
5427         $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5428         $to = File::Spec->catfile($todir,$me);
5429         File::Path::mkpath(File::Basename::dirname($to));
5430         File::Copy::copy($from, $to)
5431               or Carp::confess("Couldn't copy $from to $to: $!");
5432         $inst_file = $to;
5433     }
5434     my @result;
5435     my $fh = FileHandle->new;
5436     local $/ = "\n";
5437     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
5438     my $in_cont = 0;
5439     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
5440     while (<$fh>) {
5441         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
5442             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
5443         next unless $in_cont;
5444         next if /^=/;
5445         s/\#.*//;
5446         next if /^\s+$/;
5447         chomp;
5448         push @result, (split " ", $_, 2)[0];
5449     }
5450     close $fh;
5451     delete $self->{STATUS};
5452     $self->{CONTAINS} = \@result;
5453     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5454     unless (@result) {
5455         $CPAN::Frontend->mywarn(qq{
5456 The bundle file "$inst_file" may be a broken
5457 bundlefile. It seems not to contain any bundle definition.
5458 Please check the file and if it is bogus, please delete it.
5459 Sorry for the inconvenience.
5460 });
5461     }
5462     @result;
5463 }
5464
5465 #-> sub CPAN::Bundle::find_bundle_file
5466 sub find_bundle_file {
5467     my($self,$where,$what) = @_;
5468     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5469 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5470 ###    my $bu = File::Spec->catfile($where,$what);
5471 ###    return $bu if -f $bu;
5472     my $manifest = File::Spec->catfile($where,"MANIFEST");
5473     unless (-f $manifest) {
5474         require ExtUtils::Manifest;
5475         my $cwd = CPAN::anycwd();
5476         chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5477         ExtUtils::Manifest::mkmanifest();
5478         chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5479     }
5480     my $fh = FileHandle->new($manifest)
5481         or Carp::croak("Couldn't open $manifest: $!");
5482     local($/) = "\n";
5483     my $what2 = $what;
5484     if ($^O eq 'MacOS') {
5485       $what =~ s/^://;
5486       $what =~ tr|:|/|;
5487       $what2 =~ s/:Bundle://;
5488       $what2 =~ tr|:|/|;
5489     } else {
5490         $what2 =~ s|Bundle[/\\]||;
5491     }
5492     my $bu;
5493     while (<$fh>) {
5494         next if /^\s*\#/;
5495         my($file) = /(\S+)/;
5496         if ($file =~ m|\Q$what\E$|) {
5497             $bu = $file;
5498             # return File::Spec->catfile($where,$bu); # bad
5499             last;
5500         }
5501         # retry if she managed to
5502         # have no Bundle directory
5503         $bu = $file if $file =~ m|\Q$what2\E$|;
5504     }
5505     $bu =~ tr|/|:| if $^O eq 'MacOS';
5506     return File::Spec->catfile($where, $bu) if $bu;
5507     Carp::croak("Couldn't find a Bundle file in $where");
5508 }
5509
5510 # needs to work quite differently from Module::inst_file because of
5511 # cpan_home/Bundle/ directory and the possibility that we have
5512 # shadowing effect. As it makes no sense to take the first in @INC for
5513 # Bundles, we parse them all for $VERSION and take the newest.
5514
5515 #-> sub CPAN::Bundle::inst_file ;
5516 sub inst_file {
5517     my($self) = @_;
5518     my($inst_file);
5519     my(@me);
5520     @me = split /::/, $self->id;
5521     $me[-1] .= ".pm";
5522     my($incdir,$bestv);
5523     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5524         my $bfile = File::Spec->catfile($incdir, @me);
5525         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5526         next unless -f $bfile;
5527         my $foundv = MM->parse_version($bfile);
5528         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5529             $self->{INST_FILE} = $bfile;
5530             $self->{INST_VERSION} = $bestv = $foundv;
5531         }
5532     }
5533     $self->{INST_FILE};
5534 }
5535
5536 #-> sub CPAN::Bundle::inst_version ;
5537 sub inst_version {
5538     my($self) = @_;
5539     $self->inst_file; # finds INST_VERSION as side effect
5540     $self->{INST_VERSION};
5541 }
5542
5543 #-> sub CPAN::Bundle::rematein ;
5544 sub rematein {
5545     my($self,$meth) = @_;
5546     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5547     my($id) = $self->id;
5548     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5549         unless $self->inst_file || $self->cpan_file;
5550     my($s,%fail);
5551     for $s ($self->contains) {
5552         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5553             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5554         if ($type eq 'CPAN::Distribution') {
5555             $CPAN::Frontend->mywarn(qq{
5556 The Bundle }.$self->id.qq{ contains
5557 explicitly a file $s.
5558 });
5559             sleep 3;
5560         }
5561         # possibly noisy action:
5562         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5563         my $obj = $CPAN::META->instance($type,$s);
5564         $obj->$meth();
5565         if ($obj->isa(CPAN::Bundle)
5566             &&
5567             exists $obj->{install_failed}
5568             &&
5569             ref($obj->{install_failed}) eq "HASH"
5570            ) {
5571           for (keys %{$obj->{install_failed}}) {
5572             $self->{install_failed}{$_} = undef; # propagate faiure up
5573                                                  # to me in a
5574                                                  # recursive call
5575             $fail{$s} = 1; # the bundle itself may have succeeded but
5576                            # not all children
5577           }
5578         } else {
5579           my $success;
5580           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5581           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5582           if ($success) {
5583             delete $self->{install_failed}{$s};
5584           } else {
5585             $fail{$s} = 1;
5586           }
5587         }
5588     }
5589
5590     # recap with less noise
5591     if ( $meth eq "install" ) {
5592         if (%fail) {
5593             require Text::Wrap;
5594             my $raw = sprintf(qq{Bundle summary:
5595 The following items in bundle %s had installation problems:},
5596                               $self->id
5597                              );
5598             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5599             $CPAN::Frontend->myprint("\n");
5600             my $paragraph = "";
5601             my %reported;
5602             for $s ($self->contains) {
5603               if ($fail{$s}){
5604                 $paragraph .= "$s ";
5605                 $self->{install_failed}{$s} = undef;
5606                 $reported{$s} = undef;
5607               }
5608             }
5609             my $report_propagated;
5610             for $s (sort keys %{$self->{install_failed}}) {
5611               next if exists $reported{$s};
5612               $paragraph .= "and the following items had problems
5613 during recursive bundle calls: " unless $report_propagated++;
5614               $paragraph .= "$s ";
5615             }
5616             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
5617             $CPAN::Frontend->myprint("\n");
5618         } else {
5619             $self->{'install'} = 'YES';
5620         }
5621     }
5622 }
5623
5624 #sub CPAN::Bundle::xs_file
5625 sub xs_file {
5626     # If a bundle contains another that contains an xs_file we have
5627     # here, we just don't bother I suppose
5628     return 0;
5629 }
5630
5631 #-> sub CPAN::Bundle::force ;
5632 sub force   { shift->rematein('force',@_); }
5633 #-> sub CPAN::Bundle::notest ;
5634 sub notest  { shift->rematein('notest',@_); }
5635 #-> sub CPAN::Bundle::get ;
5636 sub get     { shift->rematein('get',@_); }
5637 #-> sub CPAN::Bundle::make ;
5638 sub make    { shift->rematein('make',@_); }
5639 #-> sub CPAN::Bundle::test ;
5640 sub test    {
5641     my $self = shift;
5642     $self->{badtestcnt} ||= 0;
5643     $self->rematein('test',@_);
5644 }
5645 #-> sub CPAN::Bundle::install ;
5646 sub install {
5647   my $self = shift;
5648   $self->rematein('install',@_);
5649 }
5650 #-> sub CPAN::Bundle::clean ;
5651 sub clean   { shift->rematein('clean',@_); }
5652
5653 #-> sub CPAN::Bundle::uptodate ;
5654 sub uptodate {
5655     my($self) = @_;
5656     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5657     my $c;
5658     foreach $c ($self->contains) {
5659         my $obj = CPAN::Shell->expandany($c);
5660         return 0 unless $obj->uptodate;
5661     }
5662     return 1;
5663 }
5664
5665 #-> sub CPAN::Bundle::readme ;
5666 sub readme  {
5667     my($self) = @_;
5668     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5669 No File found for bundle } . $self->id . qq{\n}), return;
5670     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5671     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5672 }
5673
5674 package CPAN::Module;
5675
5676 # Accessors
5677 # sub CPAN::Module::userid
5678 sub userid {
5679     my $self = shift;
5680     return unless exists $self->{RO}; # should never happen
5681     return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5682 }
5683 # sub CPAN::Module::description
5684 sub description { shift->{RO}{description} }
5685
5686 sub undelay {
5687     my $self = shift;
5688     delete $self->{later};
5689     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5690         $dist->undelay;
5691     }
5692 }
5693
5694 #-> sub CPAN::Module::color_cmd_tmps ;
5695 sub color_cmd_tmps {
5696     my($self) = shift;
5697     my($depth) = shift || 0;
5698     my($color) = shift || 0;
5699     my($ancestors) = shift || [];
5700     # a module needs to recurse to its cpan_file
5701
5702     return if exists $self->{incommandcolor}
5703         && $self->{incommandcolor}==$color;
5704     if ($depth>=100){
5705         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5706     }
5707     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5708
5709     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5710         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5711     }
5712     if ($color==0) {
5713         delete $self->{badtestcnt};
5714     }
5715     $self->{incommandcolor} = $color;
5716 }
5717
5718 #-> sub CPAN::Module::as_glimpse ;
5719 sub as_glimpse {
5720     my($self) = @_;
5721     my(@m);
5722     my $class = ref($self);
5723     $class =~ s/^CPAN:://;
5724     my $color_on = "";
5725     my $color_off = "";
5726     if (
5727         $CPAN::Shell::COLOR_REGISTERED
5728         &&
5729         $CPAN::META->has_inst("Term::ANSIColor")
5730         &&
5731         $self->{RO}{description}
5732        ) {
5733         $color_on = Term::ANSIColor::color("green");
5734         $color_off = Term::ANSIColor::color("reset");
5735     }
5736     push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5737                      $class,
5738                      $color_on,
5739                      $self->id,
5740                      $color_off,
5741                      $self->cpan_file);
5742     join "", @m;
5743 }
5744
5745 #-> sub CPAN::Module::as_string ;
5746 sub as_string {
5747     my($self) = @_;
5748     my(@m);
5749     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5750     my $class = ref($self);
5751     $class =~ s/^CPAN:://;
5752     local($^W) = 0;
5753     push @m, $class, " id = $self->{ID}\n";
5754     my $sprintf = "    %-12s %s\n";
5755     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5756         if $self->description;
5757     my $sprintf2 = "    %-12s %s (%s)\n";
5758     my($userid);
5759     $userid = $self->userid;
5760     if ( $userid ){
5761         my $author;
5762         if ($author = CPAN::Shell->expand('Author',$userid)) {
5763           my $email = "";
5764           my $m; # old perls
5765           if ($m = $author->email) {
5766             $email = " <$m>";
5767           }
5768           push @m, sprintf(
5769                            $sprintf2,
5770                            'CPAN_USERID',
5771                            $userid,
5772                            $author->fullname . $email
5773                           );
5774         }
5775     }
5776     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5777         if $self->cpan_version;
5778     if (my $cpan_file = $self->cpan_file){
5779         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
5780         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
5781             my $upload_date = $dist->upload_date;
5782             if ($upload_date) {
5783                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
5784             }
5785         }
5786     }
5787     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5788     my(%statd,%stats,%statl,%stati);
5789     @statd{qw,? i c a b R M S,} = qw,unknown idea
5790         pre-alpha alpha beta released mature standard,;
5791     @stats{qw,? m d u n a,}       = qw,unknown mailing-list
5792         developer comp.lang.perl.* none abandoned,;
5793     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
5794     @stati{qw,? f r O h,}         = qw,unknown functions
5795         references+ties object-oriented hybrid,;
5796     $statd{' '} = 'unknown';
5797     $stats{' '} = 'unknown';
5798     $statl{' '} = 'unknown';
5799     $stati{' '} = 'unknown';
5800     push @m, sprintf(
5801                      $sprintf3,
5802                      'DSLI_STATUS',
5803                      $self->{RO}{statd},
5804                      $self->{RO}{stats},
5805                      $self->{RO}{statl},
5806                      $self->{RO}{stati},
5807                      $statd{$self->{RO}{statd}},
5808                      $stats{$self->{RO}{stats}},
5809                      $statl{$self->{RO}{statl}},
5810                      $stati{$self->{RO}{stati}}
5811                     ) if $self->{RO}{statd};
5812     my $local_file = $self->inst_file;
5813     unless ($self->{MANPAGE}) {
5814         if ($local_file) {
5815             $self->{MANPAGE} = $self->manpage_headline($local_file);
5816         } else {
5817             # If we have already untarred it, we should look there
5818             my $dist = $CPAN::META->instance('CPAN::Distribution',
5819                                              $self->cpan_file);
5820             # warn "dist[$dist]";
5821             # mff=manifest file; mfh=manifest handle
5822             my($mff,$mfh);
5823             if (
5824                 $dist->{build_dir}
5825                 and
5826                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5827                 and
5828                 $mfh = FileHandle->new($mff)
5829                ) {
5830                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5831                 my $lfre = $self->id; # local file RE
5832                 $lfre =~ s/::/./g;
5833                 $lfre .= "\\.pm\$";
5834                 my($lfl); # local file file
5835                 local $/ = "\n";
5836                 my(@mflines) = <$mfh>;
5837                 for (@mflines) {
5838                     s/^\s+//;
5839                     s/\s.*//s;
5840                 }
5841                 while (length($lfre)>5 and !$lfl) {
5842                     ($lfl) = grep /$lfre/, @mflines;
5843                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5844                     $lfre =~ s/.+?\.//;
5845                 }
5846                 $lfl =~ s/\s.*//; # remove comments
5847                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5848                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5849                 # warn "lfl_abs[$lfl_abs]";
5850                 if (-f $lfl_abs) {
5851                     $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5852                 }
5853             }
5854         }
5855     }
5856     my($item);
5857     for $item (qw/MANPAGE/) {
5858         push @m, sprintf($sprintf, $item, $self->{$item})
5859             if exists $self->{$item};
5860     }
5861     for $item (qw/CONTAINS/) {
5862         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5863             if exists $self->{$item} && @{$self->{$item}};
5864     }
5865     push @m, sprintf($sprintf, 'INST_FILE',
5866                      $local_file || "(not installed)");
5867     push @m, sprintf($sprintf, 'INST_VERSION',
5868                      $self->inst_version) if $local_file;
5869     join "", @m, "\n";
5870 }
5871
5872 sub manpage_headline {
5873   my($self,$local_file) = @_;
5874   my(@local_file) = $local_file;
5875   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5876   push @local_file, $local_file;
5877   my(@result,$locf);
5878   for $locf (@local_file) {
5879     next unless -f $locf;
5880     my $fh = FileHandle->new($locf)
5881         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5882     my $inpod = 0;
5883     local $/ = "\n";
5884     while (<$fh>) {
5885       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5886           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5887       next unless $inpod;
5888       next if /^=/;
5889       next if /^\s+$/;
5890       chomp;
5891       push @result, $_;
5892     }
5893     close $fh;
5894     last if @result;
5895   }
5896   join " ", @result;
5897 }
5898
5899 #-> sub CPAN::Module::cpan_file ;
5900 # Note: also inherited by CPAN::Bundle
5901 sub cpan_file {
5902     my $self = shift;
5903     CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5904     unless (defined $self->{RO}{CPAN_FILE}) {
5905         CPAN::Index->reload;
5906     }
5907     if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5908         return $self->{RO}{CPAN_FILE};
5909     } else {
5910         my $userid = $self->userid;
5911         if ( $userid ) {
5912             if ($CPAN::META->exists("CPAN::Author",$userid)) {
5913                 my $author = $CPAN::META->instance("CPAN::Author",
5914                                                    $userid);
5915                 my $fullname = $author->fullname;
5916                 my $email = $author->email;
5917                 unless (defined $fullname && defined $email) {
5918                     return sprintf("Contact Author %s",
5919                                    $userid,
5920                                   );
5921                 }
5922                 return "Contact Author $fullname <$email>";
5923             } else {
5924                 return "Contact Author $userid (Email address not available)";
5925             }
5926         } else {
5927             return "N/A";
5928         }
5929     }
5930 }
5931
5932 #-> sub CPAN::Module::cpan_version ;
5933 sub cpan_version {
5934     my $self = shift;
5935
5936     $self->{RO}{CPAN_VERSION} = 'undef'
5937         unless defined $self->{RO}{CPAN_VERSION};
5938     # I believe this is always a bug in the index and should be reported
5939     # as such, but usually I find out such an error and do not want to
5940     # provoke too many bugreports
5941
5942     $self->{RO}{CPAN_VERSION};
5943 }
5944
5945 #-> sub CPAN::Module::force ;
5946 sub force {
5947     my($self) = @_;
5948     $self->{'force_update'}++;
5949 }
5950
5951 sub notest {
5952     my($self) = [at]_;
5953     # warn "XDEBUG: set notest for Module";
5954     $self->{'notest'}++;
5955 }
5956
5957 #-> sub CPAN::Module::rematein ;
5958 sub rematein {
5959     my($self,$meth) = @_;
5960     $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5961                                      $meth,
5962                                      $self->id));
5963     my $cpan_file = $self->cpan_file;
5964     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5965       $CPAN::Frontend->mywarn(sprintf qq{
5966   The module %s isn\'t available on CPAN.
5967
5968   Either the module has not yet been uploaded to CPAN, or it is
5969   temporary unavailable. Please contact the author to find out
5970   more about the status. Try 'i %s'.
5971 },
5972                               $self->id,
5973                               $self->id,
5974                              );
5975       return;
5976     }
5977     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5978     $pack->called_for($self->id);
5979     $pack->force($meth) if exists $self->{'force_update'};
5980     $pack->notest($meth) if exists $self->{'notest'};
5981     eval {
5982         $pack->$meth();
5983     };
5984     my $err = $@;
5985     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5986     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
5987     delete $self->{'force_update'};
5988     delete $self->{'notest'};
5989     if ($err) {
5990         die $err;
5991     }
5992 }
5993
5994 #-> sub CPAN::Module::perldoc ;
5995 sub perldoc { shift->rematein('perldoc') }
5996 #-> sub CPAN::Module::readme ;
5997 sub readme  { shift->rematein('readme') }
5998 #-> sub CPAN::Module::look ;
5999 sub look    { shift->rematein('look') }
6000 #-> sub CPAN::Module::cvs_import ;
6001 sub cvs_import { shift->rematein('cvs_import') }
6002 #-> sub CPAN::Module::get ;
6003 sub get     { shift->rematein('get',@_) }
6004 #-> sub CPAN::Module::make ;
6005 sub make    { shift->rematein('make') }
6006 #-> sub CPAN::Module::test ;
6007 sub test   {
6008     my $self = shift;
6009     $self->{badtestcnt} ||= 0;
6010     $self->rematein('test',@_);
6011 }
6012 #-> sub CPAN::Module::uptodate ;
6013 sub uptodate {
6014     my($self) = @_;
6015     my($latest) = $self->cpan_version;
6016     $latest ||= 0;
6017     my($inst_file) = $self->inst_file;
6018     my($have) = 0;
6019     if (defined $inst_file) {
6020         $have = $self->inst_version;
6021     }
6022     local($^W)=0;
6023     if ($inst_file
6024         &&
6025         ! CPAN::Version->vgt($latest, $have)
6026        ) {
6027         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
6028                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
6029         return 1;
6030     }
6031     return;
6032 }
6033 #-> sub CPAN::Module::install ;
6034 sub install {
6035     my($self) = @_;
6036     my($doit) = 0;
6037     if ($self->uptodate
6038         &&
6039         not exists $self->{'force_update'}
6040        ) {
6041         $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
6042     } else {
6043         $doit = 1;
6044     }
6045     if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
6046         $CPAN::Frontend->mywarn(qq{
6047 \n\n\n     ***WARNING***
6048      The module $self->{ID} has no active maintainer.\n\n\n
6049 });
6050         sleep 5;
6051     }
6052     $self->rematein('install') if $doit;
6053 }
6054 #-> sub CPAN::Module::clean ;
6055 sub clean  { shift->rematein('clean') }
6056
6057 #-> sub CPAN::Module::inst_file ;
6058 sub inst_file {
6059     my($self) = @_;
6060     my($dir,@packpath);
6061     @packpath = split /::/, $self->{ID};
6062     $packpath[-1] .= ".pm";
6063     foreach $dir (@INC) {
6064         my $pmfile = File::Spec->catfile($dir,@packpath);
6065         if (-f $pmfile){
6066             return $pmfile;
6067         }
6068     }
6069     return;
6070 }
6071
6072 #-> sub CPAN::Module::xs_file ;
6073 sub xs_file {
6074     my($self) = @_;
6075     my($dir,@packpath);
6076     @packpath = split /::/, $self->{ID};
6077     push @packpath, $packpath[-1];
6078     $packpath[-1] .= "." . $Config::Config{'dlext'};
6079     foreach $dir (@INC) {
6080         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
6081         if (-f $xsfile){
6082             return $xsfile;
6083         }
6084     }
6085     return;
6086 }
6087
6088 #-> sub CPAN::Module::inst_version ;
6089 sub inst_version {
6090     my($self) = @_;
6091     my $parsefile = $self->inst_file or return;
6092     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
6093     my $have;
6094
6095     # there was a bug in 5.6.0 that let lots of unini warnings out of
6096     # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
6097     # the following workaround after 5.6.1 is out.
6098     local($SIG{__WARN__}) =  sub { my $w = shift;
6099                                    return if $w =~ /uninitialized/i;
6100                                    warn $w;
6101                                  };
6102
6103     $have = MM->parse_version($parsefile) || "undef";
6104     $have =~ s/^ //; # since the %vd hack these two lines here are needed
6105     $have =~ s/ $//; # trailing whitespace happens all the time
6106
6107     # My thoughts about why %vd processing should happen here
6108
6109     # Alt1 maintain it as string with leading v:
6110     # read index files     do nothing
6111     # compare it           use utility for compare
6112     # print it             do nothing
6113
6114     # Alt2 maintain it as what it is
6115     # read index files     convert
6116     # compare it           use utility because there's still a ">" vs "gt" issue
6117     # print it             use CPAN::Version for print
6118
6119     # Seems cleaner to hold it in memory as a string starting with a "v"
6120
6121     # If the author of this module made a mistake and wrote a quoted
6122     # "v1.13" instead of v1.13, we simply leave it at that with the
6123     # effect that *we* will treat it like a v-tring while the rest of
6124     # perl won't. Seems sensible when we consider that any action we
6125     # could take now would just add complexity.
6126
6127     $have = CPAN::Version->readable($have);
6128
6129     $have =~ s/\s*//g; # stringify to float around floating point issues
6130     $have; # no stringify needed, \s* above matches always
6131 }
6132
6133 package CPAN::Tarzip;
6134
6135 # CPAN::Tarzip::gzip
6136 sub gzip {
6137   my($class,$read,$write) = @_;
6138   if ($CPAN::META->has_inst("Compress::Zlib")) {
6139     my($buffer,$fhw);
6140     $fhw = FileHandle->new($read)
6141         or $CPAN::Frontend->mydie("Could not open $read: $!");
6142         my $cwd = `pwd`;
6143     my $gz = Compress::Zlib::gzopen($write, "wb")
6144         or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
6145     $gz->gzwrite($buffer)
6146         while read($fhw,$buffer,4096) > 0 ;
6147     $gz->gzclose() ;
6148     $fhw->close;
6149     return 1;
6150   } else {
6151     system("$CPAN::Config->{gzip} -c $read > $write")==0;
6152   }
6153 }
6154
6155
6156 # CPAN::Tarzip::gunzip
6157 sub gunzip {
6158   my($class,$read,$write) = @_;
6159   if ($CPAN::META->has_inst("Compress::Zlib")) {
6160     my($buffer,$fhw);
6161     $fhw = FileHandle->new(">$write")
6162         or $CPAN::Frontend->mydie("Could not open >$write: $!");
6163     my $gz = Compress::Zlib::gzopen($read, "rb")
6164         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
6165     $fhw->print($buffer)
6166         while $gz->gzread($buffer) > 0 ;
6167     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
6168         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
6169     $gz->gzclose() ;
6170     $fhw->close;
6171     return 1;
6172   } else {
6173     system("$CPAN::Config->{gzip} -dc $read > $write")==0;
6174   }
6175 }
6176
6177
6178 # CPAN::Tarzip::gtest
6179 sub gtest {
6180   my($class,$read) = @_;
6181   # After I had reread the documentation in zlib.h, I discovered that
6182   # uncompressed files do not lead to an gzerror (anymore?).
6183   if ( $CPAN::META->has_inst("Compress::Zlib") ) {
6184     my($buffer,$len);
6185     $len = 0;
6186     my $gz = Compress::Zlib::gzopen($read, "rb")
6187         or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
6188                                           $read,
6189                                           $Compress::Zlib::gzerrno));
6190     while ($gz->gzread($buffer) > 0 ){
6191         $len += length($buffer);
6192         $buffer = "";
6193     }
6194     my $err = $gz->gzerror;
6195     my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
6196     if ($len == -s $read){
6197         $success = 0;
6198         CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
6199     }
6200     $gz->gzclose();
6201     CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
6202     return $success;
6203   } else {
6204       return system("$CPAN::Config->{gzip} -dt $read")==0;
6205   }
6206 }
6207
6208
6209 # CPAN::Tarzip::TIEHANDLE
6210 sub TIEHANDLE {
6211   my($class,$file) = @_;
6212   my $ret;
6213   $class->debug("file[$file]");
6214   if ($CPAN::META->has_inst("Compress::Zlib")) {
6215     my $gz = Compress::Zlib::gzopen($file,"rb") or
6216         die "Could not gzopen $file";
6217     $ret = bless {GZ => $gz}, $class;
6218   } else {
6219     my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
6220     my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
6221     binmode $fh;
6222     $ret = bless {FH => $fh}, $class;
6223   }
6224   $ret;
6225 }
6226
6227
6228 # CPAN::Tarzip::READLINE
6229 sub READLINE {
6230   my($self) = @_;
6231   if (exists $self->{GZ}) {
6232     my $gz = $self->{GZ};
6233     my($line,$bytesread);
6234     $bytesread = $gz->gzreadline($line);
6235     return undef if $bytesread <= 0;
6236     return $line;
6237   } else {
6238     my $fh = $self->{FH};
6239     return scalar <$fh>;
6240   }
6241 }
6242
6243
6244 # CPAN::Tarzip::READ
6245 sub READ {
6246   my($self,$ref,$length,$offset) = @_;
6247   die "read with offset not implemented" if defined $offset;
6248   if (exists $self->{GZ}) {
6249     my $gz = $self->{GZ};
6250     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
6251     return $byteread;
6252   } else {
6253     my $fh = $self->{FH};
6254     return read($fh,$$ref,$length);
6255   }
6256 }
6257
6258
6259 # CPAN::Tarzip::DESTROY
6260 sub DESTROY {
6261     my($self) = @_;
6262     if (exists $self->{GZ}) {
6263         my $gz = $self->{GZ};
6264         $gz->gzclose() if defined $gz; # hard to say if it is allowed
6265                                        # to be undef ever. AK, 2000-09
6266     } else {
6267         my $fh = $self->{FH};
6268         $fh->close if defined $fh;
6269     }
6270     undef $self;
6271 }
6272
6273
6274 # CPAN::Tarzip::untar
6275 sub untar {
6276   my($class,$file) = @_;
6277   my($prefer) = 0;
6278
6279   if (0) { # makes changing order easier
6280   } elsif ($BUGHUNTING){
6281       $prefer=2;
6282   } elsif (MM->maybe_command($CPAN::Config->{gzip})
6283            &&
6284            MM->maybe_command($CPAN::Config->{'tar'})) {
6285       # should be default until Archive::Tar is fixed
6286       $prefer = 1;
6287   } elsif (
6288            $CPAN::META->has_inst("Archive::Tar")
6289            &&
6290            $CPAN::META->has_inst("Compress::Zlib") ) {
6291       $prefer = 2;
6292   } else {
6293     $CPAN::Frontend->mydie(qq{
6294 CPAN.pm needs either both external programs tar and gzip installed or
6295 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
6296 is available. Can\'t continue.
6297 });
6298   }
6299   if ($prefer==1) { # 1 => external gzip+tar
6300     my($system);
6301     my $is_compressed = $class->gtest($file);
6302     if ($is_compressed) {
6303         $system = "$CPAN::Config->{gzip} --decompress --stdout " .
6304             "< $file | $CPAN::Config->{tar} xvf -";
6305     } else {
6306         $system = "$CPAN::Config->{tar} xvf $file";
6307     }
6308     if (system($system) != 0) {
6309         # people find the most curious tar binaries that cannot handle
6310         # pipes
6311         if ($is_compressed) {
6312             (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
6313             if (CPAN::Tarzip->gunzip($file, $ungzf)) {
6314                 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
6315             } else {
6316                 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
6317             }
6318             $file = $ungzf;
6319         }
6320         $system = "$CPAN::Config->{tar} xvf $file";
6321         $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
6322         if (system($system)==0) {
6323             $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
6324         } else {
6325             $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
6326         }
6327         return 1;
6328     } else {
6329         return 1;
6330     }
6331   } elsif ($prefer==2) { # 2 => modules
6332     my $tar = Archive::Tar->new($file,1);
6333     my $af; # archive file
6334     my @af;
6335     if ($BUGHUNTING) {
6336         # RCS 1.337 had this code, it turned out unacceptable slow but
6337         # it revealed a bug in Archive::Tar. Code is only here to hunt
6338         # the bug again. It should never be enabled in published code.
6339         # GDGraph3d-0.53 was an interesting case according to Larry
6340         # Virden.
6341         warn(">>>Bughunting code enabled<<< " x 20);
6342         for $af ($tar->list_files) {
6343             if ($af =~ m!^(/|\.\./)!) {
6344                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6345                                        "illegal member [$af]");
6346             }
6347             $CPAN::Frontend->myprint("$af\n");
6348             $tar->extract($af); # slow but effective for finding the bug
6349             return if $CPAN::Signal;
6350         }
6351     } else {
6352         for $af ($tar->list_files) {
6353             if ($af =~ m!^(/|\.\./)!) {
6354                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6355                                        "illegal member [$af]");
6356             }
6357             $CPAN::Frontend->myprint("$af\n");
6358             push @af, $af;
6359             return if $CPAN::Signal;
6360         }
6361         $tar->extract(@af);
6362     }
6363
6364     Mac::BuildTools::convert_files([$tar->list_files], 1)
6365         if ($^O eq 'MacOS');
6366
6367     return 1;
6368   }
6369 }
6370
6371 sub unzip {
6372     my($class,$file) = @_;
6373     if ($CPAN::META->has_inst("Archive::Zip")) {
6374         # blueprint of the code from Archive::Zip::Tree::extractTree();
6375         my $zip = Archive::Zip->new();
6376         my $status;
6377         $status = $zip->read($file);
6378         die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
6379         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
6380         my @members = $zip->members();
6381         for my $member ( @members ) {
6382             my $af = $member->fileName();
6383             if ($af =~ m!^(/|\.\./)!) {
6384                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6385                                        "illegal member [$af]");
6386             }
6387             my $status = $member->extractToFileNamed( $af );
6388             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
6389             die "Extracting of file[$af] from zipfile[$file] failed\n" if
6390                 $status != Archive::Zip::AZ_OK();
6391             return if $CPAN::Signal;
6392         }
6393         return 1;
6394     } else {
6395         my $unzip = $CPAN::Config->{unzip} or
6396             $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
6397         my @system = ($unzip, $file);
6398         return system(@system) == 0;
6399     }
6400 }
6401
6402 package CPAN;
6403
6404 1;
6405
6406 __END__
6407
6408 =head1 NAME
6409
6410 CPAN - query, download and build perl modules from CPAN sites
6411
6412 =head1 SYNOPSIS
6413
6414 Interactive mode:
6415
6416   perl -MCPAN -e shell;
6417
6418 Batch mode:
6419
6420   use CPAN;
6421
6422   autobundle, clean, install, make, recompile, test
6423
6424 =head1 STATUS
6425
6426 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6427 of a modern rewrite from ground up with greater extensibility and more
6428 features but no full compatibility. If you're new to CPAN.pm, you
6429 probably should investigate if CPANPLUS is the better choice for you.
6430 If you're already used to CPAN.pm you're welcome to continue using it,
6431 if you accept that its development is mostly (though not completely)
6432 stalled.
6433
6434 =head1 DESCRIPTION
6435
6436 The CPAN module is designed to automate the make and install of perl
6437 modules and extensions. It includes some primitive searching capabilities and
6438 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6439 to fetch the raw data from the net.
6440
6441 Modules are fetched from one or more of the mirrored CPAN
6442 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6443 directory.
6444
6445 The CPAN module also supports the concept of named and versioned
6446 I<bundles> of modules. Bundles simplify the handling of sets of
6447 related modules. See Bundles below.
6448
6449 The package contains a session manager and a cache manager. There is
6450 no status retained between sessions. The session manager keeps track
6451 of what has been fetched, built and installed in the current
6452 session. The cache manager keeps track of the disk space occupied by
6453 the make processes and deletes excess space according to a simple FIFO
6454 mechanism.
6455
6456 For extended searching capabilities there's a plugin for CPAN available,
6457 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6458 that indexes all documents available in CPAN authors directories. If
6459 C<CPAN::WAIT> is installed on your system, the interactive shell of
6460 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6461 which send queries to the WAIT server that has been configured for your
6462 installation.
6463
6464 All other methods provided are accessible in a programmer style and in an
6465 interactive shell style.
6466
6467 =head2 Interactive Mode
6468
6469 The interactive mode is entered by running
6470
6471     perl -MCPAN -e shell
6472
6473 which puts you into a readline interface. You will have the most fun if
6474 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6475 command completion.
6476
6477 Once you are on the command line, type 'h' and the rest should be
6478 self-explanatory.
6479
6480 The function call C<shell> takes two optional arguments, one is the
6481 prompt, the second is the default initial command line (the latter
6482 only works if a real ReadLine interface module is installed).
6483
6484 The most common uses of the interactive modes are
6485
6486 =over 2
6487
6488 =item Searching for authors, bundles, distribution files and modules
6489
6490 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6491 for each of the four categories and another, C<i> for any of the
6492 mentioned four. Each of the four entities is implemented as a class
6493 with slightly differing methods for displaying an object.
6494
6495 Arguments you pass to these commands are either strings exactly matching
6496 the identification string of an object or regular expressions that are
6497 then matched case-insensitively against various attributes of the
6498 objects. The parser recognizes a regular expression only if you
6499 enclose it between two slashes.
6500
6501 The principle is that the number of found objects influences how an
6502 item is displayed. If the search finds one item, the result is
6503 displayed with the rather verbose method C<as_string>, but if we find
6504 more than one, we display each object with the terse method
6505 <as_glimpse>.
6506
6507 =item make, test, install, clean  modules or distributions
6508
6509 These commands take any number of arguments and investigate what is
6510 necessary to perform the action. If the argument is a distribution
6511 file name (recognized by embedded slashes), it is processed. If it is
6512 a module, CPAN determines the distribution file in which this module
6513 is included and processes that, following any dependencies named in
6514 the module's Makefile.PL (this behavior is controlled by
6515 I<prerequisites_policy>.)
6516
6517 Any C<make> or C<test> are run unconditionally. An
6518
6519   install <distribution_file>
6520
6521 also is run unconditionally. But for
6522
6523   install <module>
6524
6525 CPAN checks if an install is actually needed for it and prints
6526 I<module up to date> in the case that the distribution file containing
6527 the module doesn't need to be updated.
6528
6529 CPAN also keeps track of what it has done within the current session
6530 and doesn't try to build a package a second time regardless if it
6531 succeeded or not. The C<force> pragma may precede another command
6532 (currently: C<make>, C<test>, or C<install>) and executes the
6533 command from scratch.
6534
6535 Example:
6536
6537     cpan> install OpenGL
6538     OpenGL is up to date.
6539     cpan> force install OpenGL
6540     Running make
6541     OpenGL-0.4/
6542     OpenGL-0.4/COPYRIGHT
6543     [...]
6544
6545 The C<notest> pragma may be set to skip the test part in the build
6546 process.
6547
6548 Example:
6549
6550     cpan> notest install Tk
6551
6552 A C<clean> command results in a
6553
6554   make clean
6555
6556 being executed within the distribution file's working directory.
6557
6558 =item get, readme, perldoc, look module or distribution
6559
6560 C<get> downloads a distribution file without further action. C<readme>
6561 displays the README file of the associated distribution. C<Look> gets
6562 and untars (if not yet done) the distribution file, changes to the
6563 appropriate directory and opens a subshell process in that directory.
6564 C<perldoc> displays the pod documentation of the module in html or
6565 plain text format.
6566
6567 =item ls author
6568
6569 C<ls> lists all distribution files in and below an author's CPAN
6570 directory. Only those files that contain modules are listed and if
6571 there is more than one for any given module, only the most recent one
6572 is listed.
6573
6574 =item Signals
6575
6576 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6577 in the cpan-shell it is intended that you can press C<^C> anytime and
6578 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6579 to clean up and leave the shell loop. You can emulate the effect of a
6580 SIGTERM by sending two consecutive SIGINTs, which usually means by
6581 pressing C<^C> twice.
6582
6583 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6584 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6585
6586 =back
6587
6588 =head2 CPAN::Shell
6589
6590 The commands that are available in the shell interface are methods in
6591 the package CPAN::Shell. If you enter the shell command, all your
6592 input is split by the Text::ParseWords::shellwords() routine which
6593 acts like most shells do. The first word is being interpreted as the
6594 method to be called and the rest of the words are treated as arguments
6595 to this method. Continuation lines are supported if a line ends with a
6596 literal backslash.
6597
6598 =head2 autobundle
6599
6600 C<autobundle> writes a bundle file into the
6601 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6602 a list of all modules that are both available from CPAN and currently
6603 installed within @INC. The name of the bundle file is based on the
6604 current date and a counter.
6605
6606 =head2 recompile
6607
6608 recompile() is a very special command in that it takes no argument and
6609 runs the make/test/install cycle with brute force over all installed
6610 dynamically loadable extensions (aka XS modules) with 'force' in
6611 effect. The primary purpose of this command is to finish a network
6612 installation. Imagine, you have a common source tree for two different
6613 architectures. You decide to do a completely independent fresh
6614 installation. You start on one architecture with the help of a Bundle
6615 file produced earlier. CPAN installs the whole Bundle for you, but
6616 when you try to repeat the job on the second architecture, CPAN
6617 responds with a C<"Foo up to date"> message for all modules. So you
6618 invoke CPAN's recompile on the second architecture and you're done.
6619
6620 Another popular use for C<recompile> is to act as a rescue in case your
6621 perl breaks binary compatibility. If one of the modules that CPAN uses
6622 is in turn depending on binary compatibility (so you cannot run CPAN
6623 commands), then you should try the CPAN::Nox module for recovery.
6624
6625 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6626
6627 Although it may be considered internal, the class hierarchy does matter
6628 for both users and programmer. CPAN.pm deals with above mentioned four
6629 classes, and all those classes share a set of methods. A classical
6630 single polymorphism is in effect. A metaclass object registers all
6631 objects of all kinds and indexes them with a string. The strings
6632 referencing objects have a separated namespace (well, not completely
6633 separated):
6634
6635          Namespace                         Class
6636
6637    words containing a "/" (slash)      Distribution
6638     words starting with Bundle::          Bundle
6639           everything else            Module or Author
6640
6641 Modules know their associated Distribution objects. They always refer
6642 to the most recent official release. Developers may mark their releases
6643 as unstable development versions (by inserting an underbar into the
6644 module version number which will also be reflected in the distribution
6645 name when you run 'make dist'), so the really hottest and newest
6646 distribution is not always the default.  If a module Foo circulates
6647 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6648 way to install version 1.23 by saying
6649
6650     install Foo
6651
6652 This would install the complete distribution file (say
6653 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6654 like to install version 1.23_90, you need to know where the
6655 distribution file resides on CPAN relative to the authors/id/
6656 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6657 so you would have to say
6658
6659     install BAR/Foo-1.23_90.tar.gz
6660
6661 The first example will be driven by an object of the class
6662 CPAN::Module, the second by an object of class CPAN::Distribution.
6663
6664 =head2 Programmer's interface
6665
6666 If you do not enter the shell, the available shell commands are both
6667 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6668 functions in the calling package (C<install(...)>).
6669
6670 There's currently only one class that has a stable interface -
6671 CPAN::Shell. All commands that are available in the CPAN shell are
6672 methods of the class CPAN::Shell. Each of the commands that produce
6673 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6674 the IDs of all modules within the list.
6675
6676 =over 2
6677
6678 =item expand($type,@things)
6679
6680 The IDs of all objects available within a program are strings that can
6681 be expanded to the corresponding real objects with the
6682 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6683 list of CPAN::Module objects according to the C<@things> arguments
6684 given. In scalar context it only returns the first element of the
6685 list.
6686
6687 =item expandany(@things)
6688
6689 Like expand, but returns objects of the appropriate type, i.e.
6690 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6691 CPAN::Distribution objects fro distributions.
6692
6693 =item Programming Examples
6694
6695 This enables the programmer to do operations that combine
6696 functionalities that are available in the shell.
6697
6698     # install everything that is outdated on my disk:
6699     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6700
6701     # install my favorite programs if necessary:
6702     for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6703         my $obj = CPAN::Shell->expand('Module',$mod);
6704         $obj->install;
6705     }
6706
6707     # list all modules on my disk that have no VERSION number
6708     for $mod (CPAN::Shell->expand("Module","/./")){
6709         next unless $mod->inst_file;
6710         # MakeMaker convention for undefined $VERSION:
6711         next unless $mod->inst_version eq "undef";
6712         print "No VERSION in ", $mod->id, "\n";
6713     }
6714
6715     # find out which distribution on CPAN contains a module:
6716     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6717
6718 Or if you want to write a cronjob to watch The CPAN, you could list
6719 all modules that need updating. First a quick and dirty way:
6720
6721     perl -e 'use CPAN; CPAN::Shell->r;'
6722
6723 If you don't want to get any output in the case that all modules are
6724 up to date, you can parse the output of above command for the regular
6725 expression //modules are up to date// and decide to mail the output
6726 only if it doesn't match. Ick?
6727
6728 If you prefer to do it more in a programmer style in one single
6729 process, maybe something like this suits you better:
6730
6731   # list all modules on my disk that have newer versions on CPAN
6732   for $mod (CPAN::Shell->expand("Module","/./")){
6733     next unless $mod->inst_file;
6734     next if $mod->uptodate;
6735     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6736         $mod->id, $mod->inst_version, $mod->cpan_version;
6737   }
6738
6739 If that gives you too much output every day, you maybe only want to
6740 watch for three modules. You can write
6741
6742   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6743
6744 as the first line instead. Or you can combine some of the above
6745 tricks:
6746
6747   # watch only for a new mod_perl module
6748   $mod = CPAN::Shell->expand("Module","mod_perl");
6749   exit if $mod->uptodate;
6750   # new mod_perl arrived, let me know all update recommendations
6751   CPAN::Shell->r;
6752
6753 =back
6754
6755 =head2 Methods in the other Classes
6756
6757 The programming interface for the classes CPAN::Module,
6758 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6759 beta and partially even alpha. In the following paragraphs only those
6760 methods are documented that have proven useful over a longer time and
6761 thus are unlikely to change.
6762
6763 =over 4
6764
6765 =item CPAN::Author::as_glimpse()
6766
6767 Returns a one-line description of the author
6768
6769 =item CPAN::Author::as_string()
6770
6771 Returns a multi-line description of the author
6772
6773 =item CPAN::Author::email()
6774
6775 Returns the author's email address
6776
6777 =item CPAN::Author::fullname()
6778
6779 Returns the author's name
6780
6781 =item CPAN::Author::name()
6782
6783 An alias for fullname
6784
6785 =item CPAN::Bundle::as_glimpse()
6786
6787 Returns a one-line description of the bundle
6788
6789 =item CPAN::Bundle::as_string()
6790
6791 Returns a multi-line description of the bundle
6792
6793 =item CPAN::Bundle::clean()
6794
6795 Recursively runs the C<clean> method on all items contained in the bundle.
6796
6797 =item CPAN::Bundle::contains()
6798
6799 Returns a list of objects' IDs contained in a bundle. The associated
6800 objects may be bundles, modules or distributions.
6801
6802 =item CPAN::Bundle::force($method,@args)
6803
6804 Forces CPAN to perform a task that normally would have failed. Force
6805 takes as arguments a method name to be called and any number of
6806 additional arguments that should be passed to the called method. The
6807 internals of the object get the needed changes so that CPAN.pm does
6808 not refuse to take the action. The C<force> is passed recursively to
6809 all contained objects.
6810
6811 =item CPAN::Bundle::get()
6812
6813 Recursively runs the C<get> method on all items contained in the bundle
6814
6815 =item CPAN::Bundle::inst_file()
6816
6817 Returns the highest installed version of the bundle in either @INC or
6818 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6819 CPAN::Module::inst_file.
6820
6821 =item CPAN::Bundle::inst_version()
6822
6823 Like CPAN::Bundle::inst_file, but returns the $VERSION
6824
6825 =item CPAN::Bundle::uptodate()
6826
6827 Returns 1 if the bundle itself and all its members are uptodate.
6828
6829 =item CPAN::Bundle::install()
6830
6831 Recursively runs the C<install> method on all items contained in the bundle
6832
6833 =item CPAN::Bundle::make()
6834
6835 Recursively runs the C<make> method on all items contained in the bundle
6836
6837 =item CPAN::Bundle::readme()
6838
6839 Recursively runs the C<readme> method on all items contained in the bundle
6840
6841 =item CPAN::Bundle::test()
6842
6843 Recursively runs the C<test> method on all items contained in the bundle
6844
6845 =item CPAN::Distribution::as_glimpse()
6846
6847 Returns a one-line description of the distribution
6848
6849 =item CPAN::Distribution::as_string()
6850
6851 Returns a multi-line description of the distribution
6852
6853 =item CPAN::Distribution::clean()
6854
6855 Changes to the directory where the distribution has been unpacked and
6856 runs C<make clean> there.
6857
6858 =item CPAN::Distribution::containsmods()
6859
6860 Returns a list of IDs of modules contained in a distribution file.
6861 Only works for distributions listed in the 02packages.details.txt.gz
6862 file. This typically means that only the most recent version of a
6863 distribution is covered.
6864
6865 =item CPAN::Distribution::cvs_import()
6866
6867 Changes to the directory where the distribution has been unpacked and
6868 runs something like
6869
6870     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6871
6872 there.
6873
6874 =item CPAN::Distribution::dir()
6875
6876 Returns the directory into which this distribution has been unpacked.
6877
6878 =item CPAN::Distribution::force($method,@args)
6879
6880 Forces CPAN to perform a task that normally would have failed. Force
6881 takes as arguments a method name to be called and any number of
6882 additional arguments that should be passed to the called method. The
6883 internals of the object get the needed changes so that CPAN.pm does
6884 not refuse to take the action.
6885
6886 =item CPAN::Distribution::get()
6887
6888 Downloads the distribution from CPAN and unpacks it. Does nothing if
6889 the distribution has already been downloaded and unpacked within the
6890 current session.
6891
6892 =item CPAN::Distribution::install()
6893
6894 Changes to the directory where the distribution has been unpacked and
6895 runs the external command C<make install> there. If C<make> has not
6896 yet been run, it will be run first. A C<make test> will be issued in
6897 any case and if this fails, the install will be canceled. The
6898 cancellation can be avoided by letting C<force> run the C<install> for
6899 you.
6900
6901 =item CPAN::Distribution::isa_perl()
6902
6903 Returns 1 if this distribution file seems to be a perl distribution.
6904 Normally this is derived from the file name only, but the index from
6905 CPAN can contain a hint to achieve a return value of true for other
6906 filenames too.
6907
6908 =item CPAN::Distribution::look()
6909
6910 Changes to the directory where the distribution has been unpacked and
6911 opens a subshell there. Exiting the subshell returns.
6912
6913 =item CPAN::Distribution::make()
6914
6915 First runs the C<get> method to make sure the distribution is
6916 downloaded and unpacked. Changes to the directory where the
6917 distribution has been unpacked and runs the external commands C<perl
6918 Makefile.PL> and C<make> there.
6919
6920 =item CPAN::Distribution::prereq_pm()
6921
6922 Returns the hash reference that has been announced by a distribution
6923 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6924 attempt has been made to C<make> the distribution. Returns undef
6925 otherwise.
6926
6927 =item CPAN::Distribution::readme()
6928
6929 Downloads the README file associated with a distribution and runs it
6930 through the pager specified in C<$CPAN::Config->{pager}>.
6931
6932 =item CPAN::Distribution::perldoc()
6933
6934 Downloads the pod documentation of the file associated with a
6935 distribution (in html format) and runs it through the external
6936 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
6937 isn't available, it converts it to plain text with external
6938 command html2text and runs it through the pager specified
6939 in C<$CPAN::Config->{pager}>
6940
6941 =item CPAN::Distribution::test()
6942
6943 Changes to the directory where the distribution has been unpacked and
6944 runs C<make test> there.
6945
6946 =item CPAN::Distribution::uptodate()
6947
6948 Returns 1 if all the modules contained in the distribution are
6949 uptodate. Relies on containsmods.
6950
6951 =item CPAN::Index::force_reload()
6952
6953 Forces a reload of all indices.
6954
6955 =item CPAN::Index::reload()
6956
6957 Reloads all indices if they have been read more than
6958 C<$CPAN::Config->{index_expire}> days.
6959
6960 =item CPAN::InfoObj::dump()
6961
6962 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6963 inherit this method. It prints the data structure associated with an
6964 object. Useful for debugging. Note: the data structure is considered
6965 internal and thus subject to change without notice.
6966
6967 =item CPAN::Module::as_glimpse()
6968
6969 Returns a one-line description of the module
6970
6971 =item CPAN::Module::as_string()
6972
6973 Returns a multi-line description of the module
6974
6975 =item CPAN::Module::clean()
6976
6977 Runs a clean on the distribution associated with this module.
6978
6979 =item CPAN::Module::cpan_file()
6980
6981 Returns the filename on CPAN that is associated with the module.
6982
6983 =item CPAN::Module::cpan_version()
6984
6985 Returns the latest version of this module available on CPAN.
6986
6987 =item CPAN::Module::cvs_import()
6988
6989 Runs a cvs_import on the distribution associated with this module.
6990
6991 =item CPAN::Module::description()
6992
6993 Returns a 44 character description of this module. Only available for
6994 modules listed in The Module List (CPAN/modules/00modlist.long.html
6995 or 00modlist.long.txt.gz)
6996
6997 =item CPAN::Module::force($method,@args)
6998
6999 Forces CPAN to perform a task that normally would have failed. Force
7000 takes as arguments a method name to be called and any number of
7001 additional arguments that should be passed to the called method. The
7002 internals of the object get the needed changes so that CPAN.pm does
7003 not refuse to take the action.
7004
7005 =item CPAN::Module::get()
7006
7007 Runs a get on the distribution associated with this module.
7008
7009 =item CPAN::Module::inst_file()
7010
7011 Returns the filename of the module found in @INC. The first file found
7012 is reported just like perl itself stops searching @INC when it finds a
7013 module.
7014
7015 =item CPAN::Module::inst_version()
7016
7017 Returns the version number of the module in readable format.
7018
7019 =item CPAN::Module::install()
7020
7021 Runs an C<install> on the distribution associated with this module.
7022
7023 =item CPAN::Module::look()
7024
7025 Changes to the directory where the distribution associated with this
7026 module has been unpacked and opens a subshell there. Exiting the
7027 subshell returns.
7028
7029 =item CPAN::Module::make()
7030
7031 Runs a C<make> on the distribution associated with this module.
7032
7033 =item CPAN::Module::manpage_headline()
7034
7035 If module is installed, peeks into the module's manpage, reads the
7036 headline and returns it. Moreover, if the module has been downloaded
7037 within this session, does the equivalent on the downloaded module even
7038 if it is not installed.
7039
7040 =item CPAN::Module::readme()
7041
7042 Runs a C<readme> on the distribution associated with this module.
7043
7044 =item CPAN::Module::perldoc()
7045
7046 Runs a C<perldoc> on this module.
7047
7048 =item CPAN::Module::test()
7049
7050 Runs a C<test> on the distribution associated with this module.
7051
7052 =item CPAN::Module::uptodate()
7053
7054 Returns 1 if the module is installed and up-to-date.
7055
7056 =item CPAN::Module::userid()
7057
7058 Returns the author's ID of the module.
7059
7060 =back
7061
7062 =head2 Cache Manager
7063
7064 Currently the cache manager only keeps track of the build directory
7065 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
7066 deletes complete directories below C<build_dir> as soon as the size of
7067 all directories there gets bigger than $CPAN::Config->{build_cache}
7068 (in MB). The contents of this cache may be used for later
7069 re-installations that you intend to do manually, but will never be
7070 trusted by CPAN itself. This is due to the fact that the user might
7071 use these directories for building modules on different architectures.
7072
7073 There is another directory ($CPAN::Config->{keep_source_where}) where
7074 the original distribution files are kept. This directory is not
7075 covered by the cache manager and must be controlled by the user. If
7076 you choose to have the same directory as build_dir and as
7077 keep_source_where directory, then your sources will be deleted with
7078 the same fifo mechanism.
7079
7080 =head2 Bundles
7081
7082 A bundle is just a perl module in the namespace Bundle:: that does not
7083 define any functions or methods. It usually only contains documentation.
7084
7085 It starts like a perl module with a package declaration and a $VERSION
7086 variable. After that the pod section looks like any other pod with the
7087 only difference being that I<one special pod section> exists starting with
7088 (verbatim):
7089
7090         =head1 CONTENTS
7091
7092 In this pod section each line obeys the format
7093
7094         Module_Name [Version_String] [- optional text]
7095
7096 The only required part is the first field, the name of a module
7097 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
7098 of the line is optional. The comment part is delimited by a dash just
7099 as in the man page header.
7100
7101 The distribution of a bundle should follow the same convention as
7102 other distributions.
7103
7104 Bundles are treated specially in the CPAN package. If you say 'install
7105 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
7106 the modules in the CONTENTS section of the pod. You can install your
7107 own Bundles locally by placing a conformant Bundle file somewhere into
7108 your @INC path. The autobundle() command which is available in the
7109 shell interface does that for you by including all currently installed
7110 modules in a snapshot bundle file.
7111
7112 =head2 Prerequisites
7113
7114 If you have a local mirror of CPAN and can access all files with
7115 "file:" URLs, then you only need a perl better than perl5.003 to run
7116 this module. Otherwise Net::FTP is strongly recommended. LWP may be
7117 required for non-UNIX systems or if your nearest CPAN site is
7118 associated with a URL that is not C<ftp:>.
7119
7120 If you have neither Net::FTP nor LWP, there is a fallback mechanism
7121 implemented for an external ftp command or for an external lynx
7122 command.
7123
7124 =head2 Finding packages and VERSION
7125
7126 This module presumes that all packages on CPAN
7127
7128 =over 2
7129
7130 =item *
7131
7132 declare their $VERSION variable in an easy to parse manner. This
7133 prerequisite can hardly be relaxed because it consumes far too much
7134 memory to load all packages into the running program just to determine
7135 the $VERSION variable. Currently all programs that are dealing with
7136 version use something like this
7137
7138     perl -MExtUtils::MakeMaker -le \
7139         'print MM->parse_version(shift)' filename
7140
7141 If you are author of a package and wonder if your $VERSION can be
7142 parsed, please try the above method.
7143
7144 =item *
7145
7146 come as compressed or gzipped tarfiles or as zip files and contain a
7147 Makefile.PL (well, we try to handle a bit more, but without much
7148 enthusiasm).
7149
7150 =back
7151
7152 =head2 Debugging
7153
7154 The debugging of this module is a bit complex, because we have
7155 interferences of the software producing the indices on CPAN, of the
7156 mirroring process on CPAN, of packaging, of configuration, of
7157 synchronicity, and of bugs within CPAN.pm.
7158
7159 For code debugging in interactive mode you can try "o debug" which
7160 will list options for debugging the various parts of the code. You
7161 should know that "o debug" has built-in completion support.
7162
7163 For data debugging there is the C<dump> command which takes the same
7164 arguments as make/test/install and outputs the object's Data::Dumper
7165 dump.
7166
7167 =head2 Floppy, Zip, Offline Mode
7168
7169 CPAN.pm works nicely without network too. If you maintain machines
7170 that are not networked at all, you should consider working with file:
7171 URLs. Of course, you have to collect your modules somewhere first. So
7172 you might use CPAN.pm to put together all you need on a networked
7173 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
7174 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
7175 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
7176 with this floppy. See also below the paragraph about CD-ROM support.
7177
7178 =head1 CONFIGURATION
7179
7180 When the CPAN module is used for the first time, a configuration
7181 dialog tries to determine a couple of site specific options. The
7182 result of the dialog is stored in a hash reference C< $CPAN::Config >
7183 in a file CPAN/Config.pm.
7184
7185 The default values defined in the CPAN/Config.pm file can be
7186 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
7187 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
7188 added to the search path of the CPAN module before the use() or
7189 require() statements.
7190
7191 The configuration dialog can be started any time later again by
7192 issuing the command C< o conf init > in the CPAN shell.
7193
7194 Currently the following keys in the hash reference $CPAN::Config are
7195 defined:
7196
7197   build_cache        size of cache for directories to build modules
7198   build_dir          locally accessible directory to build modules
7199   index_expire       after this many days refetch index files
7200   cache_metadata     use serializer to cache metadata
7201   cpan_home          local directory reserved for this package
7202   dontload_hash      anonymous hash: modules in the keys will not be
7203                      loaded by the CPAN::has_inst() routine
7204   gzip               location of external program gzip
7205   histfile           file to maintain history between sessions
7206   histsize           maximum number of lines to keep in histfile
7207   inactivity_timeout breaks interactive Makefile.PLs after this
7208                      many seconds inactivity. Set to 0 to never break.
7209   inhibit_startup_message
7210                      if true, does not print the startup message
7211   keep_source_where  directory in which to keep the source (if we do)
7212   make               location of external make program
7213   make_arg           arguments that should always be passed to 'make'
7214   make_install_make_command
7215                      the make command for running 'make install', for
7216                      example 'sudo make'
7217   make_install_arg   same as make_arg for 'make install'
7218   makepl_arg         arguments passed to 'perl Makefile.PL'
7219   pager              location of external program more (or any pager)
7220   prerequisites_policy
7221                      what to do if you are missing module prerequisites
7222                      ('follow' automatically, 'ask' me, or 'ignore')
7223   proxy_user         username for accessing an authenticating proxy
7224   proxy_pass         password for accessing an authenticating proxy
7225   scan_cache         controls scanning of cache ('atstart' or 'never')
7226   tar                location of external program tar
7227   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
7228                      (and nonsense for characters outside latin range)
7229   unzip              location of external program unzip
7230   urllist            arrayref to nearby CPAN sites (or equivalent locations)
7231   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
7232   ftp_proxy,      }  the three usual variables for configuring
7233     http_proxy,   }  proxy requests. Both as CPAN::Config variables
7234     no_proxy      }  and as environment variables configurable.
7235
7236 You can set and query each of these options interactively in the cpan
7237 shell with the command set defined within the C<o conf> command:
7238
7239 =over 2
7240
7241 =item C<o conf E<lt>scalar optionE<gt>>
7242
7243 prints the current value of the I<scalar option>
7244
7245 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
7246
7247 Sets the value of the I<scalar option> to I<value>
7248
7249 =item C<o conf E<lt>list optionE<gt>>
7250
7251 prints the current value of the I<list option> in MakeMaker's
7252 neatvalue format.
7253
7254 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
7255
7256 shifts or pops the array in the I<list option> variable
7257
7258 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
7259
7260 works like the corresponding perl commands.
7261
7262 =back
7263
7264 =head2 Note on urllist parameter's format
7265
7266 urllist parameters are URLs according to RFC 1738. We do a little
7267 guessing if your URL is not compliant, but if you have problems with
7268 file URLs, please try the correct format. Either:
7269
7270     file://localhost/whatever/ftp/pub/CPAN/
7271
7272 or
7273
7274     file:///home/ftp/pub/CPAN/
7275
7276 =head2 urllist parameter has CD-ROM support
7277
7278 The C<urllist> parameter of the configuration table contains a list of
7279 URLs that are to be used for downloading. If the list contains any
7280 C<file> URLs, CPAN always tries to get files from there first. This
7281 feature is disabled for index files. So the recommendation for the
7282 owner of a CD-ROM with CPAN contents is: include your local, possibly
7283 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
7284
7285   o conf urllist push file://localhost/CDROM/CPAN
7286
7287 CPAN.pm will then fetch the index files from one of the CPAN sites
7288 that come at the beginning of urllist. It will later check for each
7289 module if there is a local copy of the most recent version.
7290
7291 Another peculiarity of urllist is that the site that we could
7292 successfully fetch the last file from automatically gets a preference
7293 token and is tried as the first site for the next request. So if you
7294 add a new site at runtime it may happen that the previously preferred
7295 site will be tried another time. This means that if you want to disallow
7296 a site for the next transfer, it must be explicitly removed from
7297 urllist.
7298
7299 =head1 SECURITY
7300
7301 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
7302 install foreign, unmasked, unsigned code on your machine. We compare
7303 to a checksum that comes from the net just as the distribution file
7304 itself. If somebody has managed to tamper with the distribution file,
7305 they may have as well tampered with the CHECKSUMS file. Future
7306 development will go towards strong authentication.
7307
7308 =head1 EXPORT
7309
7310 Most functions in package CPAN are exported per default. The reason
7311 for this is that the primary use is intended for the cpan shell or for
7312 one-liners.
7313
7314 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
7315
7316 Populating a freshly installed perl with my favorite modules is pretty
7317 easy if you maintain a private bundle definition file. To get a useful
7318 blueprint of a bundle definition file, the command autobundle can be used
7319 on the CPAN shell command line. This command writes a bundle definition
7320 file for all modules that are installed for the currently running perl
7321 interpreter. It's recommended to run this command only once and from then
7322 on maintain the file manually under a private name, say
7323 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
7324
7325     cpan> install Bundle::my_bundle
7326
7327 then answer a few questions and then go out for a coffee.
7328
7329 Maintaining a bundle definition file means keeping track of two
7330 things: dependencies and interactivity. CPAN.pm sometimes fails on
7331 calculating dependencies because not all modules define all MakeMaker
7332 attributes correctly, so a bundle definition file should specify
7333 prerequisites as early as possible. On the other hand, it's a bit
7334 annoying that many distributions need some interactive configuring. So
7335 what I try to accomplish in my private bundle file is to have the
7336 packages that need to be configured early in the file and the gentle
7337 ones later, so I can go out after a few minutes and leave CPAN.pm
7338 untended.
7339
7340 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
7341
7342 Thanks to Graham Barr for contributing the following paragraphs about
7343 the interaction between perl, and various firewall configurations. For
7344 further information on firewalls, it is recommended to consult the
7345 documentation that comes with the ncftp program. If you are unable to
7346 go through the firewall with a simple Perl setup, it is very likely
7347 that you can configure ncftp so that it works for your firewall.
7348
7349 =head2 Three basic types of firewalls
7350
7351 Firewalls can be categorized into three basic types.
7352
7353 =over 4
7354
7355 =item http firewall
7356
7357 This is where the firewall machine runs a web server and to access the
7358 outside world you must do it via the web server. If you set environment
7359 variables like http_proxy or ftp_proxy to a values beginning with http://
7360 or in your web browser you have to set proxy information then you know
7361 you are running an http firewall.
7362
7363 To access servers outside these types of firewalls with perl (even for
7364 ftp) you will need to use LWP.
7365
7366 =item ftp firewall
7367
7368 This where the firewall machine runs an ftp server. This kind of
7369 firewall will only let you access ftp servers outside the firewall.
7370 This is usually done by connecting to the firewall with ftp, then
7371 entering a username like "user@outside.host.com"
7372
7373 To access servers outside these type of firewalls with perl you
7374 will need to use Net::FTP.
7375
7376 =item One way visibility
7377
7378 I say one way visibility as these firewalls try to make themselves look
7379 invisible to the users inside the firewall. An FTP data connection is
7380 normally created by sending the remote server your IP address and then
7381 listening for the connection. But the remote server will not be able to
7382 connect to you because of the firewall. So for these types of firewall
7383 FTP connections need to be done in a passive mode.
7384
7385 There are two that I can think off.
7386
7387 =over 4
7388
7389 =item SOCKS
7390
7391 If you are using a SOCKS firewall you will need to compile perl and link
7392 it with the SOCKS library, this is what is normally called a 'socksified'
7393 perl. With this executable you will be able to connect to servers outside
7394 the firewall as if it is not there.
7395
7396 =item IP Masquerade
7397
7398 This is the firewall implemented in the Linux kernel, it allows you to
7399 hide a complete network behind one IP address. With this firewall no
7400 special compiling is needed as you can access hosts directly.
7401
7402 For accessing ftp servers behind such firewalls you may need to set
7403 the environment variable C<FTP_PASSIVE> to a true value, e.g.
7404
7405     env FTP_PASSIVE=1 perl -MCPAN -eshell
7406
7407 or
7408
7409     perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
7410
7411
7412 =back
7413
7414 =back
7415
7416 =head2 Configuring lynx or ncftp for going through a firewall
7417
7418 If you can go through your firewall with e.g. lynx, presumably with a
7419 command such as
7420
7421     /usr/local/bin/lynx -pscott:tiger
7422
7423 then you would configure CPAN.pm with the command
7424
7425     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7426
7427 That's all. Similarly for ncftp or ftp, you would configure something
7428 like
7429
7430     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7431
7432 Your mileage may vary...
7433
7434 =head1 Cryptographically signed modules
7435
7436 Since release 1.77 CPAN.pm has been able to verify cryptographically
7437 signed module distributions using Module::Signature.  The CPAN modules
7438 can be signed by their authors, thus giving more security.  The simple
7439 unsigned MD5 checksums that were used before by CPAN protect mainly
7440 against accidental file corruption.
7441
7442 You will need to have Module::Signature installed, which in turn
7443 requires that you have at least one of Crypt::OpenPGP module or the
7444 command-line F<gpg> tool installed.
7445
7446 You will also need to be able to connect over the Internet to the public
7447 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
7448
7449 =head1 FAQ
7450
7451 =over 4
7452
7453 =item 1)
7454
7455 I installed a new version of module X but CPAN keeps saying,
7456 I have the old version installed
7457
7458 Most probably you B<do> have the old version installed. This can
7459 happen if a module installs itself into a different directory in the
7460 @INC path than it was previously installed. This is not really a
7461 CPAN.pm problem, you would have the same problem when installing the
7462 module manually. The easiest way to prevent this behaviour is to add
7463 the argument C<UNINST=1> to the C<make install> call, and that is why
7464 many people add this argument permanently by configuring
7465
7466   o conf make_install_arg UNINST=1
7467
7468 =item 2)
7469
7470 So why is UNINST=1 not the default?
7471
7472 Because there are people who have their precise expectations about who
7473 may install where in the @INC path and who uses which @INC array. In
7474 fine tuned environments C<UNINST=1> can cause damage.
7475
7476 =item 3)
7477
7478 I want to clean up my mess, and install a new perl along with
7479 all modules I have. How do I go about it?
7480
7481 Run the autobundle command for your old perl and optionally rename the
7482 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7483 with the Configure option prefix, e.g.
7484
7485     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7486
7487 Install the bundle file you produced in the first step with something like
7488
7489     cpan> install Bundle::mybundle
7490
7491 and you're done.
7492
7493 =item 4)
7494
7495 When I install bundles or multiple modules with one command
7496 there is too much output to keep track of.
7497
7498 You may want to configure something like
7499
7500   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7501   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7502
7503 so that STDOUT is captured in a file for later inspection.
7504
7505
7506 =item 5)
7507
7508 I am not root, how can I install a module in a personal directory?
7509
7510 First of all, you will want to use your own configuration, not the one
7511 that your root user installed. The following command sequence is a
7512 possible approach:
7513
7514     % mkdir -p $HOME/.cpan/CPAN
7515     % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
7516     % cpan
7517     [...answer all questions...]
7518
7519 You will most probably like something like this:
7520
7521   o conf makepl_arg "LIB=~/myperl/lib \
7522                     INSTALLMAN1DIR=~/myperl/man/man1 \
7523                     INSTALLMAN3DIR=~/myperl/man/man3"
7524
7525 You can make this setting permanent like all C<o conf> settings with
7526 C<o conf commit>.
7527
7528 You will have to add ~/myperl/man to the MANPATH environment variable
7529 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7530 including
7531
7532   use lib "$ENV{HOME}/myperl/lib";
7533
7534 or setting the PERL5LIB environment variable.
7535
7536 Another thing you should bear in mind is that the UNINST parameter
7537 should never be set if you are not root.
7538
7539 =item 6)
7540
7541 How to get a package, unwrap it, and make a change before building it?
7542
7543   look Sybase::Sybperl
7544
7545 =item 7)
7546
7547 I installed a Bundle and had a couple of fails. When I
7548 retried, everything resolved nicely. Can this be fixed to work
7549 on first try?
7550
7551 The reason for this is that CPAN does not know the dependencies of all
7552 modules when it starts out. To decide about the additional items to
7553 install, it just uses data found in the generated Makefile. An
7554 undetected missing piece breaks the process. But it may well be that
7555 your Bundle installs some prerequisite later than some depending item
7556 and thus your second try is able to resolve everything. Please note,
7557 CPAN.pm does not know the dependency tree in advance and cannot sort
7558 the queue of things to install in a topologically correct order. It
7559 resolves perfectly well IFF all modules declare the prerequisites
7560 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7561 fail and you need to install often, it is recommended to sort the Bundle
7562 definition file manually. It is planned to improve the metadata
7563 situation for dependencies on CPAN in general, but this will still
7564 take some time.
7565
7566 =item 8)
7567
7568 In our intranet we have many modules for internal use. How
7569 can I integrate these modules with CPAN.pm but without uploading
7570 the modules to CPAN?
7571
7572 Have a look at the CPAN::Site module.
7573
7574 =item 9)
7575
7576 When I run CPAN's shell, I get error msg about line 1 to 4,
7577 setting meta input/output via the /etc/inputrc file.
7578
7579 Some versions of readline are picky about capitalization in the
7580 /etc/inputrc file and specifically RedHat 6.2 comes with a
7581 /etc/inputrc that contains the word C<on> in lowercase. Change the
7582 occurrences of C<on> to C<On> and the bug should disappear.
7583
7584 =item 10)
7585
7586 Some authors have strange characters in their names.
7587
7588 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7589 expecting ISO-8859-1 charset, a converter can be activated by setting
7590 term_is_latin to a true value in your config file. One way of doing so
7591 would be
7592
7593     cpan> ! $CPAN::Config->{term_is_latin}=1
7594
7595 Extended support for converters will be made available as soon as perl
7596 becomes stable with regard to charset issues.
7597
7598 =item 11)
7599
7600 When an install fails for some reason and then I correct the error
7601 condition and retry, CPAN.pm refuses to install the module, saying
7602 C<Already tried without success>.
7603
7604 Use the force pragma like so
7605
7606   force install Foo::Bar
7607
7608 This does a bit more than really needed because it untars the
7609 distribution again and runs make and test and only then install.
7610
7611 Or you can use
7612
7613   look Foo::Bar
7614
7615 and then 'make install' directly in the subshell.
7616
7617 Or you leave the CPAN shell and start it again.
7618
7619 For the really curious, by accessing internals directly, you I<could>
7620
7621   ! delete  CPAN::Shell->expand("Distribution", \
7622     CPAN::Shell->expand("Module","Foo::Bar") \
7623     ->{RO}{CPAN_FILE})->{install}
7624
7625 but this is neither guaranteed to work in the future nor is it a
7626 decent command.
7627
7628 =back
7629
7630 =head1 BUGS
7631
7632 We should give coverage for B<all> of the CPAN and not just the PAUSE
7633 part, right? In this discussion CPAN and PAUSE have become equal --
7634 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7635 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7636
7637 Future development should be directed towards a better integration of
7638 the other parts.
7639
7640 If a Makefile.PL requires special customization of libraries, prompts
7641 the user for special input, etc. then you may find CPAN is not able to
7642 build the distribution. In that case, you should attempt the
7643 traditional method of building a Perl module package from a shell.
7644
7645 =head1 AUTHOR
7646
7647 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7648
7649 =head1 TRANSLATIONS
7650
7651 Kawai,Takanori provides a Japanese translation of this manpage at
7652 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7653
7654 =head1 SEE ALSO
7655
7656 perl(1), CPAN::Nox(3)
7657
7658 =cut
7659