lib/CPAN.pm

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