lib/CPAN.pm

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