lib/CPAN.pm

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