lib/CPAN.pm

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