lib/CPAN.pm

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