lib/CPAN.pm

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