lib/CPAN.pm

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