lib/CPAN.pm

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