lib/CPAN.pm

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