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