lib/CPAN.pm

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