lib/CPAN.pm

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