lib/CPAN.pm

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