lib/CPAN.pm

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