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