lib/CPAN.pm

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