lib/CPAN.pm

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