lib/CPAN.pm

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