lib/CPAN.pm

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