lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_54';
   5 $CPAN::VERSION = eval $CPAN::VERSION;
   6
   7 use CPAN::HandleConfig;
   8 use CPAN::Version;
   9 use CPAN::Debug;
  10 use CPAN::Queue;
  11 use CPAN::Tarzip;
  12 use Carp ();
  13 use Config ();
  14 use Cwd ();
  15 use DirHandle ();
  16 use Exporter ();
  17 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
  18                                     # 5.005_04 does not work without
  19                                     # this
  20 use File::Basename ();
  21 use File::Copy ();
  22 use File::Find;
  23 use File::Path ();
  24 use File::Spec ();
  25 use FileHandle ();
  26 use Safe ();
  27 use Sys::Hostname qw(hostname);
  28 use Text::ParseWords ();
  29 use Text::Wrap ();
  30
  31 # we need to run chdir all over and we would get at wrong libraries
  32 # there
  33 BEGIN {
  34     if (File::Spec->can("rel2abs")) {
  35         for my $inc (@INC) {
  36             $inc = File::Spec->rel2abs($inc);
  37         }
  38     }
  39 }
  40 no lib ".";
  41
  42 require Mac::BuildTools if $^O eq 'MacOS';
  43
  44 END { $CPAN::End++; &cleanup; }
  45
  46 $CPAN::Signal ||= 0;
  47 $CPAN::Frontend ||= "CPAN::Shell";
  48 unless (@CPAN::Defaultsites){
  49     @CPAN::Defaultsites = map {
  50         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  51     }
  52         "http://www.perl.org/CPAN/",
  53             "ftp://ftp.perl.org/pub/CPAN/";
  54 }
  55 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  56 $CPAN::Perl ||= CPAN::find_perl();
  57 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  58 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
  59
  60
  61 use vars qw($VERSION @EXPORT $AUTOLOAD
  62             $DEBUG $META $HAS_USABLE $term
  63             $GOTOSHELL
  64             $Signal $Suppress_readline $Frontend
  65             @Defaultsites $Have_warned $Defaultdocs $Defaultrecent
  66             $Be_Silent
  67             $autoload_recursion
  68            );
  69
  70 @CPAN::ISA = qw(CPAN::Debug Exporter);
  71
  72 # note that these functions live in CPAN::Shell and get executed via
  73 # AUTOLOAD when called directly
  74 @EXPORT = qw(
  75              autobundle
  76              bundle
  77              clean
  78              cvs_import
  79              expand
  80              force
  81              get
  82              install
  83              make
  84              mkmyconfig
  85              notest
  86              perldoc
  87              readme
  88              recent
  89              recompile
  90              shell
  91              test
  92              upgrade
  93             );
  94
  95 sub soft_chdir_with_alternatives ($);
  96
  97 {
  98     $autoload_recursion ||= 0;
  99
 100     #-> sub CPAN::AUTOLOAD ;
 101     sub AUTOLOAD {
 102         $autoload_recursion++;
 103         my($l) = $AUTOLOAD;
 104         $l =~ s/.*:://;
 105         if ($CPAN::Signal) {
 106             warn "Refusing to autoload '$l' while signal pending";
 107             $autoload_recursion--;
 108             return;
 109         }
 110         if ($autoload_recursion > 1) {
 111             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 112             warn "Refusing to autoload $fullcommand in recursion\n";
 113             $autoload_recursion--;
 114             return;
 115         }
 116         my(%export);
 117         @export{@EXPORT} = '';
 118         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 119         if (exists $export{$l}){
 120             CPAN::Shell->$l(@_);
 121         } else {
 122             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 123                 qq{Type ? for help.\n});
 124         }
 125         $autoload_recursion--;
 126     }
 127 }
 128
 129 #-> sub CPAN::shell ;
 130 sub shell {
 131     my($self) = @_;
 132     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 133     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 134
 135     my $oprompt = shift || CPAN::Prompt->new;
 136     my $prompt = $oprompt;
 137     my $commandline = shift || "";
 138     $CPAN::CurrentCommandId ||= 1;
 139
 140     local($^W) = 1;
 141     unless ($Suppress_readline) {
 142         require Term::ReadLine;
 143         if (! $term
 144             or
 145             $term->ReadLine eq "Term::ReadLine::Stub"
 146            ) {
 147             $term = Term::ReadLine->new('CPAN Monitor');
 148         }
 149         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 150             my $attribs = $term->Attribs;
 151              $attribs->{attempted_completion_function} = sub {
 152                  &CPAN::Complete::gnu_cpl;
 153              }
 154         } else {
 155             $readline::rl_completion_function =
 156                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 157         }
 158         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 159             unless ($term->can("AddHistory")) {
 160                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 161                 last;
 162             }
 163             my($fh) = FileHandle->new;
 164             open $fh, "<$histfile" or last;
 165             local $/ = "\n";
 166             while (<$fh>) {
 167                 chomp;
 168                 $term->AddHistory($_);
 169             }
 170             close $fh;
 171         }}
 172         for ($CPAN::Config->{term_ornaments}) { # alias
 173             local $Term::ReadLine::termcap_nowarn = 1;
 174             $term->ornaments($_) if defined;
 175         }
 176         # $term->OUT is autoflushed anyway
 177         my $odef = select STDERR;
 178         $| = 1;
 179         select STDOUT;
 180         $| = 1;
 181         select $odef;
 182     }
 183
 184     # no strict; # I do not recall why no strict was here (2000-09-03)
 185     $META->checklock();
 186     my @cwd = grep { defined $_ and length $_ }
 187         CPAN::anycwd(),
 188               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 189                     File::Spec->rootdir();
 190     my $try_detect_readline;
 191     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 192     my $rl_avail = $Suppress_readline ? "suppressed" :
 193         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 194             "available (try 'install Bundle::CPAN')";
 195
 196     unless ($CPAN::Config->{'inhibit_startup_message'}){
 197         $CPAN::Frontend->myprint(
 198                                  sprintf qq{
 199 cpan shell -- CPAN exploration and modules installation (v%s)
 200 ReadLine support %s
 201
 202 },
 203                                  $CPAN::VERSION,
 204                                  $rl_avail
 205                                 )
 206     }
 207     my($continuation) = "";
 208     my $last_term_ornaments;
 209   SHELLCOMMAND: while () {
 210         if ($Suppress_readline) {
 211             print $prompt;
 212             last SHELLCOMMAND unless defined ($_ = <> );
 213             chomp;
 214         } else {
 215             last SHELLCOMMAND unless
 216                 defined ($_ = $term->readline($prompt, $commandline));
 217         }
 218         $_ = "$continuation$_" if $continuation;
 219         s/^\s+//;
 220         next SHELLCOMMAND if /^$/;
 221         $_ = 'h' if /^\s*\?/;
 222         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 223             last SHELLCOMMAND;
 224         } elsif (s/\\$//s) {
 225             chomp;
 226             $continuation = $_;
 227             $prompt = "    > ";
 228         } elsif (/^\!/) {
 229             s/^\!//;
 230             my($eval) = $_;
 231             package CPAN::Eval;
 232             use strict;
 233             use vars qw($import_done);
 234             CPAN->import(':DEFAULT') unless $import_done++;
 235             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 236             eval($eval);
 237             warn $@ if $@;
 238             $continuation = "";
 239             $prompt = $oprompt;
 240         } elsif (/./) {
 241             my(@line);
 242             eval { @line = Text::ParseWords::shellwords($_) };
 243             warn($@), next SHELLCOMMAND if $@;
 244             warn("Text::Parsewords could not parse the line [$_]"),
 245                 next SHELLCOMMAND unless @line;
 246             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 247             my $command = shift @line;
 248             eval { CPAN::Shell->$command(@line) };
 249             warn $@ if $@;
 250             if ($command =~ /^(make|test|install|force|notest|clean|upgrade)$/) {
 251                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 252             }
 253             soft_chdir_with_alternatives(\@cwd);
 254             $CPAN::Frontend->myprint("\n");
 255             $continuation = "";
 256             $CPAN::CurrentCommandId++;
 257             $prompt = $oprompt;
 258         }
 259     } continue {
 260       $commandline = ""; # I do want to be able to pass a default to
 261                          # shell, but on the second command I see no
 262                          # use in that
 263       $Signal=0;
 264       CPAN::Queue->nullify_queue;
 265       if ($try_detect_readline) {
 266         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 267             ||
 268             $CPAN::META->has_inst("Term::ReadLine::Perl")
 269            ) {
 270             delete $INC{"Term/ReadLine.pm"};
 271             my $redef = 0;
 272             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 273             require Term::ReadLine;
 274             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 275                                      "Term::ReadLine redefined\n");
 276             $GOTOSHELL = 1;
 277         }
 278       }
 279       if ($term and $term->can("ornaments")) {
 280           for ($CPAN::Config->{term_ornaments}) { # alias
 281               if (defined $_) {
 282                   if (not defined $last_term_ornaments
 283                       or $_ != $last_term_ornaments
 284                      ) {
 285                       local $Term::ReadLine::termcap_nowarn = 1;
 286                       $term->ornaments($_);
 287                       $last_term_ornaments = $_;
 288                   }
 289               } else {
 290                   undef $last_term_ornaments;
 291               }
 292           }
 293       }
 294       if ($CPAN::DEBUG && $CPAN::DEBUG & $CPAN::DEBUG{CPAN}) {
 295           # debugging 'incommandcolor': should always be off at the end of a command
 296           # (incommandcolor is used to detect recursive dependencies)
 297           for my $class (qw(Module Distribution)) {
 298               for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 299                   next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 300                   CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 301                   delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 302               }
 303           }
 304       }
 305       if ($GOTOSHELL) {
 306           $GOTOSHELL = 0; # not too often
 307           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 308           @_ = ($oprompt,"");
 309           goto &shell;
 310       }
 311     }
 312     soft_chdir_with_alternatives(\@cwd);
 313 }
 314
 315 sub soft_chdir_with_alternatives ($) {
 316     my($cwd) = @_;
 317     unless (@$cwd) {
 318         my $root = File::Spec->rootdir();
 319         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 320 Trying '$root' as temporary haven.
 321 });
 322         push @$cwd, $root;
 323     }
 324     while () {
 325         if (chdir $cwd->[0]) {
 326             return;
 327         } else {
 328             if (@$cwd>1) {
 329                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 330 Trying to chdir to "$cwd->[1]" instead.
 331 });
 332                 shift @$cwd;
 333             } else {
 334                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 335             }
 336         }
 337     }
 338 }
 339
 340 # CPAN::_yaml_loadfile
 341 sub _yaml_loadfile {
 342     my($self,$local_file) = @_;
 343     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 344     if ($CPAN::META->has_inst($yaml_module)) {
 345         my $code = UNIVERSAL::can($yaml_module, "LoadFile");
 346         my $yaml;
 347         eval { $yaml = $code->($local_file); };
 348         if ($@) {
 349             $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
 350                                    "  $local_file\n".
 351                                    "with $yaml_module the following error was encountered:\n".
 352                                    "  $@\n"
 353                                   );
 354         }
 355         return $yaml;
 356     } else {
 357         $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
 358     }
 359     return +{};
 360 }
 361
 362 package CPAN::CacheMgr;
 363 use strict;
 364 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 365 use File::Find;
 366
 367 package CPAN::FTP;
 368 use strict;
 369 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 370 @CPAN::FTP::ISA = qw(CPAN::Debug);
 371
 372 package CPAN::LWP::UserAgent;
 373 use strict;
 374 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 375 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 376
 377 package CPAN::Complete;
 378 use strict;
 379 @CPAN::Complete::ISA = qw(CPAN::Debug);
 380 @CPAN::Complete::COMMANDS = sort qw(
 381                                     ! a b d h i m o q r u
 382                                     autobundle
 383                                     clean
 384                                     cvs_import
 385                                     dump
 386                                     force
 387                                     install
 388                                     look
 389                                     ls
 390                                     make
 391                                     mkmyconfig
 392                                     notest
 393                                     perldoc
 394                                     readme
 395                                     recent
 396                                     recompile
 397                                     reload
 398                                     scripts
 399                                     test
 400                                     upgrade
 401 );
 402
 403 package CPAN::Index;
 404 use strict;
 405 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
 406 @CPAN::Index::ISA = qw(CPAN::Debug);
 407 $LAST_TIME ||= 0;
 408 $DATE_OF_03 ||= 0;
 409 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 410 sub PROTOCOL { 2.0 }
 411
 412 package CPAN::InfoObj;
 413 use strict;
 414 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 415
 416 package CPAN::Author;
 417 use strict;
 418 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 419
 420 package CPAN::Distribution;
 421 use strict;
 422 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 423
 424 package CPAN::Bundle;
 425 use strict;
 426 @CPAN::Bundle::ISA = qw(CPAN::Module);
 427
 428 package CPAN::Module;
 429 use strict;
 430 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 431
 432 package CPAN::Exception::RecursiveDependency;
 433 use strict;
 434 use overload '""' => "as_string";
 435
 436 sub new {
 437     my($class) = shift;
 438     my($deps) = shift;
 439     my @deps;
 440     my %seen;
 441     for my $dep (@$deps) {
 442         push @deps, $dep;
 443         last if $seen{$dep}++;
 444     }
 445     bless { deps => \@deps }, $class;
 446 }
 447
 448 sub as_string {
 449     my($self) = shift;
 450     "\nRecursive dependency detected:\n    " .
 451         join("\n => ", @{$self->{deps}}) .
 452             ".\nCannot continue.\n";
 453 }
 454
 455 package CPAN::Prompt; use overload '""' => "as_string";
 456 use vars qw($prompt);
 457 $prompt = "cpan> ";
 458 $CPAN::CurrentCommandId ||= 0;
 459 sub new {
 460     bless {}, shift;
 461 }
 462 sub as_string {
 463     if ($CPAN::Config->{commandnumber_in_prompt}) {
 464         sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
 465     } else {
 466         "cpan> ";
 467     }
 468 }
 469
 470 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 471 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 472 # planned are things like age or quality
 473 sub new {
 474     my($class,%args) = @_;
 475     bless {
 476            %args
 477           }, $class;
 478 }
 479 sub as_string {
 480     my($self) = @_;
 481     $self->text;
 482 }
 483 sub text {
 484     my($self,$set) = @_;
 485     if (defined $set) {
 486         $self->{TEXT} = $set;
 487     }
 488     $self->{TEXT};
 489 }
 490
 491 package CPAN::Distrostatus;
 492 use overload '""' => "as_string",
 493     fallback => 1;
 494 sub new {
 495     my($class,$arg) = @_;
 496     bless {
 497            TEXT => $arg,
 498            FAILED => substr($arg,0,2) eq "NO",
 499            COMMANDID => $CPAN::CurrentCommandId,
 500           }, $class;
 501 }
 502 sub commandid { shift->{COMMANDID} }
 503 sub failed { shift->{FAILED} }
 504 sub text {
 505     my($self,$set) = @_;
 506     if (defined $set) {
 507         $self->{TEXT} = $set;
 508     }
 509     $self->{TEXT};
 510 }
 511 sub as_string {
 512     my($self) = @_;
 513     $self->text;
 514 }
 515
 516 package CPAN::Shell;
 517 use strict;
 518 use vars qw(
 519             $ADVANCED_QUERY
 520             $AUTOLOAD
 521             $COLOR_REGISTERED
 522             $autoload_recursion
 523             $reload
 524             @ISA
 525            );
 526 @CPAN::Shell::ISA = qw(CPAN::Debug);
 527 $COLOR_REGISTERED ||= 0;
 528
 529 {
 530     # $GLOBAL_AUTOLOAD_RECURSION = 12;
 531     $autoload_recursion   ||= 0;
 532
 533     #-> sub CPAN::Shell::AUTOLOAD ;
 534     sub AUTOLOAD {
 535         $autoload_recursion++;
 536         my($l) = $AUTOLOAD;
 537         my $class = shift(@_);
 538         # warn "autoload[$l] class[$class]";
 539         $l =~ s/.*:://;
 540         if ($CPAN::Signal) {
 541             warn "Refusing to autoload '$l' while signal pending";
 542             $autoload_recursion--;
 543             return;
 544         }
 545         if ($autoload_recursion > 1) {
 546             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 547             warn "Refusing to autoload $fullcommand in recursion\n";
 548             $autoload_recursion--;
 549             return;
 550         }
 551         if ($l =~ /^w/) {
 552             # XXX needs to be reconsidered
 553             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 554                 CPAN::WAIT->$l(@_);
 555             } else {
 556                 $CPAN::Frontend->mywarn(qq{
 557 Commands starting with "w" require CPAN::WAIT to be installed.
 558 Please consider installing CPAN::WAIT to use the fulltext index.
 559 For this you just need to type
 560     install CPAN::WAIT
 561 });
 562             }
 563         } else {
 564             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 565                                     qq{Type ? for help.
 566 });
 567         }
 568         $autoload_recursion--;
 569     }
 570 }
 571
 572 package CPAN;
 573 use strict;
 574
 575 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 576
 577 # from here on only subs.
 578 ################################################################################
 579
 580 sub suggest_myconfig () {
 581   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 582         $CPAN::Frontend->myprint("You don't seem to have a user ".
 583                                  "configuration (MyConfig.pm) yet.\n");
 584         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 585                                               "user configuration now? (Y/n)",
 586                                               "yes");
 587         if($new =~ m{^y}i) {
 588             CPAN::Shell->mkmyconfig();
 589             return &checklock;
 590         } else {
 591             $CPAN::Frontend->mydie("OK, giving up.");
 592         }
 593     }
 594 }
 595
 596 #-> sub CPAN::all_objects ;
 597 sub all_objects {
 598     my($mgr,$class) = @_;
 599     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 600     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 601     CPAN::Index->reload;
 602     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 603 }
 604
 605 # Called by shell, not in batch mode. In batch mode I see no risk in
 606 # having many processes updating something as installations are
 607 # continually checked at runtime. In shell mode I suspect it is
 608 # unintentional to open more than one shell at a time
 609
 610 #-> sub CPAN::checklock ;
 611 sub checklock {
 612     my($self) = @_;
 613     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 614     if (-f $lockfile && -M _ > 0) {
 615         my $fh = FileHandle->new($lockfile) or
 616             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 617         my $otherpid  = <$fh>;
 618         my $otherhost = <$fh>;
 619         $fh->close;
 620         if (defined $otherpid && $otherpid) {
 621             chomp $otherpid;
 622         }
 623         if (defined $otherhost && $otherhost) {
 624             chomp $otherhost;
 625         }
 626         my $thishost  = hostname();
 627         if (defined $otherhost && defined $thishost &&
 628             $otherhost ne '' && $thishost ne '' &&
 629             $otherhost ne $thishost) {
 630             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 631                                            "reports other host $otherhost and other ".
 632                                            "process $otherpid.\n".
 633                                            "Cannot proceed.\n"));
 634         }
 635         elsif (defined $otherpid && $otherpid) {
 636             return if $$ == $otherpid; # should never happen
 637             $CPAN::Frontend->mywarn(
 638                                     qq{
 639 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 640 });
 641             if (kill 0, $otherpid) {
 642                 $CPAN::Frontend->mydie(qq{Other job is running.
 643 You may want to kill it and delete the lockfile, maybe. On UNIX try:
 644     kill $otherpid
 645     rm $lockfile
 646 });
 647             } elsif (-w $lockfile) {
 648                 my($ans) =
 649                     CPAN::Shell::colorable_makemaker_prompt
 650                         (qq{Other job not responding. Shall I overwrite }.
 651                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 652                 $CPAN::Frontend->myexit("Ok, bye\n")
 653                     unless $ans =~ /^y/i;
 654             } else {
 655                 Carp::croak(
 656                             qq{Lockfile '$lockfile' not writeable by you. }.
 657                             qq{Cannot proceed.\n}.
 658                             qq{    On UNIX try:\n}.
 659                             qq{    rm '$lockfile'\n}.
 660                             qq{  and then rerun us.\n}
 661                            );
 662             }
 663         } else {
 664             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 665                                            "reports other process with ID ".
 666                                            "$otherpid. Cannot proceed.\n"));
 667         }
 668     }
 669     my $dotcpan = $CPAN::Config->{cpan_home};
 670     eval { File::Path::mkpath($dotcpan);};
 671     if ($@) {
 672         # A special case at least for Jarkko.
 673         my $firsterror = $@;
 674         my $seconderror;
 675         my $symlinkcpan;
 676         if (-l $dotcpan) {
 677             $symlinkcpan = readlink $dotcpan;
 678             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 679             eval { File::Path::mkpath($symlinkcpan); };
 680             if ($@) {
 681                 $seconderror = $@;
 682             } else {
 683                 $CPAN::Frontend->mywarn(qq{
 684 Working directory $symlinkcpan created.
 685 });
 686             }
 687         }
 688         unless (-d $dotcpan) {
 689             my $mess = qq{
 690 Your configuration suggests "$dotcpan" as your
 691 CPAN.pm working directory. I could not create this directory due
 692 to this error: $firsterror\n};
 693             $mess .= qq{
 694 As "$dotcpan" is a symlink to "$symlinkcpan",
 695 I tried to create that, but I failed with this error: $seconderror
 696 } if $seconderror;
 697             $mess .= qq{
 698 Please make sure the directory exists and is writable.
 699 };
 700             $CPAN::Frontend->myprint($mess);
 701             return suggest_myconfig;
 702         }
 703     } # $@ after eval mkpath $dotcpan
 704     my $fh;
 705     unless ($fh = FileHandle->new(">$lockfile")) {
 706         if ($! =~ /Permission/) {
 707             $CPAN::Frontend->myprint(qq{
 708
 709 Your configuration suggests that CPAN.pm should use a working
 710 directory of
 711     $CPAN::Config->{cpan_home}
 712 Unfortunately we could not create the lock file
 713     $lockfile
 714 due to permission problems.
 715
 716 Please make sure that the configuration variable
 717     \$CPAN::Config->{cpan_home}
 718 points to a directory where you can write a .lock file. You can set
 719 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 720 \@INC path;
 721 });
 722             return suggest_myconfig;
 723         }
 724     }
 725     $fh->print($$, "\n");
 726     $fh->print(hostname(), "\n");
 727     $self->{LOCK} = $lockfile;
 728     $fh->close;
 729     $SIG{TERM} = sub {
 730         my $sig = shift;
 731         &cleanup;
 732         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
 733     };
 734     $SIG{INT} = sub {
 735       # no blocks!!!
 736         my $sig = shift;
 737         &cleanup if $Signal;
 738         die "Got yet another signal" if $Signal > 1;
 739         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
 740         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
 741         $Signal++;
 742     };
 743
 744 #       From: Larry Wall <larry@wall.org>
 745 #       Subject: Re: deprecating SIGDIE
 746 #       To: perl5-porters@perl.org
 747 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 748 #
 749 #       The original intent of __DIE__ was only to allow you to substitute one
 750 #       kind of death for another on an application-wide basis without respect
 751 #       to whether you were in an eval or not.  As a global backstop, it should
 752 #       not be used any more lightly (or any more heavily :-) than class
 753 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 754 #       be politely squashed.  Any bug that causes every eval {} to have to be
 755 #       modified should be not so politely squashed.
 756 #
 757 #       Those are my current opinions.  It is also my optinion that polite
 758 #       arguments degenerate to personal arguments far too frequently, and that
 759 #       when they do, it's because both people wanted it to, or at least didn't
 760 #       sufficiently want it not to.
 761 #
 762 #       Larry
 763
 764     # global backstop to cleanup if we should really die
 765     $SIG{__DIE__} = \&cleanup;
 766     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 767 }
 768
 769 #-> sub CPAN::DESTROY ;
 770 sub DESTROY {
 771     &cleanup; # need an eval?
 772 }
 773
 774 #-> sub CPAN::anycwd ;
 775 sub anycwd () {
 776     my $getcwd;
 777     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 778     CPAN->$getcwd();
 779 }
 780
 781 #-> sub CPAN::cwd ;
 782 sub cwd {Cwd::cwd();}
 783
 784 #-> sub CPAN::getcwd ;
 785 sub getcwd {Cwd::getcwd();}
 786
 787 #-> sub CPAN::fastcwd ;
 788 sub fastcwd {Cwd::fastcwd();}
 789
 790 #-> sub CPAN::backtickcwd ;
 791 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
 792
 793 #-> sub CPAN::find_perl ;
 794 sub find_perl {
 795     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
 796     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
 797     my $candidate = File::Spec->catfile($pwd,$^X);
 798     $perl ||= $candidate if MM->maybe_command($candidate);
 799
 800     unless ($perl) {
 801         my ($component,$perl_name);
 802       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
 803             PATH_COMPONENT: foreach $component (File::Spec->path(),
 804                                                 $Config::Config{'binexp'}) {
 805                   next unless defined($component) && $component;
 806                   my($abs) = File::Spec->catfile($component,$perl_name);
 807                   if (MM->maybe_command($abs)) {
 808                       $perl = $abs;
 809                       last DIST_PERLNAME;
 810                   }
 811               }
 812           }
 813     }
 814
 815     return $perl;
 816 }
 817
 818
 819 #-> sub CPAN::exists ;
 820 sub exists {
 821     my($mgr,$class,$id) = @_;
 822     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 823     CPAN::Index->reload;
 824     ### Carp::croak "exists called without class argument" unless $class;
 825     $id ||= "";
 826     $id =~ s/:+/::/g if $class eq "CPAN::Module";
 827     exists $META->{readonly}{$class}{$id} or
 828         exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 829 }
 830
 831 #-> sub CPAN::delete ;
 832 sub delete {
 833   my($mgr,$class,$id) = @_;
 834   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
 835   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
 836 }
 837
 838 #-> sub CPAN::has_usable
 839 # has_inst is sometimes too optimistic, we should replace it with this
 840 # has_usable whenever a case is given
 841 sub has_usable {
 842     my($self,$mod,$message) = @_;
 843     return 1 if $HAS_USABLE->{$mod};
 844     my $has_inst = $self->has_inst($mod,$message);
 845     return unless $has_inst;
 846     my $usable;
 847     $usable = {
 848                LWP => [ # we frequently had "Can't locate object
 849                         # method "new" via package "LWP::UserAgent" at
 850                         # (eval 69) line 2006
 851                        sub {require LWP},
 852                        sub {require LWP::UserAgent},
 853                        sub {require HTTP::Request},
 854                        sub {require URI::URL},
 855                       ],
 856                'Net::FTP' => [
 857                             sub {require Net::FTP},
 858                             sub {require Net::Config},
 859                            ],
 860                'File::HomeDir' => [
 861                                    sub {require File::HomeDir;
 862                                         unless (File::HomeDir->VERSION >= 0.52){
 863                                             for ("Will not use File::HomeDir, need 0.52\n") {
 864                                                 $CPAN::Frontend->mywarn($_);
 865                                                 die $_;
 866                                             }
 867                                         }
 868                                     },
 869                                   ],
 870               };
 871     if ($usable->{$mod}) {
 872         for my $c (0..$#{$usable->{$mod}}) {
 873             my $code = $usable->{$mod}[$c];
 874             my $ret = eval { &$code() };
 875             $ret = "" unless defined $ret;
 876             if ($@) {
 877                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
 878                 return;
 879             }
 880         }
 881     }
 882     return $HAS_USABLE->{$mod} = 1;
 883 }
 884
 885 #-> sub CPAN::has_inst
 886 sub has_inst {
 887     my($self,$mod,$message) = @_;
 888     Carp::croak("CPAN->has_inst() called without an argument")
 889         unless defined $mod;
 890     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
 891         keys %{$CPAN::Config->{dontload_hash}||{}},
 892             @{$CPAN::Config->{dontload_list}||[]};
 893     if (defined $message && $message eq "no"  # afair only used by Nox
 894         ||
 895         $dont{$mod}
 896        ) {
 897       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
 898       return 0;
 899     }
 900     my $file = $mod;
 901     my $obj;
 902     $file =~ s|::|/|g;
 903     $file .= ".pm";
 904     if ($INC{$file}) {
 905         # checking %INC is wrong, because $INC{LWP} may be true
 906         # although $INC{"URI/URL.pm"} may have failed. But as
 907         # I really want to say "bla loaded OK", I have to somehow
 908         # cache results.
 909         ### warn "$file in %INC"; #debug
 910         return 1;
 911     } elsif (eval { require $file }) {
 912         # eval is good: if we haven't yet read the database it's
 913         # perfect and if we have installed the module in the meantime,
 914         # it tries again. The second require is only a NOOP returning
 915         # 1 if we had success, otherwise it's retrying
 916
 917         my $v = eval "\$$mod\::VERSION";
 918         $v = $v ? " (v$v)" : "";
 919         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
 920         if ($mod eq "CPAN::WAIT") {
 921             push @CPAN::Shell::ISA, 'CPAN::WAIT';
 922         }
 923         return 1;
 924     } elsif ($mod eq "Net::FTP") {
 925         $CPAN::Frontend->mywarn(qq{
 926   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
 927   if you just type
 928       install Bundle::libnet
 929
 930 }) unless $Have_warned->{"Net::FTP"}++;
 931         $CPAN::Frontend->mysleep(3);
 932     } elsif ($mod eq "Digest::SHA"){
 933         if ($Have_warned->{"Digest::SHA"}++) {
 934             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
 935                                      qq{because Digest::SHA not installed.\n});
 936         } else {
 937             $CPAN::Frontend->mywarn(qq{
 938   CPAN: checksum security checks disabled because Digest::SHA not installed.
 939   Please consider installing the Digest::SHA module.
 940
 941 });
 942             $CPAN::Frontend->mysleep(2);
 943         }
 944     } elsif ($mod eq "Module::Signature"){
 945         if (not $CPAN::Config->{check_sigs}) {
 946             # they do not want us:-(
 947         } elsif (not $Have_warned->{"Module::Signature"}++) {
 948             # No point in complaining unless the user can
 949             # reasonably install and use it.
 950             if (eval { require Crypt::OpenPGP; 1 } ||
 951                 (
 952                  defined $CPAN::Config->{'gpg'}
 953                  &&
 954                  $CPAN::Config->{'gpg'} =~ /\S/
 955                 )
 956                ) {
 957                 $CPAN::Frontend->mywarn(qq{
 958   CPAN: Module::Signature security checks disabled because Module::Signature
 959   not installed.  Please consider installing the Module::Signature module.
 960   You may also need to be able to connect over the Internet to the public
 961   keyservers like pgp.mit.edu (port 11371).
 962
 963 });
 964                 $CPAN::Frontend->mysleep(2);
 965             }
 966         }
 967     } else {
 968         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
 969     }
 970     return 0;
 971 }
 972
 973 #-> sub CPAN::instance ;
 974 sub instance {
 975     my($mgr,$class,$id) = @_;
 976     CPAN::Index->reload;
 977     $id ||= "";
 978     # unsafe meta access, ok?
 979     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
 980     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
 981 }
 982
 983 #-> sub CPAN::new ;
 984 sub new {
 985     bless {}, shift;
 986 }
 987
 988 #-> sub CPAN::cleanup ;
 989 sub cleanup {
 990   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
 991   local $SIG{__DIE__} = '';
 992   my($message) = @_;
 993   my $i = 0;
 994   my $ineval = 0;
 995   my($subroutine);
 996   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
 997       $ineval = 1, last if
 998           $subroutine eq '(eval)';
 999   }
1000   return if $ineval && !$CPAN::End;
1001   return unless defined $META->{LOCK};
1002   return unless -f $META->{LOCK};
1003   $META->savehist;
1004   unlink $META->{LOCK};
1005   # require Carp;
1006   # Carp::cluck("DEBUGGING");
1007   $CPAN::Frontend->myprint("Lockfile removed.\n");
1008 }
1009
1010 #-> sub CPAN::savehist
1011 sub savehist {
1012     my($self) = @_;
1013     my($histfile,$histsize);
1014     unless ($histfile = $CPAN::Config->{'histfile'}){
1015         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1016         return;
1017     }
1018     $histsize = $CPAN::Config->{'histsize'} || 100;
1019     if ($CPAN::term){
1020         unless ($CPAN::term->can("GetHistory")) {
1021             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1022             return;
1023         }
1024     } else {
1025         return;
1026     }
1027     my @h = $CPAN::term->GetHistory;
1028     splice @h, 0, @h-$histsize if @h>$histsize;
1029     my($fh) = FileHandle->new;
1030     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1031     local $\ = local $, = "\n";
1032     print $fh @h;
1033     close $fh;
1034 }
1035
1036 sub is_tested {
1037     my($self,$what) = @_;
1038     $self->{is_tested}{$what} = 1;
1039 }
1040
1041 # unsets the is_tested flag: as soon as the thing is installed, it is
1042 # not needed in set_perl5lib anymore
1043 sub is_installed {
1044     my($self,$what) = @_;
1045     delete $self->{is_tested}{$what};
1046 }
1047
1048 sub set_perl5lib {
1049     my($self) = @_;
1050     $self->{is_tested} ||= {};
1051     return unless %{$self->{is_tested}};
1052     my $env = $ENV{PERL5LIB};
1053     $env = $ENV{PERLLIB} unless defined $env;
1054     my @env;
1055     push @env, $env if defined $env and length $env;
1056     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1057     $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1058     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1059 }
1060
1061 package CPAN::CacheMgr;
1062 use strict;
1063
1064 #-> sub CPAN::CacheMgr::as_string ;
1065 sub as_string {
1066     eval { require Data::Dumper };
1067     if ($@) {
1068         return shift->SUPER::as_string;
1069     } else {
1070         return Data::Dumper::Dumper(shift);
1071     }
1072 }
1073
1074 #-> sub CPAN::CacheMgr::cachesize ;
1075 sub cachesize {
1076     shift->{DU};
1077 }
1078
1079 #-> sub CPAN::CacheMgr::tidyup ;
1080 sub tidyup {
1081   my($self) = @_;
1082   return unless -d $self->{ID};
1083   while ($self->{DU} > $self->{'MAX'} ) {
1084     my($toremove) = shift @{$self->{FIFO}};
1085     $CPAN::Frontend->myprint(sprintf(
1086                                      "Deleting from cache".
1087                                      ": $toremove (%.1f>%.1f MB)\n",
1088                                      $self->{DU}, $self->{'MAX'})
1089                             );
1090     return if $CPAN::Signal;
1091     $self->force_clean_cache($toremove);
1092     return if $CPAN::Signal;
1093   }
1094 }
1095
1096 #-> sub CPAN::CacheMgr::dir ;
1097 sub dir {
1098     shift->{ID};
1099 }
1100
1101 #-> sub CPAN::CacheMgr::entries ;
1102 sub entries {
1103     my($self,$dir) = @_;
1104     return unless defined $dir;
1105     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1106     $dir ||= $self->{ID};
1107     my($cwd) = CPAN::anycwd();
1108     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1109     my $dh = DirHandle->new(File::Spec->curdir)
1110         or Carp::croak("Couldn't opendir $dir: $!");
1111     my(@entries);
1112     for ($dh->read) {
1113         next if $_ eq "." || $_ eq "..";
1114         if (-f $_) {
1115             push @entries, File::Spec->catfile($dir,$_);
1116         } elsif (-d _) {
1117             push @entries, File::Spec->catdir($dir,$_);
1118         } else {
1119             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1120         }
1121     }
1122     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1123     sort { -M $b <=> -M $a} @entries;
1124 }
1125
1126 #-> sub CPAN::CacheMgr::disk_usage ;
1127 sub disk_usage {
1128     my($self,$dir) = @_;
1129     return if exists $self->{SIZE}{$dir};
1130     return if $CPAN::Signal;
1131     my($Du) = 0;
1132     if (-e $dir) {
1133         unless (-x $dir) {
1134             unless (chmod 0755, $dir) {
1135                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1136                                         "permission to change the permission; cannot ".
1137                                         "estimate disk usage of '$dir'\n");
1138                 $CPAN::Frontend->mysleep(5);
1139                 return;
1140             }
1141         }
1142     } else {
1143         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1144         return;
1145     }
1146     find(
1147          sub {
1148            $File::Find::prune++ if $CPAN::Signal;
1149            return if -l $_;
1150            if ($^O eq 'MacOS') {
1151              require Mac::Files;
1152              my $cat  = Mac::Files::FSpGetCatInfo($_);
1153              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1154            } else {
1155              if (-d _) {
1156                unless (-x _) {
1157                  unless (chmod 0755, $_) {
1158                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1159                                            "the permission to change the permission; ".
1160                                            "can only partially estimate disk usage ".
1161                                            "of '$_'\n");
1162                    $CPAN::Frontend->mysleep(5);
1163                    return;
1164                  }
1165                }
1166              } else {
1167                $Du += (-s _);
1168              }
1169            }
1170          },
1171          $dir
1172         );
1173     return if $CPAN::Signal;
1174     $self->{SIZE}{$dir} = $Du/1024/1024;
1175     push @{$self->{FIFO}}, $dir;
1176     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1177     $self->{DU} += $Du/1024/1024;
1178     $self->{DU};
1179 }
1180
1181 #-> sub CPAN::CacheMgr::force_clean_cache ;
1182 sub force_clean_cache {
1183     my($self,$dir) = @_;
1184     return unless -e $dir;
1185     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1186         if $CPAN::DEBUG;
1187     File::Path::rmtree($dir);
1188     $self->{DU} -= $self->{SIZE}{$dir};
1189     delete $self->{SIZE}{$dir};
1190 }
1191
1192 #-> sub CPAN::CacheMgr::new ;
1193 sub new {
1194     my $class = shift;
1195     my $time = time;
1196     my($debug,$t2);
1197     $debug = "";
1198     my $self = {
1199                 ID => $CPAN::Config->{'build_dir'},
1200                 MAX => $CPAN::Config->{'build_cache'},
1201                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1202                 DU => 0
1203                };
1204     File::Path::mkpath($self->{ID});
1205     my $dh = DirHandle->new($self->{ID});
1206     bless $self, $class;
1207     $self->scan_cache;
1208     $t2 = time;
1209     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1210     $time = $t2;
1211     CPAN->debug($debug) if $CPAN::DEBUG;
1212     $self;
1213 }
1214
1215 #-> sub CPAN::CacheMgr::scan_cache ;
1216 sub scan_cache {
1217     my $self = shift;
1218     return if $self->{SCAN} eq 'never';
1219     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1220         unless $self->{SCAN} eq 'atstart';
1221     $CPAN::Frontend->myprint(
1222                              sprintf("Scanning cache %s for sizes\n",
1223                                      $self->{ID}));
1224     my $e;
1225     for $e ($self->entries($self->{ID})) {
1226         next if $e eq ".." || $e eq ".";
1227         $self->disk_usage($e);
1228         return if $CPAN::Signal;
1229     }
1230     $self->tidyup;
1231 }
1232
1233 package CPAN::Shell;
1234 use strict;
1235
1236 #-> sub CPAN::Shell::h ;
1237 sub h {
1238     my($class,$about) = @_;
1239     if (defined $about) {
1240         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1241     } else {
1242         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1243         $CPAN::Frontend->myprint(qq{
1244 Display Information $filler (ver $CPAN::VERSION)
1245  command  argument          description
1246  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1247  i        WORD or /REGEXP/  about any of the above
1248  ls       AUTHOR or GLOB    about files in the author's directory
1249     (with WORD being a module, bundle or author name or a distribution
1250     name of the form AUTHOR/DISTRIBUTION)
1251
1252 Download, Test, Make, Install...
1253  get      download                     clean    make clean
1254  make     make (implies get)           look     open subshell in dist directory
1255  test     make test (implies make)     readme   display these README files
1256  install  make install (implies test)  perldoc  display POD documentation
1257
1258 Upgrade
1259  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1260  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1261
1262 Pragmas
1263  force COMMAND    unconditionally do command
1264  notest COMMAND   skip testing
1265
1266 Other
1267  h,?           display this menu       ! perl-code   eval a perl command
1268  o conf [opt]  set and query options   q             quit the cpan shell
1269  reload cpan   load CPAN.pm again      reload index  load newer indices
1270  autobundle    Snapshot                recent        latest CPAN uploads});
1271 }
1272 }
1273
1274 *help = \&h;
1275
1276 #-> sub CPAN::Shell::a ;
1277 sub a {
1278   my($self,@arg) = @_;
1279   # authors are always UPPERCASE
1280   for (@arg) {
1281     $_ = uc $_ unless /=/;
1282   }
1283   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1284 }
1285
1286 #-> sub CPAN::Shell::globls ;
1287 sub globls {
1288     my($self,$s,$pragmas) = @_;
1289     # ls is really very different, but we had it once as an ordinary
1290     # command in the Shell (upto rev. 321) and we could not handle
1291     # force well then
1292     my(@accept,@preexpand);
1293     if ($s =~ /[\*\?\/]/) {
1294         if ($CPAN::META->has_inst("Text::Glob")) {
1295             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1296                 my $rau = Text::Glob::glob_to_regex(uc $au);
1297                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1298                       if $CPAN::DEBUG;
1299                 push @preexpand, map { $_->id . "/" . $pathglob }
1300                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1301             } else {
1302                 my $rau = Text::Glob::glob_to_regex(uc $s);
1303                 push @preexpand, map { $_->id }
1304                     CPAN::Shell->expand_by_method('CPAN::Author',
1305                                                   ['id'],
1306                                                   "/$rau/");
1307             }
1308         } else {
1309             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1310         }
1311     } else {
1312         push @preexpand, uc $s;
1313     }
1314     for (@preexpand) {
1315         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1316             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1317             next;
1318         }
1319         push @accept, $_;
1320     }
1321     my $silent = @accept>1;
1322     my $last_alpha = "";
1323     my @results;
1324     for my $a (@accept){
1325         my($author,$pathglob);
1326         if ($a =~ m|(.*?)/(.*)|) {
1327             my $a2 = $1;
1328             $pathglob = $2;
1329             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1330                                                     ['id'],
1331                                                     $a2) or die "No author found for $a2";
1332         } else {
1333             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1334                                                     ['id'],
1335                                                     $a) or die "No author found for $a";
1336         }
1337         if ($silent) {
1338             my $alpha = substr $author->id, 0, 1;
1339             my $ad;
1340             if ($alpha eq $last_alpha) {
1341                 $ad = "";
1342             } else {
1343                 $ad = "[$alpha]";
1344                 $last_alpha = $alpha;
1345             }
1346             $CPAN::Frontend->myprint($ad);
1347         }
1348         for my $pragma (@$pragmas) {
1349             if ($author->can($pragma)) {
1350                 $author->$pragma();
1351             }
1352         }
1353         push @results, $author->ls($pathglob,$silent); # silent if
1354                                                        # more than one
1355                                                        # author
1356         for my $pragma (@$pragmas) {
1357             my $meth = "un$pragma";
1358             if ($author->can($meth)) {
1359                 $author->$meth();
1360             }
1361         }
1362     }
1363     @results;
1364 }
1365
1366 #-> sub CPAN::Shell::local_bundles ;
1367 sub local_bundles {
1368     my($self,@which) = @_;
1369     my($incdir,$bdir,$dh);
1370     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1371         my @bbase = "Bundle";
1372         while (my $bbase = shift @bbase) {
1373             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1374             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1375             if ($dh = DirHandle->new($bdir)) { # may fail
1376                 my($entry);
1377                 for $entry ($dh->read) {
1378                     next if $entry =~ /^\./;
1379                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1380                     if (-d File::Spec->catdir($bdir,$entry)){
1381                         push @bbase, "$bbase\::$entry";
1382                     } else {
1383                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1384                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1385                     }
1386                 }
1387             }
1388         }
1389     }
1390 }
1391
1392 #-> sub CPAN::Shell::b ;
1393 sub b {
1394     my($self,@which) = @_;
1395     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1396     $self->local_bundles;
1397     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1398 }
1399
1400 #-> sub CPAN::Shell::d ;
1401 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1402
1403 #-> sub CPAN::Shell::m ;
1404 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1405     my $self = shift;
1406     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1407 }
1408
1409 #-> sub CPAN::Shell::i ;
1410 sub i {
1411     my($self) = shift;
1412     my(@args) = @_;
1413     @args = '/./' unless @args;
1414     my(@result);
1415     for my $type (qw/Bundle Distribution Module/) {
1416         push @result, $self->expand($type,@args);
1417     }
1418     # Authors are always uppercase.
1419     push @result, $self->expand("Author", map { uc $_ } @args);
1420
1421     my $result = @result == 1 ?
1422         $result[0]->as_string :
1423             @result == 0 ?
1424                 "No objects found of any type for argument @args\n" :
1425                     join("",
1426                          (map {$_->as_glimpse} @result),
1427                          scalar @result, " items found\n",
1428                         );
1429     $CPAN::Frontend->myprint($result);
1430 }
1431
1432 #-> sub CPAN::Shell::o ;
1433
1434 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1435 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1436 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1437 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1438 sub o {
1439     my($self,$o_type,@o_what) = @_;
1440     $DB::single = 1;
1441     $o_type ||= "";
1442     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1443     if ($o_type eq 'conf') {
1444         if (!@o_what) { # print all things, "o conf"
1445             my($k,$v);
1446             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1447             my @from;
1448             if (exists $INC{'CPAN/Config.pm'}) {
1449                 push @from, $INC{'CPAN/Config.pm'};
1450             }
1451             if (exists $INC{'CPAN/MyConfig.pm'}) {
1452                 push @from, $INC{'CPAN/MyConfig.pm'};
1453             }
1454             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1455             $CPAN::Frontend->myprint(":\n");
1456             for $k (sort keys %CPAN::HandleConfig::can) {
1457                 $v = $CPAN::HandleConfig::can{$k};
1458                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1459             }
1460             $CPAN::Frontend->myprint("\n");
1461             for $k (sort keys %$CPAN::Config) {
1462                 CPAN::HandleConfig->prettyprint($k);
1463             }
1464             $CPAN::Frontend->myprint("\n");
1465         } elsif (!CPAN::HandleConfig->edit(@o_what)) {
1466             $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1467                                      qq{items\n\n});
1468         }
1469     } elsif ($o_type eq 'debug') {
1470         my(%valid);
1471         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1472         if (@o_what) {
1473             while (@o_what) {
1474                 my($what) = shift @o_what;
1475                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1476                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1477                     next;
1478                 }
1479                 if ( exists $CPAN::DEBUG{$what} ) {
1480                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1481                 } elsif ($what =~ /^\d/) {
1482                     $CPAN::DEBUG = $what;
1483                 } elsif (lc $what eq 'all') {
1484                     my($max) = 0;
1485                     for (values %CPAN::DEBUG) {
1486                         $max += $_;
1487                     }
1488                     $CPAN::DEBUG = $max;
1489                 } else {
1490                     my($known) = 0;
1491                     for (keys %CPAN::DEBUG) {
1492                         next unless lc($_) eq lc($what);
1493                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1494                         $known = 1;
1495                     }
1496                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1497                         unless $known;
1498                 }
1499             }
1500         } else {
1501           my $raw = "Valid options for debug are ".
1502               join(", ",sort(keys %CPAN::DEBUG), 'all').
1503                   qq{ or a number. Completion works on the options. }.
1504                       qq{Case is ignored.};
1505           require Text::Wrap;
1506           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1507           $CPAN::Frontend->myprint("\n\n");
1508         }
1509         if ($CPAN::DEBUG) {
1510             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1511             my($k,$v);
1512             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1513                 $v = $CPAN::DEBUG{$k};
1514                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1515                     if $v & $CPAN::DEBUG;
1516             }
1517         } else {
1518             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1519         }
1520     } else {
1521         $CPAN::Frontend->myprint(qq{
1522 Known options:
1523   conf    set or get configuration variables
1524   debug   set or get debugging options
1525 });
1526     }
1527 }
1528
1529 # CPAN::Shell::paintdots_onreload
1530 sub paintdots_onreload {
1531     my($ref) = shift;
1532     sub {
1533         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1534             my($subr) = $1;
1535             ++$$ref;
1536             local($|) = 1;
1537             # $CPAN::Frontend->myprint(".($subr)");
1538             $CPAN::Frontend->myprint(".");
1539             if ($subr =~ /\bshell\b/i) {
1540                 # warn "debug[$_[0]]";
1541
1542                 # It would be nice if we could detect that a
1543                 # subroutine has actually changed, but for now we
1544                 # practically always set the GOTOSHELL global
1545
1546                 $CPAN::GOTOSHELL=1;
1547             }
1548             return;
1549         }
1550         warn @_;
1551     };
1552 }
1553
1554 #-> sub CPAN::Shell::reload ;
1555 sub reload {
1556     my($self,$command,@arg) = @_;
1557     $command ||= "";
1558     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1559     if ($command =~ /^cpan$/i) {
1560         my $redef = 0;
1561         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1562         my $failed;
1563         my @relo = (
1564                     "CPAN.pm",
1565                     "CPAN/HandleConfig.pm",
1566                     "CPAN/FirstTime.pm",
1567                     "CPAN/Tarzip.pm",
1568                     "CPAN/Debug.pm",
1569                     "CPAN/Version.pm",
1570                     "CPAN/Queue.pm",
1571                     "CPAN/Reporter.pm",
1572                    );
1573       MFILE: for my $f (@relo) {
1574             next unless exists $INC{$f};
1575             my $p = $f;
1576             $p =~ s/\.pm$//;
1577             $p =~ s|/|::|g;
1578             $CPAN::Frontend->myprint("($p");
1579             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1580             $self->reload_this($f) or $failed++;
1581             my $v = eval "$p\::->VERSION";
1582             $CPAN::Frontend->myprint("v$v)");
1583         }
1584         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1585         if ($failed) {
1586             my $errors = $failed == 1 ? "error" : "errors";
1587             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1588                                     "this session.\n");
1589         }
1590     } elsif ($command =~ /^index$/i) {
1591       CPAN::Index->force_reload;
1592     } else {
1593       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
1594 index    re-reads the index files\n});
1595     }
1596 }
1597
1598 # reload means only load again what we have loaded before
1599 #-> sub CPAN::Shell::reload_this ;
1600 sub reload_this {
1601     my($self,$f,$args) = @_;
1602     CPAN->debug("f[$f]") if $CPAN::DEBUG;
1603     return 1 unless $INC{$f}; # we never loaded this, so we do not
1604                               # reload but say OK
1605     my $pwd = CPAN::anycwd();
1606     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1607     my($file);
1608     for my $inc (@INC) {
1609         $file = File::Spec->catfile($inc,split /\//, $f);
1610         last if -f $file;
1611         $file = "";
1612     }
1613     CPAN->debug("file[$file]") if $CPAN::DEBUG;
1614     my @inc = @INC;
1615     unless ($file && -f $file) {
1616         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1617         $file = $INC{$f};
1618         @inc = substr($file,0,-length($f)); # bring in back to me!
1619     }
1620     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1621     unless (-f $file) {
1622         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1623         return;
1624     }
1625     my $mtime = (stat $file)[9];
1626     $reload->{$f} ||= $^T;
1627     my $must_reload = $mtime > $reload->{$f};
1628     $args ||= {};
1629     $must_reload ||= $args->{force};
1630     if ($must_reload) {
1631         my $fh = FileHandle->new($file) or
1632             $CPAN::Frontend->mydie("Could not open $file: $!");
1633         local($/);
1634         local $^W = 1;
1635         my $content = <$fh>;
1636         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1637             if $CPAN::DEBUG;
1638         delete $INC{$f};
1639         local @INC = @inc;
1640         eval "require '$f'";
1641         if ($@){
1642             warn $@;
1643             return;
1644         }
1645         $reload->{$f} = time;
1646     } else {
1647         $CPAN::Frontend->myprint("__unchanged__");
1648     }
1649     return 1;
1650 }
1651
1652 #-> sub CPAN::Shell::mkmyconfig ;
1653 sub mkmyconfig {
1654     my($self, $cpanpm, %args) = @_;
1655     require CPAN::FirstTime;
1656     my $home = CPAN::HandleConfig::home;
1657     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1658         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1659     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1660     CPAN::HandleConfig::require_myconfig_or_config;
1661     $CPAN::Config ||= {};
1662     $CPAN::Config = {
1663         %$CPAN::Config,
1664         build_dir           =>  undef,
1665         cpan_home           =>  undef,
1666         keep_source_where   =>  undef,
1667         histfile            =>  undef,
1668     };
1669     CPAN::FirstTime::init($cpanpm, %args);
1670 }
1671
1672 #-> sub CPAN::Shell::_binary_extensions ;
1673 sub _binary_extensions {
1674     my($self) = shift @_;
1675     my(@result,$module,%seen,%need,$headerdone);
1676     for $module ($self->expand('Module','/./')) {
1677         my $file  = $module->cpan_file;
1678         next if $file eq "N/A";
1679         next if $file =~ /^Contact Author/;
1680         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1681         next if $dist->isa_perl;
1682         next unless $module->xs_file;
1683         local($|) = 1;
1684         $CPAN::Frontend->myprint(".");
1685         push @result, $module;
1686     }
1687 #    print join " | ", @result;
1688     $CPAN::Frontend->myprint("\n");
1689     return @result;
1690 }
1691
1692 #-> sub CPAN::Shell::recompile ;
1693 sub recompile {
1694     my($self) = shift @_;
1695     my($module,@module,$cpan_file,%dist);
1696     @module = $self->_binary_extensions();
1697     for $module (@module){  # we force now and compile later, so we
1698                             # don't do it twice
1699         $cpan_file = $module->cpan_file;
1700         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1701         $pack->force;
1702         $dist{$cpan_file}++;
1703     }
1704     for $cpan_file (sort keys %dist) {
1705         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1706         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1707         $pack->install;
1708         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1709                            # stop a package from recompiling,
1710                            # e.g. IO-1.12 when we have perl5.003_10
1711     }
1712 }
1713
1714 #-> sub CPAN::Shell::scripts ;
1715 sub scripts {
1716     my($self, $arg) = @_;
1717     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1718
1719     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1720         unless ($CPAN::META->has_inst($req)) {
1721             $CPAN::Frontend->mywarn("  $req not available\n");
1722         }
1723     }
1724     my $p = HTML::LinkExtor->new();
1725     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1726     unless (-f $indexfile) {
1727         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1728     }
1729     $p->parse_file($indexfile);
1730     my @hrefs;
1731     my $qrarg;
1732     if ($arg =~ s|^/(.+)/$|$1|) {
1733         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1734     }
1735     for my $l ($p->links) {
1736         my $tag = shift @$l;
1737         next unless $tag eq "a";
1738         my %att = @$l;
1739         my $href = $att{href};
1740         next unless $href =~ s|^\.\./authors/id/./../||;
1741         if ($arg) {
1742             if ($qrarg) {
1743                 if ($href =~ $qrarg) {
1744                     push @hrefs, $href;
1745                 }
1746             } else {
1747                 if ($href =~ /\Q$arg\E/) {
1748                     push @hrefs, $href;
1749                 }
1750             }
1751         } else {
1752             push @hrefs, $href;
1753         }
1754     }
1755     # now filter for the latest version if there is more than one of a name
1756     my %stems;
1757     for (sort @hrefs) {
1758         my $href = $_;
1759         s/-v?\d.*//;
1760         my $stem = $_;
1761         $stems{$stem} ||= [];
1762         push @{$stems{$stem}}, $href;
1763     }
1764     for (sort keys %stems) {
1765         my $highest;
1766         if (@{$stems{$_}} > 1) {
1767             $highest = List::Util::reduce {
1768                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1769               } @{$stems{$_}};
1770         } else {
1771             $highest = $stems{$_}[0];
1772         }
1773         $CPAN::Frontend->myprint("$highest\n");
1774     }
1775 }
1776
1777 #-> sub CPAN::Shell::upgrade ;
1778 sub upgrade {
1779     my($self,@args) = @_;
1780     $self->install($self->r(@args));
1781 }
1782
1783 #-> sub CPAN::Shell::_u_r_common ;
1784 sub _u_r_common {
1785     my($self) = shift @_;
1786     my($what) = shift @_;
1787     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1788     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1789           $what && $what =~ /^[aru]$/;
1790     my(@args) = @_;
1791     @args = '/./' unless @args;
1792     my(@result,$module,%seen,%need,$headerdone,
1793        $version_undefs,$version_zeroes);
1794     $version_undefs = $version_zeroes = 0;
1795     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
1796     my @expand = $self->expand('Module',@args);
1797     my $expand = scalar @expand;
1798     if (0) { # Looks like noise to me, was very useful for debugging
1799              # for metadata cache
1800         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1801     }
1802   MODULE: for $module (@expand) {
1803         my $file  = $module->cpan_file;
1804         next MODULE unless defined $file; # ??
1805         $file =~ s|^./../||;
1806         my($latest) = $module->cpan_version;
1807         my($inst_file) = $module->inst_file;
1808         my($have);
1809         return if $CPAN::Signal;
1810         if ($inst_file){
1811             if ($what eq "a") {
1812                 $have = $module->inst_version;
1813             } elsif ($what eq "r") {
1814                 $have = $module->inst_version;
1815                 local($^W) = 0;
1816                 if ($have eq "undef"){
1817                     $version_undefs++;
1818                 } elsif ($have == 0){
1819                     $version_zeroes++;
1820                 }
1821                 next MODULE unless CPAN::Version->vgt($latest, $have);
1822 # to be pedantic we should probably say:
1823 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1824 # to catch the case where CPAN has a version 0 and we have a version undef
1825             } elsif ($what eq "u") {
1826                 next MODULE;
1827             }
1828         } else {
1829             if ($what eq "a") {
1830                 next MODULE;
1831             } elsif ($what eq "r") {
1832                 next MODULE;
1833             } elsif ($what eq "u") {
1834                 $have = "-";
1835             }
1836         }
1837         return if $CPAN::Signal; # this is sometimes lengthy
1838         $seen{$file} ||= 0;
1839         if ($what eq "a") {
1840             push @result, sprintf "%s %s\n", $module->id, $have;
1841         } elsif ($what eq "r") {
1842             push @result, $module->id;
1843             next MODULE if $seen{$file}++;
1844         } elsif ($what eq "u") {
1845             push @result, $module->id;
1846             next MODULE if $seen{$file}++;
1847             next MODULE if $file =~ /^Contact/;
1848         }
1849         unless ($headerdone++){
1850             $CPAN::Frontend->myprint("\n");
1851             $CPAN::Frontend->myprint(sprintf(
1852                                              $sprintf,
1853                                              "",
1854                                              "Package namespace",
1855                                              "",
1856                                              "installed",
1857                                              "latest",
1858                                              "in CPAN file"
1859                                             ));
1860         }
1861         my $color_on = "";
1862         my $color_off = "";
1863         # $GLOBAL_AUTOLOAD_RECURSION = 12;
1864         if (
1865             $COLOR_REGISTERED
1866             &&
1867             $CPAN::META->has_inst("Term::ANSIColor")
1868             &&
1869             $module->description
1870            ) {
1871             $color_on = Term::ANSIColor::color("green");
1872             $color_off = Term::ANSIColor::color("reset");
1873         }
1874         $CPAN::Frontend->myprint(sprintf $sprintf,
1875                                  $color_on,
1876                                  $module->id,
1877                                  $color_off,
1878                                  $have,
1879                                  $latest,
1880                                  $file);
1881         $need{$module->id}++;
1882     }
1883     unless (%need) {
1884         if ($what eq "u") {
1885             $CPAN::Frontend->myprint("No modules found for @args\n");
1886         } elsif ($what eq "r") {
1887             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1888         }
1889     }
1890     if ($what eq "r") {
1891         if ($version_zeroes) {
1892             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1893             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1894                 qq{a version number of 0\n});
1895         }
1896         if ($version_undefs) {
1897             my $s_has = $version_undefs > 1 ? "s have" : " has";
1898             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1899                 qq{parseable version number\n});
1900         }
1901     }
1902     @result;
1903 }
1904
1905 #-> sub CPAN::Shell::r ;
1906 sub r {
1907     shift->_u_r_common("r",@_);
1908 }
1909
1910 #-> sub CPAN::Shell::u ;
1911 sub u {
1912     shift->_u_r_common("u",@_);
1913 }
1914
1915 #-> sub CPAN::Shell::failed ;
1916 sub failed {
1917     my($self,$only_id,$silent) = @_;
1918     my @failed;
1919   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1920         my $failed = "";
1921       NAY: for my $nosayer (
1922                             "writemakefile",
1923                             "signature_verify",
1924                             "make",
1925                             "make_test",
1926                             "install",
1927                             "make_clean",
1928                            ) {
1929             next unless exists $d->{$nosayer};
1930             next unless (
1931                          $d->{$nosayer}->can("failed") ?
1932                          $d->{$nosayer}->failed :
1933                          $d->{$nosayer} =~ /^NO/
1934                         );
1935             next NAY if $only_id && $only_id != (
1936                                                  $d->{$nosayer}->can("commandid")
1937                                                  ?
1938                                                  $d->{$nosayer}->commandid
1939                                                  :
1940                                                  $CPAN::CurrentCommandId
1941                                                 );
1942             $failed = $nosayer;
1943             last;
1944         }
1945         next DIST unless $failed;
1946         my $id = $d->id;
1947         $id =~ s|^./../||;
1948         #$print .= sprintf(
1949         #                  "  %-45s: %s %s\n",
1950         push @failed,
1951             (
1952              $d->{$failed}->can("failed") ?
1953              [
1954               $d->{$failed}->commandid,
1955               $id,
1956               $failed,
1957               $d->{$failed}->text,
1958              ] :
1959              [
1960               1,
1961               $id,
1962               $failed,
1963               $d->{$failed},
1964              ]
1965             );
1966     }
1967     my $scope = $only_id ? "command" : "session";
1968     if (@failed) {
1969         my $print = join "",
1970             map { sprintf "  %-45s: %s %s\n", @$_[1,2,3] }
1971                 sort { $a->[0] <=> $b->[0] } @failed;
1972         $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
1973     } elsif (!$only_id || !$silent) {
1974         $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
1975     }
1976 }
1977
1978 # XXX intentionally undocumented because completely bogus, unportable,
1979 # useless, etc.
1980
1981 #-> sub CPAN::Shell::status ;
1982 sub status {
1983     my($self) = @_;
1984     require Devel::Size;
1985     my $ps = FileHandle->new;
1986     open $ps, "/proc/$$/status";
1987     my $vm = 0;
1988     while (<$ps>) {
1989         next unless /VmSize:\s+(\d+)/;
1990         $vm = $1;
1991         last;
1992     }
1993     $CPAN::Frontend->mywarn(sprintf(
1994                                     "%-27s %6d\n%-27s %6d\n",
1995                                     "vm",
1996                                     $vm,
1997                                     "CPAN::META",
1998                                     Devel::Size::total_size($CPAN::META)/1024,
1999                                    ));
2000     for my $k (sort keys %$CPAN::META) {
2001         next unless substr($k,0,4) eq "read";
2002         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2003         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2004             warn sprintf "  %-25s %6d (keys: %6d)\n",
2005                 $k2,
2006                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2007                           scalar keys %{$CPAN::META->{$k}{$k2}};
2008         }
2009     }
2010 }
2011
2012 #-> sub CPAN::Shell::autobundle ;
2013 sub autobundle {
2014     my($self) = shift;
2015     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2016     my(@bundle) = $self->_u_r_common("a",@_);
2017     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2018     File::Path::mkpath($todir);
2019     unless (-d $todir) {
2020         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2021         return;
2022     }
2023     my($y,$m,$d) =  (localtime)[5,4,3];
2024     $y+=1900;
2025     $m++;
2026     my($c) = 0;
2027     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2028     my($to) = File::Spec->catfile($todir,"$me.pm");
2029     while (-f $to) {
2030         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2031         $to = File::Spec->catfile($todir,"$me.pm");
2032     }
2033     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2034     $fh->print(
2035                "package Bundle::$me;\n\n",
2036                "\$VERSION = '0.01';\n\n",
2037                "1;\n\n",
2038                "__END__\n\n",
2039                "=head1 NAME\n\n",
2040                "Bundle::$me - Snapshot of installation on ",
2041                $Config::Config{'myhostname'},
2042                " on ",
2043                scalar(localtime),
2044                "\n\n=head1 SYNOPSIS\n\n",
2045                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2046                "=head1 CONTENTS\n\n",
2047                join("\n", @bundle),
2048                "\n\n=head1 CONFIGURATION\n\n",
2049                Config->myconfig,
2050                "\n\n=head1 AUTHOR\n\n",
2051                "This Bundle has been generated automatically ",
2052                "by the autobundle routine in CPAN.pm.\n",
2053               );
2054     $fh->close;
2055     $CPAN::Frontend->myprint("\nWrote bundle file
2056     $to\n\n");
2057 }
2058
2059 #-> sub CPAN::Shell::expandany ;
2060 sub expandany {
2061     my($self,$s) = @_;
2062     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2063     if ($s =~ m|/|) { # looks like a file
2064         $s = CPAN::Distribution->normalize($s);
2065         return $CPAN::META->instance('CPAN::Distribution',$s);
2066         # Distributions spring into existence, not expand
2067     } elsif ($s =~ m|^Bundle::|) {
2068         $self->local_bundles; # scanning so late for bundles seems
2069                               # both attractive and crumpy: always
2070                               # current state but easy to forget
2071                               # somewhere
2072         return $self->expand('Bundle',$s);
2073     } else {
2074         return $self->expand('Module',$s)
2075             if $CPAN::META->exists('CPAN::Module',$s);
2076     }
2077     return;
2078 }
2079
2080 #-> sub CPAN::Shell::expand ;
2081 sub expand {
2082     my $self = shift;
2083     my($type,@args) = @_;
2084     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2085     my $class = "CPAN::$type";
2086     my $methods = ['id'];
2087     for my $meth (qw(name)) {
2088         next if $] < 5.00303; # no "can"
2089         next unless $class->can($meth);
2090         push @$methods, $meth;
2091     }
2092     $self->expand_by_method($class,$methods,@args);
2093 }
2094
2095 sub expand_by_method {
2096     my $self = shift;
2097     my($class,$methods,@args) = @_;
2098     my($arg,@m);
2099     for $arg (@args) {
2100         my($regex,$command);
2101         if ($arg =~ m|^/(.*)/$|) {
2102             $regex = $1;
2103         } elsif ($arg =~ m/=/) {
2104             $command = 1;
2105         }
2106         my $obj;
2107         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2108                     $class,
2109                     defined $regex ? $regex : "UNDEFINED",
2110                     defined $command ? $command : "UNDEFINED",
2111                    ) if $CPAN::DEBUG;
2112         if (defined $regex) {
2113             for $obj (
2114                       $CPAN::META->all_objects($class)
2115                      ) {
2116                 unless ($obj->id){
2117                     # BUG, we got an empty object somewhere
2118                     require Data::Dumper;
2119                     CPAN->debug(sprintf(
2120                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2121                                         $obj,
2122                                         Data::Dumper::Dumper($obj)
2123                                        )) if $CPAN::DEBUG;
2124                     next;
2125                 }
2126                 for my $method (@$methods) {
2127                     my $match = eval {$obj->$method() =~ /$regex/i};
2128                     if ($@) {
2129                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2130                         $err ||= $@; # if we were too restrictive above
2131                         $CPAN::Frontend->mydie("$err\n");
2132                     } elsif ($match) {
2133                         push @m, $obj;
2134                         last;
2135                     }
2136                 }
2137             }
2138         } elsif ($command) {
2139             die "equal sign in command disabled (immature interface), ".
2140                 "you can set
2141  ! \$CPAN::Shell::ADVANCED_QUERY=1
2142 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2143 that may go away anytime.\n"
2144                     unless $ADVANCED_QUERY;
2145             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2146             my($matchcrit) = $criterion =~ m/^~(.+)/;
2147             for my $self (
2148                           sort
2149                           {$a->id cmp $b->id}
2150                           $CPAN::META->all_objects($class)
2151                          ) {
2152                 my $lhs = $self->$method() or next; # () for 5.00503
2153                 if ($matchcrit) {
2154                     push @m, $self if $lhs =~ m/$matchcrit/;
2155                 } else {
2156                     push @m, $self if $lhs eq $criterion;
2157                 }
2158             }
2159         } else {
2160             my($xarg) = $arg;
2161             if ( $class eq 'CPAN::Bundle' ) {
2162                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2163             } elsif ($class eq "CPAN::Distribution") {
2164                 $xarg = CPAN::Distribution->normalize($arg);
2165             } else {
2166                 $xarg =~ s/:+/::/g;
2167             }
2168             if ($CPAN::META->exists($class,$xarg)) {
2169                 $obj = $CPAN::META->instance($class,$xarg);
2170             } elsif ($CPAN::META->exists($class,$arg)) {
2171                 $obj = $CPAN::META->instance($class,$arg);
2172             } else {
2173                 next;
2174             }
2175             push @m, $obj;
2176         }
2177     }
2178     @m = sort {$a->id cmp $b->id} @m;
2179     if ( $CPAN::DEBUG ) {
2180         my $wantarray = wantarray;
2181         my $join_m = join ",", map {$_->id} @m;
2182         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2183     }
2184     return wantarray ? @m : $m[0];
2185 }
2186
2187 #-> sub CPAN::Shell::format_result ;
2188 sub format_result {
2189     my($self) = shift;
2190     my($type,@args) = @_;
2191     @args = '/./' unless @args;
2192     my(@result) = $self->expand($type,@args);
2193     my $result = @result == 1 ?
2194         $result[0]->as_string :
2195             @result == 0 ?
2196                 "No objects of type $type found for argument @args\n" :
2197                     join("",
2198                          (map {$_->as_glimpse} @result),
2199                          scalar @result, " items found\n",
2200                         );
2201     $result;
2202 }
2203
2204 #-> sub CPAN::Shell::report_fh ;
2205 {
2206     my $installation_report_fh;
2207     my $previously_noticed = 0;
2208
2209     sub report_fh {
2210         return $installation_report_fh if $installation_report_fh;
2211         if ($CPAN::META->has_inst("File::Temp")) {
2212             $installation_report_fh
2213                 = File::Temp->new(
2214                                   template => 'cpan_install_XXXX',
2215                                   suffix   => '.txt',
2216                                   unlink   => 0,
2217                                  );
2218         }
2219         unless ( $installation_report_fh ) {
2220             warn("Couldn't open installation report file; " .
2221                  "no report file will be generated."
2222                 ) unless $previously_noticed++;
2223         }
2224     }
2225 }
2226
2227
2228 # The only reason for this method is currently to have a reliable
2229 # debugging utility that reveals which output is going through which
2230 # channel. No, I don't like the colors ;-)
2231
2232 # to turn colordebugging on, write
2233 # cpan> o conf colorize_output 1
2234
2235 #-> sub CPAN::Shell::print_ornamented ;
2236 {
2237     my $print_ornamented_have_warned = 0;
2238     sub colorize_output {
2239         my $colorize_output = $CPAN::Config->{colorize_output};
2240         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2241             unless ($print_ornamented_have_warned++) {
2242                 # no myprint/mywarn within myprint/mywarn!
2243                 warn "Colorize_output is set to true but Term::ANSIColor is not
2244 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2245             }
2246             $colorize_output = 0;
2247         }
2248         return $colorize_output;
2249     }
2250 }
2251
2252
2253 sub print_ornamented {
2254     my($self,$what,$ornament) = @_;
2255     return unless defined $what;
2256
2257     local $| = 1; # Flush immediately
2258     if ( $CPAN::Be_Silent ) {
2259         print {report_fh()} $what;
2260         return;
2261     }
2262     my $swhat = "$what"; # stringify if it is an object
2263     if ($CPAN::Config->{term_is_latin}){
2264         # courtesy jhi:
2265         $swhat
2266             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2267     }
2268     if ($self->colorize_output) {
2269         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2270             # if you want to have this configurable, please file a bugreport
2271             $ornament = "black on_cyan";
2272         }
2273         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2274         if ($@) {
2275             print "Term::ANSIColor rejects color[$ornament]: $@\n
2276 Please choose a different color (Hint: try 'o conf init color.*')\n";
2277         }
2278         print $color_on,
2279             $swhat,
2280                 Term::ANSIColor::color("reset");
2281     } else {
2282         print $swhat;
2283     }
2284 }
2285
2286 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2287 # where to use what! I think, we send everything to STDOUT and use
2288 # print for normal/good news and warn for news that need more
2289 # attention. Yes, this is our working contract for now.
2290 sub myprint {
2291     my($self,$what) = @_;
2292
2293     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2294 }
2295
2296 sub myexit {
2297     my($self,$what) = @_;
2298     $self->myprint($what);
2299     exit;
2300 }
2301
2302 sub mywarn {
2303     my($self,$what) = @_;
2304     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2305 }
2306
2307 # only to be used for shell commands
2308 sub mydie {
2309     my($self,$what) = @_;
2310     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2311
2312     # If it is the shell, we want that the following die to be silent,
2313     # but if it is not the shell, we would need a 'die $what'. We need
2314     # to take care that only shell commands use mydie. Is this
2315     # possible?
2316
2317     die "\n";
2318 }
2319
2320 # sub CPAN::Shell::colorable_makemaker_prompt
2321 sub colorable_makemaker_prompt {
2322     my($foo,$bar) = @_;
2323     if (CPAN::Shell->colorize_output) {
2324         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2325         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2326         print $color_on;
2327     }
2328     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2329     if (CPAN::Shell->colorize_output) {
2330         print Term::ANSIColor::color('reset');
2331     }
2332     return $ans;
2333 }
2334
2335 # use this only for unrecoverable errors!
2336 sub unrecoverable_error {
2337     my($self,$what) = @_;
2338     my @lines = split /\n/, $what;
2339     my $longest = 0;
2340     for my $l (@lines) {
2341         $longest = length $l if length $l > $longest;
2342     }
2343     $longest = 62 if $longest > 62;
2344     for my $l (@lines) {
2345         if ($l =~ /^\s*$/){
2346             $l = "\n";
2347             next;
2348         }
2349         $l = "==> $l";
2350         if (length $l < 66) {
2351             $l = pack "A66 A*", $l, "<==";
2352         }
2353         $l .= "\n";
2354     }
2355     unshift @lines, "\n";
2356     $self->mydie(join "", @lines);
2357 }
2358
2359 sub mysleep {
2360     my($self, $sleep) = @_;
2361     sleep $sleep;
2362 }
2363
2364 sub setup_output {
2365     return if -t STDOUT;
2366     my $odef = select STDERR;
2367     $| = 1;
2368     select STDOUT;
2369     $| = 1;
2370     select $odef;
2371 }
2372
2373 #-> sub CPAN::Shell::rematein ;
2374 # RE-adme||MA-ke||TE-st||IN-stall
2375 sub rematein {
2376     my $self = shift;
2377     my($meth,@some) = @_;
2378     my @pragma;
2379     while($meth =~ /^(force|notest)$/) {
2380         push @pragma, $meth;
2381         $meth = shift @some or
2382             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2383                                    "cannot continue");
2384     }
2385     setup_output();
2386     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2387
2388     # Here is the place to set "test_count" on all involved parties to
2389     # 0. We then can pass this counter on to the involved
2390     # distributions and those can refuse to test if test_count > X. In
2391     # the first stab at it we could use a 1 for "X".
2392
2393     # But when do I reset the distributions to start with 0 again?
2394     # Jost suggested to have a random or cycling interaction ID that
2395     # we pass through. But the ID is something that is just left lying
2396     # around in addition to the counter, so I'd prefer to set the
2397     # counter to 0 now, and repeat at the end of the loop. But what
2398     # about dependencies? They appear later and are not reset, they
2399     # enter the queue but not its copy. How do they get a sensible
2400     # test_count?
2401
2402     # construct the queue
2403     my($s,@s,@qcopy);
2404   STHING: foreach $s (@some) {
2405         my $obj;
2406         if (ref $s) {
2407             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2408             $obj = $s;
2409         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2410         } elsif ($s =~ m|^/|) { # looks like a regexp
2411             $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2412                                     "not supported.\nRejecting argument '$s'\n");
2413             $CPAN::Frontend->mysleep(2);
2414             next;
2415         } elsif ($meth eq "ls") {
2416             $self->globls($s,\@pragma);
2417             next STHING;
2418         } else {
2419             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2420             $obj = CPAN::Shell->expandany($s);
2421         }
2422         if (0) {
2423         } elsif (ref $obj) {
2424             $obj->color_cmd_tmps(0,1);
2425             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2426             push @qcopy, $obj;
2427         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2428             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2429             if ($meth =~ /^(dump|ls)$/) {
2430                 $obj->$meth();
2431             } else {
2432                 $CPAN::Frontend->mywarn(
2433                                         join "",
2434                                         "Don't be silly, you can't $meth ",
2435                                         $obj->fullname,
2436                                         " ;-)\n"
2437                                        );
2438                 $CPAN::Frontend->mysleep(2);
2439             }
2440         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2441             CPAN::InfoObj->dump($s);
2442         } else {
2443             $CPAN::Frontend
2444                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2445                           qq{don't know what it is.
2446 Try the command
2447
2448     i /$s/
2449
2450 to find objects with matching identifiers.
2451 });
2452             $CPAN::Frontend->mysleep(2);
2453         }
2454     }
2455
2456     # queuerunner (please be warned: when I started to change the
2457     # queue to hold objects instead of names, I made one or two
2458     # mistakes and never found which. I reverted back instead)
2459     while (my $q = CPAN::Queue->first) {
2460         my $obj;
2461         my $s = $q->as_string;
2462         my $reqtype = $q->reqtype || "";
2463         $obj = CPAN::Shell->expandany($s);
2464         $obj->{reqtype} ||= "";
2465         CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2466                     "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2467         if ($obj->{reqtype}) {
2468             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2469                 $obj->{reqtype} = $reqtype;
2470                 if (
2471                     exists $obj->{install}
2472                     &&
2473                     (
2474                      $obj->{install}->can("failed") ?
2475                      $obj->{install}->failed :
2476                      $obj->{install} =~ /^NO/
2477                     )
2478                    ) {
2479                     delete $obj->{install};
2480                     $CPAN::Frontend->mywarn
2481                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2482                 }
2483             }
2484         } else {
2485             $obj->{reqtype} = $reqtype;
2486         }
2487
2488         for my $pragma (@pragma) {
2489             if ($pragma
2490                 &&
2491                 ($] < 5.00303 || $obj->can($pragma))){
2492                 ### compatibility with 5.003
2493                 $obj->$pragma($meth); # the pragma "force" in
2494                                       # "CPAN::Distribution" must know
2495                                       # what we are intending
2496             }
2497         }
2498         if ($]>=5.00303 && $obj->can('called_for')) {
2499             $obj->called_for($s);
2500         }
2501         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2502                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2503
2504         push @qcopy, $obj;
2505         if ($obj->$meth()){
2506             CPAN::Queue->delete($s);
2507         } else {
2508             CPAN->debug("failed");
2509         }
2510
2511         $obj->undelay;
2512         CPAN::Queue->delete_first($s);
2513     }
2514     for my $obj (@qcopy) {
2515         $obj->color_cmd_tmps(0,0);
2516     }
2517 }
2518
2519 #-> sub CPAN::Shell::recent ;
2520 sub recent {
2521   my($self) = @_;
2522
2523   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2524   return;
2525 }
2526
2527 {
2528     # set up the dispatching methods
2529     no strict "refs";
2530     for my $command (qw(
2531                         clean
2532                         cvs_import
2533                         dump
2534                         force
2535                         get
2536                         install
2537                         look
2538                         ls
2539                         make
2540                         notest
2541                         perldoc
2542                         readme
2543                         test
2544                        )) {
2545         *$command = sub { shift->rematein($command, @_); };
2546     }
2547 }
2548
2549 package CPAN::LWP::UserAgent;
2550 use strict;
2551
2552 sub config {
2553     return if $SETUPDONE;
2554     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2555         require LWP::UserAgent;
2556         @ISA = qw(Exporter LWP::UserAgent);
2557         $SETUPDONE++;
2558     } else {
2559         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
2560     }
2561 }
2562
2563 sub get_basic_credentials {
2564     my($self, $realm, $uri, $proxy) = @_;
2565     if ($USER && $PASSWD) {
2566         return ($USER, $PASSWD);
2567     }
2568     if ( $proxy ) {
2569         ($USER,$PASSWD) = $self->get_proxy_credentials();
2570     } else {
2571         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2572     }
2573     return($USER,$PASSWD);
2574 }
2575
2576 sub get_proxy_credentials {
2577     my $self = shift;
2578     my ($user, $password);
2579     if ( defined $CPAN::Config->{proxy_user} &&
2580          defined $CPAN::Config->{proxy_pass}) {
2581         $user = $CPAN::Config->{proxy_user};
2582         $password = $CPAN::Config->{proxy_pass};
2583         return ($user, $password);
2584     }
2585     my $username_prompt = "\nProxy authentication needed!
2586  (Note: to permanently configure username and password run
2587    o conf proxy_user your_username
2588    o conf proxy_pass your_password
2589      )\nUsername:";
2590     ($user, $password) =
2591         _get_username_and_password_from_user($username_prompt);
2592     return ($user,$password);
2593 }
2594
2595 sub get_non_proxy_credentials {
2596     my $self = shift;
2597     my ($user,$password);
2598     if ( defined $CPAN::Config->{username} &&
2599          defined $CPAN::Config->{password}) {
2600         $user = $CPAN::Config->{username};
2601         $password = $CPAN::Config->{password};
2602         return ($user, $password);
2603     }
2604     my $username_prompt = "\nAuthentication needed!
2605      (Note: to permanently configure username and password run
2606        o conf username your_username
2607        o conf password your_password
2608      )\nUsername:";
2609
2610     ($user, $password) =
2611         _get_username_and_password_from_user($username_prompt);
2612     return ($user,$password);
2613 }
2614
2615 sub _get_username_and_password_from_user {
2616     my $self = shift;
2617     my $username_message = shift;
2618     my ($username,$password);
2619
2620     ExtUtils::MakeMaker->import(qw(prompt));
2621     $username = prompt($username_message);
2622         if ($CPAN::META->has_inst("Term::ReadKey")) {
2623             Term::ReadKey::ReadMode("noecho");
2624         }
2625     else {
2626         $CPAN::Frontend->mywarn(
2627             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2628         );
2629     }
2630     $password = prompt("Password:");
2631
2632         if ($CPAN::META->has_inst("Term::ReadKey")) {
2633             Term::ReadKey::ReadMode("restore");
2634         }
2635         $CPAN::Frontend->myprint("\n\n");
2636     return ($username,$password);
2637 }
2638
2639 # mirror(): Its purpose is to deal with proxy authentication. When we
2640 # call SUPER::mirror, we relly call the mirror method in
2641 # LWP::UserAgent. LWP::UserAgent will then call
2642 # $self->get_basic_credentials or some equivalent and this will be
2643 # $self->dispatched to our own get_basic_credentials method.
2644
2645 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2646
2647 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2648 # although we have gone through our get_basic_credentials, the proxy
2649 # server refuses to connect. This could be a case where the username or
2650 # password has changed in the meantime, so I'm trying once again without
2651 # $USER and $PASSWD to give the get_basic_credentials routine another
2652 # chance to set $USER and $PASSWD.
2653
2654 # mirror(): Its purpose is to deal with proxy authentication. When we
2655 # call SUPER::mirror, we relly call the mirror method in
2656 # LWP::UserAgent. LWP::UserAgent will then call
2657 # $self->get_basic_credentials or some equivalent and this will be
2658 # $self->dispatched to our own get_basic_credentials method.
2659
2660 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2661
2662 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2663 # although we have gone through our get_basic_credentials, the proxy
2664 # server refuses to connect. This could be a case where the username or
2665 # password has changed in the meantime, so I'm trying once again without
2666 # $USER and $PASSWD to give the get_basic_credentials routine another
2667 # chance to set $USER and $PASSWD.
2668
2669 sub mirror {
2670     my($self,$url,$aslocal) = @_;
2671     my $result = $self->SUPER::mirror($url,$aslocal);
2672     if ($result->code == 407) {
2673         undef $USER;
2674         undef $PASSWD;
2675         $result = $self->SUPER::mirror($url,$aslocal);
2676     }
2677     $result;
2678 }
2679
2680 package CPAN::FTP;
2681 use strict;
2682
2683 #-> sub CPAN::FTP::ftp_get ;
2684 sub ftp_get {
2685     my($class,$host,$dir,$file,$target) = @_;
2686     $class->debug(
2687                   qq[Going to fetch file [$file] from dir [$dir]
2688         on host [$host] as local [$target]\n]
2689                  ) if $CPAN::DEBUG;
2690     my $ftp = Net::FTP->new($host);
2691     unless ($ftp) {
2692         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
2693         return;
2694     }
2695     return 0 unless defined $ftp;
2696     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2697     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2698     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2699         my $msg = $ftp->message;
2700         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
2701         return;
2702     }
2703     unless ( $ftp->cwd($dir) ){
2704         my $msg = $ftp->message;
2705         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
2706         return;
2707     }
2708     $ftp->binary;
2709     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2710     unless ( $ftp->get($file,$target) ){
2711         my $msg = $ftp->message;
2712         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
2713         return;
2714     }
2715     $ftp->quit; # it's ok if this fails
2716     return 1;
2717 }
2718
2719 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2720
2721  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
2722  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
2723  # > ***************
2724  # > *** 1562,1567 ****
2725  # > --- 1562,1580 ----
2726  # >       return 1 if substr($url,0,4) eq "file";
2727  # >       return 1 unless $url =~ m|://([^/]+)|;
2728  # >       my $host = $1;
2729  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2730  # > +     if ($proxy) {
2731  # > +         $proxy =~ m|://([^/:]+)|;
2732  # > +         $proxy = $1;
2733  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2734  # > +         if ($noproxy) {
2735  # > +             if ($host !~ /$noproxy$/) {
2736  # > +                 $host = $proxy;
2737  # > +             }
2738  # > +         } else {
2739  # > +             $host = $proxy;
2740  # > +         }
2741  # > +     }
2742  # >       require Net::Ping;
2743  # >       return 1 unless $Net::Ping::VERSION >= 2;
2744  # >       my $p;
2745
2746
2747 #-> sub CPAN::FTP::localize ;
2748 sub localize {
2749     my($self,$file,$aslocal,$force) = @_;
2750     $force ||= 0;
2751     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2752         unless defined $aslocal;
2753     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2754         if $CPAN::DEBUG;
2755
2756     if ($^O eq 'MacOS') {
2757         # Comment by AK on 2000-09-03: Uniq short filenames would be
2758         # available in CHECKSUMS file
2759         my($name, $path) = File::Basename::fileparse($aslocal, '');
2760         if (length($name) > 31) {
2761             $name =~ s/(
2762                         \.(
2763                            readme(\.(gz|Z))? |
2764                            (tar\.)?(gz|Z) |
2765                            tgz |
2766                            zip |
2767                            pm\.(gz|Z)
2768                           )
2769                        )$//x;
2770             my $suf = $1;
2771             my $size = 31 - length($suf);
2772             while (length($name) > $size) {
2773                 chop $name;
2774             }
2775             $name .= $suf;
2776             $aslocal = File::Spec->catfile($path, $name);
2777         }
2778     }
2779
2780     if (-f $aslocal && -r _ && !($force & 1)){
2781         my $size;
2782         if ($size = -s $aslocal) {
2783             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
2784             return $aslocal;
2785         } else {
2786             # empty file from a previous unsuccessful attempt to download it
2787             unlink $aslocal or
2788                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
2789                                        "could not remove.");
2790         }
2791     }
2792     my($restore) = 0;
2793     if (-f $aslocal){
2794         rename $aslocal, "$aslocal.bak";
2795         $restore++;
2796     }
2797
2798     my($aslocal_dir) = File::Basename::dirname($aslocal);
2799     File::Path::mkpath($aslocal_dir);
2800     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2801         qq{directory "$aslocal_dir".
2802     I\'ll continue, but if you encounter problems, they may be due
2803     to insufficient permissions.\n}) unless -w $aslocal_dir;
2804
2805     # Inheritance is not easier to manage than a few if/else branches
2806     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2807         unless ($Ua) {
2808             CPAN::LWP::UserAgent->config;
2809             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2810             if ($@) {
2811                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2812                     if $CPAN::DEBUG;
2813             } else {
2814                 my($var);
2815                 $Ua->proxy('ftp',  $var)
2816                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2817                 $Ua->proxy('http', $var)
2818                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2819
2820
2821 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2822 #
2823 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2824 #  > use ones that require basic autorization.
2825 #
2826 #  > Example of when I use it manually in my own stuff:
2827 #
2828 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2829 #  > $req->proxy_authorization_basic("username","password");
2830 #  > $res = $ua->request($req);
2831 #
2832
2833                 $Ua->no_proxy($var)
2834                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2835             }
2836         }
2837     }
2838     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2839         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2840     }
2841
2842     # Try the list of urls for each single object. We keep a record
2843     # where we did get a file from
2844     my(@reordered,$last);
2845     $CPAN::Config->{urllist} ||= [];
2846     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2847         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
2848         $CPAN::Config->{urllist} = [];
2849     }
2850     $last = $#{$CPAN::Config->{urllist}};
2851     if ($force & 2) { # local cpans probably out of date, don't reorder
2852         @reordered = (0..$last);
2853     } else {
2854         @reordered =
2855             sort {
2856                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2857                     <=>
2858                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2859                     or
2860                 defined($ThesiteURL)
2861                     and
2862                 ($CPAN::Config->{urllist}[$b] eq $ThesiteURL)
2863                     <=>
2864                 ($CPAN::Config->{urllist}[$a] eq $ThesiteURL)
2865             } 0..$last;
2866     }
2867     my(@levels);
2868     $Themethod ||= "";
2869     $self->debug("Themethod[$Themethod]") if $CPAN::DEBUG;
2870     if ($Themethod) {
2871         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2872     } else {
2873         @levels = qw/easy hard hardest/;
2874     }
2875     @levels = qw/easy/ if $^O eq 'MacOS';
2876     my($levelno);
2877     local $ENV{FTP_PASSIVE} =
2878         exists $CPAN::Config->{ftp_passive} ?
2879         $CPAN::Config->{ftp_passive} : 1;
2880     for $levelno (0..$#levels) {
2881         my $level = $levels[$levelno];
2882         my $method = "host$level";
2883         my @host_seq = $level eq "easy" ?
2884             @reordered : 0..$last;  # reordered has CDROM up front
2885         my @urllist = map { $CPAN::Config->{urllist}[$_] } @host_seq;
2886         for my $u (@urllist) {
2887             if ($u->can("text")) {
2888                 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
2889             } else {
2890                 $u .= "/" unless substr($u,-1) eq "/";
2891                 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
2892             }
2893         }
2894         for my $u (@CPAN::Defaultsites) {
2895             push @urllist, $u unless grep { $_ eq $u } @urllist;
2896         }
2897         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
2898         my $ret = $self->$method(\@urllist,$file,$aslocal);
2899         if ($ret) {
2900           $Themethod = $level;
2901           my $now = time;
2902           # utime $now, $now, $aslocal; # too bad, if we do that, we
2903                                       # might alter a local mirror
2904           $self->debug("level[$level]") if $CPAN::DEBUG;
2905           return $ret;
2906         } else {
2907           unlink $aslocal;
2908           last if $CPAN::Signal; # need to cleanup
2909         }
2910     }
2911     unless ($CPAN::Signal) {
2912         my(@mess);
2913         local $" = " ";
2914         if (@{$CPAN::Config->{urllist}}) {
2915             push @mess,
2916                 qq{Please check, if the URLs I found in your configuration file \(}.
2917                     join(", ", @{$CPAN::Config->{urllist}}).
2918                         qq{\) are valid.};
2919         } else {
2920             push @mess, qq{Your urllist is empty!};
2921         }
2922         push @mess, qq{The urllist can be edited.},
2923             qq{E.g. with 'o conf urllist push ftp://myurl/'};
2924         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
2925         $CPAN::Frontend->mywarn("Could not fetch $file\n");
2926         $CPAN::Frontend->mysleep(2);
2927     }
2928     if ($restore) {
2929         rename "$aslocal.bak", $aslocal;
2930         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2931                                  $self->ls($aslocal));
2932         return $aslocal;
2933     }
2934     return;
2935 }
2936
2937 # package CPAN::FTP;
2938 sub hosteasy {
2939     my($self,$host_seq,$file,$aslocal) = @_;
2940     my($ro_url);
2941   HOSTEASY: for $ro_url (@$host_seq) {
2942         my $url .= "$ro_url$file";
2943         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2944         if ($url =~ /^file:/) {
2945             my $l;
2946             if ($CPAN::META->has_inst('URI::URL')) {
2947                 my $u =  URI::URL->new($url);
2948                 $l = $u->path;
2949             } else { # works only on Unix, is poorly constructed, but
2950                 # hopefully better than nothing.
2951                 # RFC 1738 says fileurl BNF is
2952                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2953                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2954                 # the code
2955                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2956                 $l =~ s|^file:||;                   # assume they
2957                                                     # meant
2958                                                     # file://localhost
2959                 $l =~ s|^/||s
2960                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
2961             }
2962             $self->debug("local file[$l]") if $CPAN::DEBUG;
2963             if ( -f $l && -r _) {
2964                 $ThesiteURL = $ro_url;
2965                 return $l;
2966             }
2967             if ($l =~ /(.+)\.gz$/) {
2968                 my $ungz = $1;
2969                 if ( -f $ungz && -r _) {
2970                     $ThesiteURL = $ro_url;
2971                     return $ungz;
2972                 }
2973             }
2974             # Maybe mirror has compressed it?
2975             if (-f "$l.gz") {
2976                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2977                 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
2978                 if ( -f $aslocal) {
2979                     $ThesiteURL = $ro_url;
2980                     return $aslocal;
2981                 }
2982             }
2983         }
2984         if ($CPAN::META->has_usable('LWP')) {
2985             $CPAN::Frontend->myprint("Fetching with LWP:
2986   $url
2987 ");
2988             unless ($Ua) {
2989                 CPAN::LWP::UserAgent->config;
2990                 eval { $Ua = CPAN::LWP::UserAgent->new; };
2991                 if ($@) {
2992                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2993                 }
2994             }
2995             my $res = $Ua->mirror($url, $aslocal);
2996             if ($res->is_success) {
2997                 $ThesiteURL = $ro_url;
2998                 my $now = time;
2999                 utime $now, $now, $aslocal; # download time is more
3000                                             # important than upload
3001                                             # time
3002                 return $aslocal;
3003             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3004                 my $gzurl = "$url.gz";
3005                 $CPAN::Frontend->myprint("Fetching with LWP:
3006   $gzurl
3007 ");
3008                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3009                 if ($res->is_success &&
3010                     CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
3011                    ) {
3012                     $ThesiteURL = $ro_url;
3013                     return $aslocal;
3014                 }
3015             } else {
3016                 $CPAN::Frontend->myprint(sprintf(
3017                                                  "LWP failed with code[%s] message[%s]\n",
3018                                                  $res->code,
3019                                                  $res->message,
3020                                                 ));
3021                 # Alan Burlison informed me that in firewall environments
3022                 # Net::FTP can still succeed where LWP fails. So we do not
3023                 # skip Net::FTP anymore when LWP is available.
3024             }
3025         } elsif (
3026                  $ro_url->can("text")
3027                  and
3028                  $ro_url->{FROM} eq "USER"
3029                 ){
3030             my $ret = $self->hosthard([$ro_url],$file,$aslocal);
3031             return $ret if $ret;
3032         } else {
3033             $CPAN::Frontend->mywarn("  LWP not available\n");
3034         }
3035         return if $CPAN::Signal;
3036         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3037             # that's the nice and easy way thanks to Graham
3038             my($host,$dir,$getfile) = ($1,$2,$3);
3039             if ($CPAN::META->has_usable('Net::FTP')) {
3040                 $dir =~ s|/+|/|g;
3041                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3042   $url
3043 ");
3044                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3045                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3046                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3047                     $ThesiteURL = $ro_url;
3048                     return $aslocal;
3049                 }
3050                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3051                     my $gz = "$aslocal.gz";
3052                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3053   $url.gz
3054 ");
3055                     if (CPAN::FTP->ftp_get($host,
3056                                            $dir,
3057                                            "$getfile.gz",
3058                                            $gz) &&
3059                         CPAN::Tarzip->new($gz)->gunzip($aslocal)
3060                        ){
3061                         $ThesiteURL = $ro_url;
3062                         return $aslocal;
3063                     }
3064                 }
3065                 # next HOSTEASY;
3066             }
3067         }
3068         return if $CPAN::Signal;
3069     }
3070 }
3071
3072 # package CPAN::FTP;
3073 sub hosthard {
3074   my($self,$host_seq,$file,$aslocal) = @_;
3075
3076   # Came back if Net::FTP couldn't establish connection (or
3077   # failed otherwise) Maybe they are behind a firewall, but they
3078   # gave us a socksified (or other) ftp program...
3079
3080   my($ro_url);
3081   my($devnull) = $CPAN::Config->{devnull} || "";
3082   # < /dev/null ";
3083   my($aslocal_dir) = File::Basename::dirname($aslocal);
3084   File::Path::mkpath($aslocal_dir);
3085   HOSTHARD: for $ro_url (@$host_seq) {
3086         my $url = "$ro_url$file";
3087         my($proto,$host,$dir,$getfile);
3088
3089         # Courtesy Mark Conty mark_conty@cargill.com change from
3090         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3091         # to
3092         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3093           # proto not yet used
3094           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3095         } else {
3096           next HOSTHARD; # who said, we could ftp anything except ftp?
3097         }
3098         next HOSTHARD if $proto eq "file"; # file URLs would have had
3099                                            # success above. Likely a bogus URL
3100
3101         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3102
3103         # Try the most capable first and leave ncftp* for last as it only
3104         # does FTP.
3105       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3106           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3107           next unless defined $funkyftp;
3108           next if $funkyftp =~ /^\s*$/;
3109
3110           my($asl_ungz, $asl_gz);
3111           ($asl_ungz = $aslocal) =~ s/\.gz//;
3112           $asl_gz = "$asl_ungz.gz";
3113
3114           my($src_switch) = "";
3115           my($chdir) = "";
3116           my($stdout_redir) = " > $asl_ungz";
3117           if ($f eq "lynx"){
3118             $src_switch = " -source";
3119           } elsif ($f eq "ncftp"){
3120             $src_switch = " -c";
3121           } elsif ($f eq "wget"){
3122             $src_switch = " -O $asl_ungz";
3123             $stdout_redir = "";
3124           } elsif ($f eq 'curl'){
3125             $src_switch = ' -L -f -s -S --netrc-optional';
3126           }
3127
3128           if ($f eq "ncftpget"){
3129             $chdir = "cd $aslocal_dir && ";
3130             $stdout_redir = "";
3131           }
3132           $CPAN::Frontend->myprint(
3133                                    qq[
3134 Trying with "$funkyftp$src_switch" to get
3135     $url
3136 ]);
3137           my($system) =
3138               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3139           $self->debug("system[$system]") if $CPAN::DEBUG;
3140           my($wstatus) = system($system);
3141           if ($f eq "lynx") {
3142               # lynx returns 0 when it fails somewhere
3143               if (-s $asl_ungz) {
3144                   my $content = do { local *FH; open FH, $asl_ungz or die; local $/; <FH> };
3145                   if ($content =~ /^<.*<title>[45]/si) {
3146                       $CPAN::Frontend->mywarn(qq{
3147 No success, the file that lynx has has downloaded looks like an error message:
3148 $content
3149 });
3150                       $CPAN::Frontend->mysleep(1);
3151                       next DLPRG;
3152                   }
3153               } else {
3154                   $CPAN::Frontend->myprint(qq{
3155 No success, the file that lynx has has downloaded is an empty file.
3156 });
3157                   next DLPRG;
3158               }
3159           }
3160           if ($wstatus == 0) {
3161             if (-s $aslocal) {
3162               # Looks good
3163             } elsif ($asl_ungz ne $aslocal) {
3164               # test gzip integrity
3165               if (CPAN::Tarzip->new($asl_ungz)->gtest) {
3166                   # e.g. foo.tar is gzipped --> foo.tar.gz
3167                   rename $asl_ungz, $aslocal;
3168               } else {
3169                   CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
3170               }
3171             }
3172             $ThesiteURL = $ro_url;
3173             return $aslocal;
3174           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3175             unlink $asl_ungz if
3176                 -f $asl_ungz && -s _ == 0;
3177             my $gz = "$aslocal.gz";
3178             my $gzurl = "$url.gz";
3179             $CPAN::Frontend->myprint(
3180                                      qq[
3181 Trying with "$funkyftp$src_switch" to get
3182   $url.gz
3183 ]);
3184             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3185             $self->debug("system[$system]") if $CPAN::DEBUG;
3186             my($wstatus);
3187             if (($wstatus = system($system)) == 0
3188                 &&
3189                 -s $asl_gz
3190                ) {
3191               # test gzip integrity
3192               my $ct = CPAN::Tarzip->new($asl_gz);
3193               if ($ct->gtest) {
3194                   $ct->gunzip($aslocal);
3195               } else {
3196                   # somebody uncompressed file for us?
3197                   rename $asl_ungz, $aslocal;
3198               }
3199               $ThesiteURL = $ro_url;
3200               return $aslocal;
3201             } else {
3202               unlink $asl_gz if -f $asl_gz;
3203             }
3204           } else {
3205             my $estatus = $wstatus >> 8;
3206             my $size = -f $aslocal ?
3207                 ", left\n$aslocal with size ".-s _ :
3208                     "\nWarning: expected file [$aslocal] doesn't exist";
3209             $CPAN::Frontend->myprint(qq{
3210 System call "$system"
3211 returned status $estatus (wstat $wstatus)$size
3212 });
3213           }
3214           return if $CPAN::Signal;
3215         } # transfer programs
3216     } # host
3217 }
3218
3219 # package CPAN::FTP;
3220 sub hosthardest {
3221     my($self,$host_seq,$file,$aslocal) = @_;
3222
3223     my($ro_url);
3224     my($aslocal_dir) = File::Basename::dirname($aslocal);
3225     File::Path::mkpath($aslocal_dir);
3226     my $ftpbin = $CPAN::Config->{ftp};
3227     unless (length $ftpbin && MM->maybe_command($ftpbin)) {
3228         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3229         return;
3230     }
3231     $CPAN::Frontend->mywarn(qq{
3232 As a last ressort we now switch to the external ftp command '$ftpbin'
3233 to get '$aslocal'.
3234
3235 Doing so often leads to problems that are hard to diagnose.
3236
3237 If you're victim of such problems, please consider unsetting the ftp
3238 config variable with
3239
3240     o conf ftp ""
3241     o conf commit
3242
3243 });
3244     $CPAN::Frontend->mysleep(2);
3245   HOSTHARDEST: for $ro_url (@$host_seq) {
3246         my $url = "$ro_url$file";
3247         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3248         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3249             next;
3250         }
3251         my($host,$dir,$getfile) = ($1,$2,$3);
3252         my $timestamp = 0;
3253         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3254            $ctime,$blksize,$blocks) = stat($aslocal);
3255         $timestamp = $mtime ||= 0;
3256         my($netrc) = CPAN::FTP::netrc->new;
3257         my($netrcfile) = $netrc->netrc;
3258         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3259         my $targetfile = File::Basename::basename($aslocal);
3260         my(@dialog);
3261         push(
3262              @dialog,
3263              "lcd $aslocal_dir",
3264              "cd /",
3265              map("cd $_", split /\//, $dir), # RFC 1738
3266              "bin",
3267              "get $getfile $targetfile",
3268              "quit"
3269             );
3270         if (! $netrcfile) {
3271             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3272         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3273             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3274                                 $netrc->hasdefault,
3275                                 $netrc->contains($host))) if $CPAN::DEBUG;
3276             if ($netrc->protected) {
3277                 my $dialog = join "", map { "    $_\n" } @dialog;
3278                 my $netrc_explain;
3279                 if ($netrc->contains($host)) {
3280                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3281                         "manages the login";
3282                 } else {
3283                     $netrc_explain = "Relying that your default .netrc entry ".
3284                         "manages the login";
3285                 }
3286                 $CPAN::Frontend->myprint(qq{
3287   Trying with external ftp to get
3288     $url
3289   $netrc_explain
3290   Going to send the dialog
3291 $dialog
3292 }
3293                      );
3294                 $self->talk_ftp("$ftpbin$verbose $host",
3295                                 @dialog);
3296                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3297                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3298                 $mtime ||= 0;
3299                 if ($mtime > $timestamp) {
3300                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3301                     $ThesiteURL = $ro_url;
3302                     return $aslocal;
3303                 } else {
3304                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3305                 }
3306                 return if $CPAN::Signal;
3307             } else {
3308                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3309                                         qq{correctly protected.\n});
3310             }
3311         } else {
3312             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3313   nor does it have a default entry\n");
3314         }
3315
3316         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3317         # then and login manually to host, using e-mail as
3318         # password.
3319         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3320         unshift(
3321                 @dialog,
3322                 "open $host",
3323                 "user anonymous $Config::Config{'cf_email'}"
3324                );
3325         my $dialog = join "", map { "    $_\n" } @dialog;
3326         $CPAN::Frontend->myprint(qq{
3327   Trying with external ftp to get
3328     $url
3329   Going to send the dialog
3330 $dialog
3331 }
3332                      );
3333         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3334         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3335          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3336         $mtime ||= 0;
3337         if ($mtime > $timestamp) {
3338             $CPAN::Frontend->myprint("GOT $aslocal\n");
3339             $ThesiteURL = $ro_url;
3340             return $aslocal;
3341         } else {
3342             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3343         }
3344         return if $CPAN::Signal;
3345         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3346         $CPAN::Frontend->mysleep(2);
3347     } # host
3348 }
3349
3350 # package CPAN::FTP;
3351 sub talk_ftp {
3352     my($self,$command,@dialog) = @_;
3353     my $fh = FileHandle->new;
3354     $fh->open("|$command") or die "Couldn't open ftp: $!";
3355     foreach (@dialog) { $fh->print("$_\n") }
3356     $fh->close;         # Wait for process to complete
3357     my $wstatus = $?;
3358     my $estatus = $wstatus >> 8;
3359     $CPAN::Frontend->myprint(qq{
3360 Subprocess "|$command"
3361   returned status $estatus (wstat $wstatus)
3362 }) if $wstatus;
3363 }
3364
3365 # find2perl needs modularization, too, all the following is stolen
3366 # from there
3367 # CPAN::FTP::ls
3368 sub ls {
3369     my($self,$name) = @_;
3370     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3371      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3372
3373     my($perms,%user,%group);
3374     my $pname = $name;
3375
3376     if ($blocks) {
3377         $blocks = int(($blocks + 1) / 2);
3378     }
3379     else {
3380         $blocks = int(($sizemm + 1023) / 1024);
3381     }
3382
3383     if    (-f _) { $perms = '-'; }
3384     elsif (-d _) { $perms = 'd'; }
3385     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3386     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3387     elsif (-p _) { $perms = 'p'; }
3388     elsif (-S _) { $perms = 's'; }
3389     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3390
3391     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3392     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3393     my $tmpmode = $mode;
3394     my $tmp = $rwx[$tmpmode & 7];
3395     $tmpmode >>= 3;
3396     $tmp = $rwx[$tmpmode & 7] . $tmp;
3397     $tmpmode >>= 3;
3398     $tmp = $rwx[$tmpmode & 7] . $tmp;
3399     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3400     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3401     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3402     $perms .= $tmp;
3403
3404     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
3405     my $group = $group{$gid} || $gid;
3406
3407     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3408     my($timeyear);
3409     my($moname) = $moname[$mon];
3410     if (-M _ > 365.25 / 2) {
3411         $timeyear = $year + 1900;
3412     }
3413     else {
3414         $timeyear = sprintf("%02d:%02d", $hour, $min);
3415     }
3416
3417     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3418             $ino,
3419                  $blocks,
3420                       $perms,
3421                             $nlink,
3422                                 $user,
3423                                      $group,
3424                                           $sizemm,
3425                                               $moname,
3426                                                  $mday,
3427                                                      $timeyear,
3428                                                          $pname;
3429 }
3430
3431 package CPAN::FTP::netrc;
3432 use strict;
3433
3434 # package CPAN::FTP::netrc;
3435 sub new {
3436     my($class) = @_;
3437     my $home = CPAN::HandleConfig::home;
3438     my $file = File::Spec->catfile($home,".netrc");
3439
3440     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3441        $atime,$mtime,$ctime,$blksize,$blocks)
3442         = stat($file);
3443     $mode ||= 0;
3444     my $protected = 0;
3445
3446     my($fh,@machines,$hasdefault);
3447     $hasdefault = 0;
3448     $fh = FileHandle->new or die "Could not create a filehandle";
3449
3450     if($fh->open($file)){
3451         $protected = ($mode & 077) == 0;
3452         local($/) = "";
3453       NETRC: while (<$fh>) {
3454             my(@tokens) = split " ", $_;
3455           TOKEN: while (@tokens) {
3456                 my($t) = shift @tokens;
3457                 if ($t eq "default"){
3458                     $hasdefault++;
3459                     last NETRC;
3460                 }
3461                 last TOKEN if $t eq "macdef";
3462                 if ($t eq "machine") {
3463                     push @machines, shift @tokens;
3464                 }
3465             }
3466         }
3467     } else {
3468         $file = $hasdefault = $protected = "";
3469     }
3470
3471     bless {
3472            'mach' => [@machines],
3473            'netrc' => $file,
3474            'hasdefault' => $hasdefault,
3475            'protected' => $protected,
3476           }, $class;
3477 }
3478
3479 # CPAN::FTP::netrc::hasdefault;
3480 sub hasdefault { shift->{'hasdefault'} }
3481 sub netrc      { shift->{'netrc'}      }
3482 sub protected  { shift->{'protected'}  }
3483 sub contains {
3484     my($self,$mach) = @_;
3485     for ( @{$self->{'mach'}} ) {
3486         return 1 if $_ eq $mach;
3487     }
3488     return 0;
3489 }
3490
3491 package CPAN::Complete;
3492 use strict;
3493
3494 sub gnu_cpl {
3495     my($text, $line, $start, $end) = @_;
3496     my(@perlret) = cpl($text, $line, $start);
3497     # find longest common match. Can anybody show me how to peruse
3498     # T::R::Gnu to have this done automatically? Seems expensive.
3499     return () unless @perlret;
3500     my($newtext) = $text;
3501     for (my $i = length($text)+1;;$i++) {
3502         last unless length($perlret[0]) && length($perlret[0]) >= $i;
3503         my $try = substr($perlret[0],0,$i);
3504         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3505         # warn "try[$try]tries[@tries]";
3506         if (@tries == @perlret) {
3507             $newtext = $try;
3508         } else {
3509             last;
3510         }
3511     }
3512     ($newtext,@perlret);
3513 }
3514
3515 #-> sub CPAN::Complete::cpl ;
3516 sub cpl {
3517     my($word,$line,$pos) = @_;
3518     $word ||= "";
3519     $line ||= "";
3520     $pos ||= 0;
3521     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3522     $line =~ s/^\s*//;
3523     if ($line =~ s/^(force\s*)//) {
3524         $pos -= length($1);
3525     }
3526     my @return;
3527     if ($pos == 0) {
3528         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3529     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3530         @return = ();
3531     } elsif ($line =~ /^(a|ls)\s/) {
3532         @return = cplx('CPAN::Author',uc($word));
3533     } elsif ($line =~ /^b\s/) {
3534         CPAN::Shell->local_bundles;
3535         @return = cplx('CPAN::Bundle',$word);
3536     } elsif ($line =~ /^d\s/) {
3537         @return = cplx('CPAN::Distribution',$word);
3538     } elsif ($line =~ m/^(
3539                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3540                          )\s/x ) {
3541         if ($word =~ /^Bundle::/) {
3542             CPAN::Shell->local_bundles;
3543         }
3544         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3545     } elsif ($line =~ /^i\s/) {
3546         @return = cpl_any($word);
3547     } elsif ($line =~ /^reload\s/) {
3548         @return = cpl_reload($word,$line,$pos);
3549     } elsif ($line =~ /^o\s/) {
3550         @return = cpl_option($word,$line,$pos);
3551     } elsif ($line =~ m/^\S+\s/ ) {
3552         # fallback for future commands and what we have forgotten above
3553         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3554     } else {
3555         @return = ();
3556     }
3557     return @return;
3558 }
3559
3560 #-> sub CPAN::Complete::cplx ;
3561 sub cplx {
3562     my($class, $word) = @_;
3563     # I believed for many years that this was sorted, today I
3564     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3565     # make it sorted again. Maybe sort was dropped when GNU-readline
3566     # support came in? The RCS file is difficult to read on that:-(
3567     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3568 }
3569
3570 #-> sub CPAN::Complete::cpl_any ;
3571 sub cpl_any {
3572     my($word) = shift;
3573     return (
3574             cplx('CPAN::Author',$word),
3575             cplx('CPAN::Bundle',$word),
3576             cplx('CPAN::Distribution',$word),
3577             cplx('CPAN::Module',$word),
3578            );
3579 }
3580
3581 #-> sub CPAN::Complete::cpl_reload ;
3582 sub cpl_reload {
3583     my($word,$line,$pos) = @_;
3584     $word ||= "";
3585     my(@words) = split " ", $line;
3586     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3587     my(@ok) = qw(cpan index);
3588     return @ok if @words == 1;
3589     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3590 }
3591
3592 #-> sub CPAN::Complete::cpl_option ;
3593 sub cpl_option {
3594     my($word,$line,$pos) = @_;
3595     $word ||= "";
3596     my(@words) = split " ", $line;
3597     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3598     my(@ok) = qw(conf debug);
3599     return @ok if @words == 1;
3600     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3601     if (0) {
3602     } elsif ($words[1] eq 'index') {
3603         return ();
3604     } elsif ($words[1] eq 'conf') {
3605         return CPAN::HandleConfig::cpl(@_);
3606     } elsif ($words[1] eq 'debug') {
3607         return sort grep /^\Q$word\E/i,
3608             sort keys %CPAN::DEBUG, 'all';
3609     }
3610 }
3611
3612 package CPAN::Index;
3613 use strict;
3614
3615 #-> sub CPAN::Index::force_reload ;
3616 sub force_reload {
3617     my($class) = @_;
3618     $CPAN::Index::LAST_TIME = 0;
3619     $class->reload(1);
3620 }
3621
3622 #-> sub CPAN::Index::reload ;
3623 sub reload {
3624     my($cl,$force) = @_;
3625     my $time = time;
3626
3627     # XXX check if a newer one is available. (We currently read it
3628     # from time to time)
3629     for ($CPAN::Config->{index_expire}) {
3630         $_ = 0.001 unless $_ && $_ > 0.001;
3631     }
3632     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3633         # debug here when CPAN doesn't seem to read the Metadata
3634         require Carp;
3635         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3636     }
3637     unless ($CPAN::META->{PROTOCOL}) {
3638         $cl->read_metadata_cache;
3639         $CPAN::META->{PROTOCOL} ||= "1.0";
3640     }
3641     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
3642         # warn "Setting last_time to 0";
3643         $LAST_TIME = 0; # No warning necessary
3644     }
3645     return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3646         and ! $force;
3647     if (0) {
3648         # IFF we are developing, it helps to wipe out the memory
3649         # between reloads, otherwise it is not what a user expects.
3650         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3651         $CPAN::META = CPAN->new;
3652     }
3653     {
3654         my($debug,$t2);
3655         local $LAST_TIME = $time;
3656         local $CPAN::META->{PROTOCOL} = PROTOCOL;
3657
3658         my $needshort = $^O eq "dos";
3659
3660         $cl->rd_authindex($cl
3661                           ->reload_x(
3662                                      "authors/01mailrc.txt.gz",
3663                                      $needshort ?
3664                                      File::Spec->catfile('authors', '01mailrc.gz') :
3665                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
3666                                      $force));
3667         $t2 = time;
3668         $debug = "timing reading 01[".($t2 - $time)."]";
3669         $time = $t2;
3670         return if $CPAN::Signal; # this is sometimes lengthy
3671         $cl->rd_modpacks($cl
3672                          ->reload_x(
3673                                     "modules/02packages.details.txt.gz",
3674                                     $needshort ?
3675                                     File::Spec->catfile('modules', '02packag.gz') :
3676                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
3677                                     $force));
3678         $t2 = time;
3679         $debug .= "02[".($t2 - $time)."]";
3680         $time = $t2;
3681         return if $CPAN::Signal; # this is sometimes lengthy
3682         $cl->rd_modlist($cl
3683                         ->reload_x(
3684                                    "modules/03modlist.data.gz",
3685                                    $needshort ?
3686                                    File::Spec->catfile('modules', '03mlist.gz') :
3687                                    File::Spec->catfile('modules', '03modlist.data.gz'),
3688                                    $force));
3689         $cl->write_metadata_cache;
3690         $t2 = time;
3691         $debug .= "03[".($t2 - $time)."]";
3692         $time = $t2;
3693         CPAN->debug($debug) if $CPAN::DEBUG;
3694     }
3695     $LAST_TIME = $time;
3696     $CPAN::META->{PROTOCOL} = PROTOCOL;
3697 }
3698
3699 #-> sub CPAN::Index::reload_x ;
3700 sub reload_x {
3701     my($cl,$wanted,$localname,$force) = @_;
3702     $force |= 2; # means we're dealing with an index here
3703     CPAN::HandleConfig->load; # we should guarantee loading wherever
3704                               # we rely on Config XXX
3705     $localname ||= $wanted;
3706     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3707                                          $localname);
3708     if (
3709         -f $abs_wanted &&
3710         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3711         !($force & 1)
3712        ) {
3713         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3714         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3715                    qq{day$s. I\'ll use that.});
3716         return $abs_wanted;
3717     } else {
3718         $force |= 1; # means we're quite serious about it.
3719     }
3720     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3721 }
3722
3723 #-> sub CPAN::Index::rd_authindex ;
3724 sub rd_authindex {
3725     my($cl, $index_target) = @_;
3726     my @lines;
3727     return unless defined $index_target;
3728     $CPAN::Frontend->myprint("Going to read $index_target\n");
3729     local(*FH);
3730     tie *FH, 'CPAN::Tarzip', $index_target;
3731     local($/) = "\n";
3732     local($_);
3733     push @lines, split /\012/ while <FH>;
3734     my $i = 0;
3735     my $modulus = int($#lines/75) || 1;
3736     CPAN->debug(sprintf "modulus[%d]lines[%s]", $modulus, scalar @lines) if $CPAN::DEBUG;
3737     foreach (@lines) {
3738         my($userid,$fullname,$email) =
3739             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3740         next unless $userid && $fullname && $email;
3741
3742         # instantiate an author object
3743         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3744         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3745         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
3746         return if $CPAN::Signal;
3747     }
3748     $CPAN::Frontend->myprint("DONE\n");
3749 }
3750
3751 sub userid {
3752   my($self,$dist) = @_;
3753   $dist = $self->{'id'} unless defined $dist;
3754   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3755   $ret;
3756 }
3757
3758 #-> sub CPAN::Index::rd_modpacks ;
3759 sub rd_modpacks {
3760     my($self, $index_target) = @_;
3761     return unless defined $index_target;
3762     $CPAN::Frontend->myprint("Going to read $index_target\n");
3763     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3764     local $_;
3765     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
3766     my $slurp = "";
3767     my $chunk;
3768     while (my $bytes = $fh->READ(\$chunk,8192)) {
3769         $slurp.=$chunk;
3770     }
3771     my @lines = split /\012/, $slurp;
3772     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
3773     undef $fh;
3774     # read header
3775     my($line_count,$last_updated);
3776     while (@lines) {
3777         my $shift = shift(@lines);
3778         last if $shift =~ /^\s*$/;
3779         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3780         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3781     }
3782     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
3783     if (not defined $line_count) {
3784
3785         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
3786 Please check the validity of the index file by comparing it to more
3787 than one CPAN mirror. I'll continue but problems seem likely to
3788 happen.\a
3789 });
3790
3791         $CPAN::Frontend->mysleep(5);
3792     } elsif ($line_count != scalar @lines) {
3793
3794         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
3795 contains a Line-Count header of %d but I see %d lines there. Please
3796 check the validity of the index file by comparing it to more than one
3797 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3798 $index_target, $line_count, scalar(@lines));
3799
3800     }
3801     if (not defined $last_updated) {
3802
3803         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
3804 Please check the validity of the index file by comparing it to more
3805 than one CPAN mirror. I'll continue but problems seem likely to
3806 happen.\a
3807 });
3808
3809         $CPAN::Frontend->mysleep(5);
3810     } else {
3811
3812         $CPAN::Frontend
3813             ->myprint(sprintf qq{  Database was generated on %s\n},
3814                       $last_updated);
3815         $DATE_OF_02 = $last_updated;
3816
3817         my $age = time;
3818         if ($CPAN::META->has_inst('HTTP::Date')) {
3819             require HTTP::Date;
3820             $age -= HTTP::Date::str2time($last_updated);
3821         } else {
3822             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
3823             require Time::Local;
3824             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
3825             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
3826             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
3827         }
3828         $age /= 3600*24;
3829         if ($age > 30) {
3830
3831             $CPAN::Frontend
3832                 ->mywarn(sprintf
3833                          qq{Warning: This index file is %d days old.
3834   Please check the host you chose as your CPAN mirror for staleness.
3835   I'll continue but problems seem likely to happen.\a\n},
3836                          $age);
3837
3838         } elsif ($age < -1) {
3839
3840             $CPAN::Frontend
3841                 ->mywarn(sprintf
3842                          qq{Warning: Your system date is %d days behind this index file!
3843   System time:          %s
3844   Timestamp index file: %s
3845   Please fix your system time, problems with the make command expected.\n},
3846                          -$age,
3847                          scalar gmtime,
3848                          $DATE_OF_02,
3849                         );
3850
3851         }
3852     }
3853
3854
3855     # A necessity since we have metadata_cache: delete what isn't
3856     # there anymore
3857     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3858     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3859     my(%exists);
3860     my $i = 0;
3861     my $modulus = int($#lines/75) || 1;
3862     foreach (@lines) {
3863         # before 1.56 we split into 3 and discarded the rest. From
3864         # 1.57 we assign remaining text to $comment thus allowing to
3865         # influence isa_perl
3866         my($mod,$version,$dist,$comment) = split " ", $_, 4;
3867         my($bundle,$id,$userid);
3868
3869         if ($mod eq 'CPAN' &&
3870             ! (
3871                CPAN::Queue->exists('Bundle::CPAN') ||
3872                CPAN::Queue->exists('CPAN')
3873               )
3874            ) {
3875             local($^W)= 0;
3876             if ($version > $CPAN::VERSION){
3877                 $CPAN::Frontend->mywarn(qq{
3878   New CPAN.pm version (v$version) available.
3879   [Currently running version is v$CPAN::VERSION]
3880   You might want to try
3881     install CPAN
3882     reload cpan
3883   to both upgrade CPAN.pm and run the new version without leaving
3884   the current session.
3885
3886 }); #});
3887                 $CPAN::Frontend->mysleep(2);
3888                 $CPAN::Frontend->myprint(qq{\n});
3889             }
3890             last if $CPAN::Signal;
3891         } elsif ($mod =~ /^Bundle::(.*)/) {
3892             $bundle = $1;
3893         }
3894
3895         if ($bundle){
3896             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
3897             # Let's make it a module too, because bundles have so much
3898             # in common with modules.
3899
3900             # Changed in 1.57_63: seems like memory bloat now without
3901             # any value, so commented out
3902
3903             # $CPAN::META->instance('CPAN::Module',$mod);
3904
3905         } else {
3906
3907             # instantiate a module object
3908             $id = $CPAN::META->instance('CPAN::Module',$mod);
3909
3910         }
3911
3912         # Although CPAN prohibits same name with different version the
3913         # indexer may have changed the version for the same distro
3914         # since the last time ("Force Reindexing" feature)
3915         if ($id->cpan_file ne $dist
3916             ||
3917             $id->cpan_version ne $version
3918            ){
3919             $userid = $id->userid || $self->userid($dist);
3920             $id->set(
3921                      'CPAN_USERID' => $userid,
3922                      'CPAN_VERSION' => $version,
3923                      'CPAN_FILE' => $dist,
3924                     );
3925         }
3926
3927         # instantiate a distribution object
3928         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3929           # we do not need CONTAINSMODS unless we do something with
3930           # this dist, so we better produce it on demand.
3931
3932           ## my $obj = $CPAN::META->instance(
3933           ##                              'CPAN::Distribution' => $dist
3934           ##                             );
3935           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3936         } else {
3937           $CPAN::META->instance(
3938                                 'CPAN::Distribution' => $dist
3939                                )->set(
3940                                       'CPAN_USERID' => $userid,
3941                                       'CPAN_COMMENT' => $comment,
3942                                      );
3943         }
3944         if ($secondtime) {
3945             for my $name ($mod,$dist) {
3946                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
3947                 $exists{$name} = undef;
3948             }
3949         }
3950         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
3951         return if $CPAN::Signal;
3952     }
3953     $CPAN::Frontend->myprint("DONE\n");
3954     if ($secondtime) {
3955         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3956             for my $o ($CPAN::META->all_objects($class)) {
3957                 next if exists $exists{$o->{ID}};
3958                 $CPAN::META->delete($class,$o->{ID});
3959                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3960                 #     if $CPAN::DEBUG;
3961             }
3962         }
3963     }
3964 }
3965
3966 #-> sub CPAN::Index::rd_modlist ;
3967 sub rd_modlist {
3968     my($cl,$index_target) = @_;
3969     return unless defined $index_target;
3970     $CPAN::Frontend->myprint("Going to read $index_target\n");
3971     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3972     local $_;
3973     my $slurp = "";
3974     my $chunk;
3975     while (my $bytes = $fh->READ(\$chunk,8192)) {
3976         $slurp.=$chunk;
3977     }
3978     my @eval2 = split /\012/, $slurp;
3979
3980     while (@eval2) {
3981         my $shift = shift(@eval2);
3982         if ($shift =~ /^Date:\s+(.*)/){
3983             if ($DATE_OF_03 eq $1){
3984                 $CPAN::Frontend->myprint("Unchanged.\n");
3985                 return;
3986             }
3987             ($DATE_OF_03) = $1;
3988         }
3989         last if $shift =~ /^\s*$/;
3990     }
3991     push @eval2, q{CPAN::Modulelist->data;};
3992     local($^W) = 0;
3993     my($comp) = Safe->new("CPAN::Safe1");
3994     my($eval2) = join("\n", @eval2);
3995     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
3996     my $ret = $comp->reval($eval2);
3997     Carp::confess($@) if $@;
3998     return if $CPAN::Signal;
3999     my $i = 0;
4000     my $until = keys(%$ret) - 1;
4001     my $modulus = int($until/75) || 1;
4002     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4003     for (keys %$ret) {
4004         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4005         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4006         $obj->set(%{$ret->{$_}});
4007         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
4008         return if $CPAN::Signal;
4009     }
4010     $CPAN::Frontend->myprint("DONE\n");
4011 }
4012
4013 #-> sub CPAN::Index::write_metadata_cache ;
4014 sub write_metadata_cache {
4015     my($self) = @_;
4016     return unless $CPAN::Config->{'cache_metadata'};
4017     return unless $CPAN::META->has_usable("Storable");
4018     my $cache;
4019     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4020                       CPAN::Distribution)) {
4021         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4022     }
4023     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4024     $cache->{last_time} = $LAST_TIME;
4025     $cache->{DATE_OF_02} = $DATE_OF_02;
4026     $cache->{PROTOCOL} = PROTOCOL;
4027     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4028     eval { Storable::nstore($cache, $metadata_file) };
4029     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4030 }
4031
4032 #-> sub CPAN::Index::read_metadata_cache ;
4033 sub read_metadata_cache {
4034     my($self) = @_;
4035     return unless $CPAN::Config->{'cache_metadata'};
4036     return unless $CPAN::META->has_usable("Storable");
4037     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4038     return unless -r $metadata_file and -f $metadata_file;
4039     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4040     my $cache;
4041     eval { $cache = Storable::retrieve($metadata_file) };
4042     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4043     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4044         $LAST_TIME = 0;
4045         return;
4046     }
4047     if (exists $cache->{PROTOCOL}) {
4048         if (PROTOCOL > $cache->{PROTOCOL}) {
4049             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4050                                             "with protocol v%s, requiring v%s\n",
4051                                             $cache->{PROTOCOL},
4052                                             PROTOCOL)
4053                                    );
4054             return;
4055         }
4056     } else {
4057         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4058                                 "with protocol v1.0\n");
4059         return;
4060     }
4061     my $clcnt = 0;
4062     my $idcnt = 0;
4063     while(my($class,$v) = each %$cache) {
4064         next unless $class =~ /^CPAN::/;
4065         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4066         while (my($id,$ro) = each %$v) {
4067             $CPAN::META->{readwrite}{$class}{$id} ||=
4068                 $class->new(ID=>$id, RO=>$ro);
4069             $idcnt++;
4070         }
4071         $clcnt++;
4072     }
4073     unless ($clcnt) { # sanity check
4074         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4075         return;
4076     }
4077     if ($idcnt < 1000) {
4078         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4079                                  "in $metadata_file\n");
4080         return;
4081     }
4082     $CPAN::META->{PROTOCOL} ||=
4083         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4084                             # does initialize to some protocol
4085     $LAST_TIME = $cache->{last_time};
4086     $DATE_OF_02 = $cache->{DATE_OF_02};
4087     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4088         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4089     return;
4090 }
4091
4092 package CPAN::InfoObj;
4093 use strict;
4094
4095 sub ro {
4096     my $self = shift;
4097     exists $self->{RO} and return $self->{RO};
4098 }
4099
4100 sub cpan_userid {
4101     my $self = shift;
4102     my $ro = $self->ro or return "N/A"; # N/A for bundles found locally
4103     return $ro->{CPAN_USERID} || "N/A";
4104 }
4105
4106 sub id { shift->{ID}; }
4107
4108 #-> sub CPAN::InfoObj::new ;
4109 sub new {
4110     my $this = bless {}, shift;
4111     %$this = @_;
4112     $this
4113 }
4114
4115 # The set method may only be used by code that reads index data or
4116 # otherwise "objective" data from the outside world. All session
4117 # related material may do anything else with instance variables but
4118 # must not touch the hash under the RO attribute. The reason is that
4119 # the RO hash gets written to Metadata file and is thus persistent.
4120
4121 #-> sub CPAN::InfoObj::safe_chdir ;
4122 sub safe_chdir {
4123   my($self,$todir) = @_;
4124   # we die if we cannot chdir and we are debuggable
4125   Carp::confess("safe_chdir called without todir argument")
4126         unless defined $todir and length $todir;
4127   if (chdir $todir) {
4128     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4129         if $CPAN::DEBUG;
4130   } else {
4131     if (-e $todir) {
4132         unless (-x $todir) {
4133             unless (chmod 0755, $todir) {
4134                 my $cwd = CPAN::anycwd();
4135                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4136                                         "permission to change the permission; cannot ".
4137                                         "chdir to '$todir'\n");
4138                 $CPAN::Frontend->mysleep(5);
4139                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4140                                        qq{to todir[$todir]: $!});
4141             }
4142         }
4143     } else {
4144         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4145     }
4146     if (chdir $todir) {
4147       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4148           if $CPAN::DEBUG;
4149     } else {
4150       my $cwd = CPAN::anycwd();
4151       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4152                              qq{to todir[$todir] (a chmod has been issued): $!});
4153     }
4154   }
4155 }
4156
4157 #-> sub CPAN::InfoObj::set ;
4158 sub set {
4159     my($self,%att) = @_;
4160     my $class = ref $self;
4161
4162     # This must be ||=, not ||, because only if we write an empty
4163     # reference, only then the set method will write into the readonly
4164     # area. But for Distributions that spring into existence, maybe
4165     # because of a typo, we do not like it that they are written into
4166     # the readonly area and made permanent (at least for a while) and
4167     # that is why we do not "allow" other places to call ->set.
4168     unless ($self->id) {
4169         CPAN->debug("Bug? Empty ID, rejecting");
4170         return;
4171     }
4172     my $ro = $self->{RO} =
4173         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4174
4175     while (my($k,$v) = each %att) {
4176         $ro->{$k} = $v;
4177     }
4178 }
4179
4180 #-> sub CPAN::InfoObj::as_glimpse ;
4181 sub as_glimpse {
4182     my($self) = @_;
4183     my(@m);
4184     my $class = ref($self);
4185     $class =~ s/^CPAN:://;
4186     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4187     push @m, sprintf "%-15s %s\n", $class, $id;
4188     join "", @m;
4189 }
4190
4191 #-> sub CPAN::InfoObj::as_string ;
4192 sub as_string {
4193     my($self) = @_;
4194     my(@m);
4195     my $class = ref($self);
4196     $class =~ s/^CPAN:://;
4197     push @m, $class, " id = $self->{ID}\n";
4198     my $ro;
4199     unless ($ro = $self->ro) {
4200         $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4201     }
4202     for (sort keys %$ro) {
4203         # next if m/^(ID|RO)$/;
4204         my $extra = "";
4205         if ($_ eq "CPAN_USERID") {
4206             $extra .= " (";
4207             $extra .= $self->fullname;
4208             my $email; # old perls!
4209             if ($email = $CPAN::META->instance("CPAN::Author",
4210                                                $self->cpan_userid
4211                                               )->email) {
4212                 $extra .= " <$email>";
4213             } else {
4214                 $extra .= " <no email>";
4215             }
4216             $extra .= ")";
4217         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4218             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
4219             next;
4220         }
4221         next unless defined $ro->{$_};
4222         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
4223     }
4224     for (sort keys %$self) {
4225         next if m/^(ID|RO)$/;
4226         if (ref($self->{$_}) eq "ARRAY") {
4227           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
4228         } elsif (ref($self->{$_}) eq "HASH") {
4229           push @m, sprintf(
4230                            "    %-12s %s\n",
4231                            $_,
4232                            join(" ",sort keys %{$self->{$_}}),
4233                           );
4234         } else {
4235           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
4236         }
4237     }
4238     join "", @m, "\n";
4239 }
4240
4241 #-> sub CPAN::InfoObj::fullname ;
4242 sub fullname {
4243     my($self) = @_;
4244     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4245 }
4246
4247 #-> sub CPAN::InfoObj::dump ;
4248 sub dump {
4249   my($self, $what) = @_;
4250   unless ($CPAN::META->has_inst("Data::Dumper")) {
4251       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4252   }
4253   local $Data::Dumper::Sortkeys;
4254   $Data::Dumper::Sortkeys = 1;
4255   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4256   if (length $out > 100000) {
4257       my $fh_pager = FileHandle->new;
4258       local($SIG{PIPE}) = "IGNORE";
4259       my $pager = $CPAN::Config->{'pager'} || "cat";
4260       $fh_pager->open("|$pager")
4261           or die "Could not open pager $pager\: $!";
4262       $fh_pager->print($out);
4263       close $fh_pager;
4264   } else {
4265       $CPAN::Frontend->myprint($out);
4266   }
4267 }
4268
4269 package CPAN::Author;
4270 use strict;
4271
4272 #-> sub CPAN::Author::force
4273 sub force {
4274     my $self = shift;
4275     $self->{force}++;
4276 }
4277
4278 #-> sub CPAN::Author::force
4279 sub unforce {
4280     my $self = shift;
4281     delete $self->{force};
4282 }
4283
4284 #-> sub CPAN::Author::id
4285 sub id {
4286     my $self = shift;
4287     my $id = $self->{ID};
4288     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4289     $id;
4290 }
4291
4292 #-> sub CPAN::Author::as_glimpse ;
4293 sub as_glimpse {
4294     my($self) = @_;
4295     my(@m);
4296     my $class = ref($self);
4297     $class =~ s/^CPAN:://;
4298     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4299                      $class,
4300                      $self->{ID},
4301                      $self->fullname,
4302                      $self->email);
4303     join "", @m;
4304 }
4305
4306 #-> sub CPAN::Author::fullname ;
4307 sub fullname {
4308     shift->ro->{FULLNAME};
4309 }
4310 *name = \&fullname;
4311
4312 #-> sub CPAN::Author::email ;
4313 sub email    { shift->ro->{EMAIL}; }
4314
4315 #-> sub CPAN::Author::ls ;
4316 sub ls {
4317     my $self = shift;
4318     my $glob = shift || "";
4319     my $silent = shift || 0;
4320     my $id = $self->id;
4321
4322     # adapted from CPAN::Distribution::verifyCHECKSUM ;
4323     my(@csf); # chksumfile
4324     @csf = $self->id =~ /(.)(.)(.*)/;
4325     $csf[1] = join "", @csf[0,1];
4326     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4327     my(@dl);
4328     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4329     unless (grep {$_->[2] eq $csf[1]} @dl) {
4330         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4331         return;
4332     }
4333     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4334     unless (grep {$_->[2] eq $csf[2]} @dl) {
4335         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4336         return;
4337     }
4338     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4339     if ($glob) {
4340         if ($CPAN::META->has_inst("Text::Glob")) {
4341             my $rglob = Text::Glob::glob_to_regex($glob);
4342             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4343         } else {
4344             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4345         }
4346     }
4347     $CPAN::Frontend->myprint(join "", map {
4348         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4349     } sort { $a->[2] cmp $b->[2] } @dl);
4350     @dl;
4351 }
4352
4353 # returns an array of arrays, the latter contain (size,mtime,filename)
4354 #-> sub CPAN::Author::dir_listing ;
4355 sub dir_listing {
4356     my $self = shift;
4357     my $chksumfile = shift;
4358     my $recursive = shift;
4359     my $may_ftp = shift;
4360
4361     my $lc_want =
4362         File::Spec->catfile($CPAN::Config->{keep_source_where},
4363                             "authors", "id", @$chksumfile);
4364
4365     my $fh;
4366
4367     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4368     # hazard.  (Without GPG installed they are not that much better,
4369     # though.)
4370     $fh = FileHandle->new;
4371     if (open($fh, $lc_want)) {
4372         my $line = <$fh>; close $fh;
4373         unlink($lc_want) unless $line =~ /PGP/;
4374     }
4375
4376     local($") = "/";
4377     # connect "force" argument with "index_expire".
4378     my $force = $self->{force};
4379     if (my @stat = stat $lc_want) {
4380         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4381     }
4382     my $lc_file;
4383     if ($may_ftp) {
4384         $lc_file = CPAN::FTP->localize(
4385                                        "authors/id/@$chksumfile",
4386                                        $lc_want,
4387                                        $force,
4388                                       );
4389         unless ($lc_file) {
4390             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4391             $chksumfile->[-1] .= ".gz";
4392             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4393                                            "$lc_want.gz",1);
4394             if ($lc_file) {
4395                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4396                 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4397             } else {
4398                 return;
4399             }
4400         }
4401     } else {
4402         $lc_file = $lc_want;
4403         # we *could* second-guess and if the user has a file: URL,
4404         # then we could look there. But on the other hand, if they do
4405         # have a file: URL, wy did they choose to set
4406         # $CPAN::Config->{show_upload_date} to false?
4407     }
4408
4409     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
4410     $fh = FileHandle->new;
4411     my($cksum);
4412     if (open $fh, $lc_file){
4413         local($/);
4414         my $eval = <$fh>;
4415         $eval =~ s/\015?\012/\n/g;
4416         close $fh;
4417         my($comp) = Safe->new();
4418         $cksum = $comp->reval($eval);
4419         if ($@) {
4420             rename $lc_file, "$lc_file.bad";
4421             Carp::confess($@) if $@;
4422         }
4423     } elsif ($may_ftp) {
4424         Carp::carp "Could not open '$lc_file' for reading.";
4425     } else {
4426         # Maybe should warn: "You may want to set show_upload_date to a true value"
4427         return;
4428     }
4429     my(@result,$f);
4430     for $f (sort keys %$cksum) {
4431         if (exists $cksum->{$f}{isdir}) {
4432             if ($recursive) {
4433                 my(@dir) = @$chksumfile;
4434                 pop @dir;
4435                 push @dir, $f, "CHECKSUMS";
4436                 push @result, map {
4437                     [$_->[0], $_->[1], "$f/$_->[2]"]
4438                 } $self->dir_listing(\@dir,1,$may_ftp);
4439             } else {
4440                 push @result, [ 0, "-", $f ];
4441             }
4442         } else {
4443             push @result, [
4444                            ($cksum->{$f}{"size"}||0),
4445                            $cksum->{$f}{"mtime"}||"---",
4446                            $f
4447                           ];
4448         }
4449     }
4450     @result;
4451 }
4452
4453 package CPAN::Distribution;
4454 use strict;
4455
4456 # Accessors
4457 sub cpan_comment {
4458     my $self = shift;
4459     my $ro = $self->ro or return;
4460     $ro->{CPAN_COMMENT}
4461 }
4462
4463 # CPAN::Distribution::undelay
4464 sub undelay {
4465     my $self = shift;
4466     delete $self->{later};
4467 }
4468
4469 # add the A/AN/ stuff
4470 # CPAN::Distribution::normalize
4471 sub normalize {
4472     my($self,$s) = @_;
4473     $s = $self->id unless defined $s;
4474     if (
4475         $s =~ tr|/|| == 1
4476         or
4477         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
4478        ) {
4479         return $s if $s =~ m:^N/A|^Contact Author: ;
4480         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
4481             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
4482         CPAN->debug("s[$s]") if $CPAN::DEBUG;
4483     }
4484     $s;
4485 }
4486
4487 #-> sub CPAN::Distribution::author ;
4488 sub author {
4489     my($self) = @_;
4490     my($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
4491     CPAN::Shell->expand("Author",$authorid);
4492 }
4493
4494 # tries to get the yaml from CPAN instead of the distro itself:
4495 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
4496 sub fast_yaml {
4497     my($self) = @_;
4498     my $meta = $self->pretty_id;
4499     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
4500     my(@ls) = CPAN::Shell->globls($meta);
4501     my $norm = $self->normalize($meta);
4502
4503     my($local_file);
4504     my($local_wanted) =
4505         File::Spec->catfile(
4506                             $CPAN::Config->{keep_source_where},
4507                             "authors",
4508                             "id",
4509                             split(/\//,$norm)
4510                            );
4511     $self->debug("Doing localize") if $CPAN::DEBUG;
4512     unless ($local_file =
4513             CPAN::FTP->localize("authors/id/$norm",
4514                                 $local_wanted)) {
4515         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
4516     }
4517     my $yaml = CPAN->_yaml_loadfile($local_file);
4518 }
4519
4520 #-> sub CPAN::Distribution::pretty_id
4521 sub pretty_id {
4522     my $self = shift;
4523     my $id = $self->id;
4524     return $id unless $id =~ m|^./../|;
4525     substr($id,5);
4526 }
4527
4528 # mark as dirty/clean
4529 #-> sub CPAN::Distribution::color_cmd_tmps ;
4530 sub color_cmd_tmps {
4531     my($self) = shift;
4532     my($depth) = shift || 0;
4533     my($color) = shift || 0;
4534     my($ancestors) = shift || [];
4535     # a distribution needs to recurse into its prereq_pms
4536
4537     return if exists $self->{incommandcolor}
4538         && $self->{incommandcolor}==$color;
4539     if ($depth>=100){
4540         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4541     }
4542     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4543     my $prereq_pm = $self->prereq_pm;
4544     if (defined $prereq_pm) {
4545       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
4546                            keys %{$prereq_pm->{build_requires}||{}}) {
4547             next PREREQ if $pre eq "perl";
4548             my $premo;
4549             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
4550                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
4551                 $CPAN::Frontend->mysleep(2);
4552                 next PREREQ;
4553             }
4554             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4555         }
4556     }
4557     if ($color==0) {
4558         delete $self->{sponsored_mods};
4559         delete $self->{badtestcnt};
4560     }
4561     $self->{incommandcolor} = $color;
4562 }
4563
4564 #-> sub CPAN::Distribution::as_string ;
4565 sub as_string {
4566   my $self = shift;
4567   $self->containsmods;
4568   $self->upload_date;
4569   $self->SUPER::as_string(@_);
4570 }
4571
4572 #-> sub CPAN::Distribution::containsmods ;
4573 sub containsmods {
4574   my $self = shift;
4575   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
4576   my $dist_id = $self->{ID};
4577   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
4578     my $mod_file = $mod->cpan_file or next;
4579     my $mod_id = $mod->{ID} or next;
4580     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
4581     # sleep 1;
4582     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
4583   }
4584   keys %{$self->{CONTAINSMODS}};
4585 }
4586
4587 #-> sub CPAN::Distribution::upload_date ;
4588 sub upload_date {
4589   my $self = shift;
4590   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4591   my(@local_wanted) = split(/\//,$self->id);
4592   my $filename = pop @local_wanted;
4593   push @local_wanted, "CHECKSUMS";
4594   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4595   return unless $author;
4596   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4597   return unless @dl;
4598   my($dirent) = grep { $_->[2] eq $filename } @dl;
4599   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4600   return unless $dirent->[1];
4601   return $self->{UPLOAD_DATE} = $dirent->[1];
4602 }
4603
4604 #-> sub CPAN::Distribution::uptodate ;
4605 sub uptodate {
4606     my($self) = @_;
4607     my $c;
4608     foreach $c ($self->containsmods) {
4609         my $obj = CPAN::Shell->expandany($c);
4610         unless ($obj->uptodate){
4611             my $id = $self->pretty_id;
4612             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
4613             return 0;
4614         }
4615     }
4616     return 1;
4617 }
4618
4619 #-> sub CPAN::Distribution::called_for ;
4620 sub called_for {
4621     my($self,$id) = @_;
4622     $self->{CALLED_FOR} = $id if defined $id;
4623     return $self->{CALLED_FOR};
4624 }
4625
4626 #-> sub CPAN::Distribution::get ;
4627 sub get {
4628     my($self) = @_;
4629   EXCUSE: {
4630         my @e;
4631         exists $self->{'build_dir'} and push @e,
4632             "Is already unwrapped into directory $self->{'build_dir'}";
4633         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4634     }
4635     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4636
4637     #
4638     # Get the file on local disk
4639     #
4640
4641     my($local_file);
4642     my($local_wanted) =
4643         File::Spec->catfile(
4644                             $CPAN::Config->{keep_source_where},
4645                             "authors",
4646                             "id",
4647                             split(/\//,$self->id)
4648                            );
4649
4650     $self->debug("Doing localize") if $CPAN::DEBUG;
4651     unless ($local_file =
4652             CPAN::FTP->localize("authors/id/$self->{ID}",
4653                                 $local_wanted)) {
4654         my $note = "";
4655         if ($CPAN::Index::DATE_OF_02) {
4656             $note = "Note: Current database in memory was generated ".
4657                 "on $CPAN::Index::DATE_OF_02\n";
4658         }
4659         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4660     }
4661     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4662     $self->{localfile} = $local_file;
4663     return if $CPAN::Signal;
4664
4665     #
4666     # Check integrity
4667     #
4668     if ($CPAN::META->has_inst("Digest::SHA")) {
4669         $self->debug("Digest::SHA is installed, verifying");
4670         $self->verifyCHECKSUM;
4671     } else {
4672         $self->debug("Digest::SHA is NOT installed");
4673     }
4674     return if $CPAN::Signal;
4675
4676     #
4677     # Create a clean room and go there
4678     #
4679     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4680     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4681     $self->safe_chdir($builddir);
4682     $self->debug("Removing tmp") if $CPAN::DEBUG;
4683     File::Path::rmtree("tmp");
4684     unless (mkdir "tmp", 0755) {
4685         $CPAN::Frontend->unrecoverable_error(<<EOF);
4686 Couldn't mkdir '$builddir/tmp': $!
4687
4688 Cannot continue: Please find the reason why I cannot make the
4689 directory
4690 $builddir/tmp
4691 and fix the problem, then retry.
4692
4693 EOF
4694     }
4695     if ($CPAN::Signal){
4696         $self->safe_chdir($sub_wd);
4697         return;
4698     }
4699     $self->safe_chdir("tmp");
4700
4701     #
4702     # Unpack the goods
4703     #
4704     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4705     my $ct = CPAN::Tarzip->new($local_file);
4706     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
4707         $self->{was_uncompressed}++ unless $ct->gtest();
4708         $self->untar_me($ct);
4709     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4710         $self->unzip_me($ct);
4711     } else {
4712         $self->{was_uncompressed}++ unless $ct->gtest();
4713         $self->debug("calling pm2dir for local_file[$local_file]")
4714           if $CPAN::DEBUG;
4715         $local_file = $self->handle_singlefile($local_file);
4716 #    } else {
4717 #       $self->{archived} = "NO";
4718 #        $self->safe_chdir($sub_wd);
4719 #        return;
4720     }
4721
4722     # we are still in the tmp directory!
4723     # Let's check if the package has its own directory.
4724     my $dh = DirHandle->new(File::Spec->curdir)
4725         or Carp::croak("Couldn't opendir .: $!");
4726     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4727     $dh->close;
4728     my ($distdir,$packagedir);
4729     if (@readdir == 1 && -d $readdir[0]) {
4730         $distdir = $readdir[0];
4731         $packagedir = File::Spec->catdir($builddir,$distdir);
4732         $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4733             if $CPAN::DEBUG;
4734         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4735                                                     "$packagedir\n");
4736         File::Path::rmtree($packagedir);
4737         unless (File::Copy::move($distdir,$packagedir)) {
4738             $CPAN::Frontend->unrecoverable_error(<<EOF);
4739 Couldn't move '$distdir' to '$packagedir': $!
4740
4741 Cannot continue: Please find the reason why I cannot move
4742 $builddir/tmp/$distdir
4743 to
4744 $packagedir
4745 and fix the problem, then retry
4746
4747 EOF
4748         }
4749         $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4750                              $distdir,
4751                              $packagedir,
4752                              -e $packagedir,
4753                              -d $packagedir,
4754                             )) if $CPAN::DEBUG;
4755     } else {
4756         my $userid = $self->cpan_userid;
4757         unless ($userid) {
4758             CPAN->debug("no userid? self[$self]");
4759             $userid = "anon";
4760         }
4761         my $pragmatic_dir = $userid . '000';
4762         $pragmatic_dir =~ s/\W_//g;
4763         $pragmatic_dir++ while -d "../$pragmatic_dir";
4764         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4765         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4766         File::Path::mkpath($packagedir);
4767         my($f);
4768         for $f (@readdir) { # is already without "." and ".."
4769             my $to = File::Spec->catdir($packagedir,$f);
4770             File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4771         }
4772     }
4773     if ($CPAN::Signal){
4774         $self->safe_chdir($sub_wd);
4775         return;
4776     }
4777
4778     $self->{'build_dir'} = $packagedir;
4779     $self->safe_chdir($builddir);
4780     File::Path::rmtree("tmp");
4781
4782     $self->safe_chdir($packagedir);
4783     if ($CPAN::Config->{check_sigs}) {
4784         if ($CPAN::META->has_inst("Module::Signature")) {
4785             if (-f "SIGNATURE") {
4786                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4787                 my $rv = Module::Signature::verify();
4788                 if ($rv != Module::Signature::SIGNATURE_OK() and
4789                     $rv != Module::Signature::SIGNATURE_MISSING()) {
4790                     $CPAN::Frontend->myprint(
4791                                              qq{\nSignature invalid for }.
4792                                              qq{distribution file. }.
4793                                              qq{Please investigate.\n\n}.
4794                                              $self->as_string,
4795                                              $CPAN::META->instance(
4796                                                                    'CPAN::Author',
4797                                                                    $self->cpan_userid,
4798                                                                   )->as_string
4799                                             );
4800
4801                     my $wrap =
4802                         sprintf(qq{I'd recommend removing %s. Its signature
4803 is invalid. Maybe you have configured your 'urllist' with
4804 a bad URL. Please check this array with 'o conf urllist', and
4805 retry. For more information, try opening a subshell with
4806   look %s
4807 and there run
4808   cpansign -v
4809 },
4810                                 $self->{localfile},
4811                                 $self->pretty_id,
4812                                );
4813                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
4814                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
4815                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
4816                 } else {
4817                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
4818                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
4819                 }
4820             } else {
4821                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
4822             }
4823         } else {
4824             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4825         }
4826     }
4827     $self->safe_chdir($builddir);
4828     return if $CPAN::Signal;
4829
4830
4831     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4832     my($mpl_exists) = -f $mpl;
4833     unless ($mpl_exists) {
4834         # NFS has been reported to have racing problems after the
4835         # renaming of a directory in some environments.
4836         # This trick helps.
4837         $CPAN::Frontend->mysleep(1);
4838         my $mpldh = DirHandle->new($packagedir)
4839             or Carp::croak("Couldn't opendir $packagedir: $!");
4840         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4841         $mpldh->close;
4842     }
4843     my $prefer_installer = "eumm"; # eumm|mb
4844     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
4845         if ($mpl_exists) { # they *can* choose
4846             if ($CPAN::META->has_inst("Module::Build")) {
4847                 $prefer_installer = $CPAN::Config->{prefer_installer};
4848             }
4849         } else {
4850             $prefer_installer = "mb";
4851         }
4852     }
4853     if (lc($prefer_installer) eq "mb") {
4854         $self->{modulebuild} = 1;
4855     } elsif (! $mpl_exists) {
4856         $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4857                              $mpl,
4858                              CPAN::anycwd(),
4859                             )) if $CPAN::DEBUG;
4860         my($configure) = File::Spec->catfile($packagedir,"Configure");
4861         if (-f $configure) {
4862             # do we have anything to do?
4863             $self->{'configure'} = $configure;
4864         } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4865             $CPAN::Frontend->mywarn(qq{
4866 Package comes with a Makefile and without a Makefile.PL.
4867 We\'ll try to build it with that Makefile then.
4868 });
4869             $self->{writemakefile} = CPAN::Distrostatus->new("YES");
4870             $CPAN::Frontend->mysleep(2);
4871         } else {
4872             my $cf = $self->called_for || "unknown";
4873             if ($cf =~ m|/|) {
4874                 $cf =~ s|.*/||;
4875                 $cf =~ s|\W.*||;
4876             }
4877             $cf =~ s|[/\\:]||g; # risk of filesystem damage
4878             $cf = "unknown" unless length($cf);
4879             $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
4880   (The test -f "$mpl" returned false.)
4881   Writing one on our own (setting NAME to $cf)\a\n});
4882             $self->{had_no_makefile_pl}++;
4883             $CPAN::Frontend->mysleep(3);
4884
4885             # Writing our own Makefile.PL
4886
4887             my $script = "";
4888             if ($self->{archived} eq "maybe_pl"){
4889                 my $fh = FileHandle->new;
4890                 my $script_file = File::Spec->catfile($packagedir,$local_file);
4891                 $fh->open($script_file)
4892                   or Carp::croak("Could not open $script_file: $!");
4893                 local $/ = "\n";
4894                 # name parsen und prereq
4895                 my($state) = "poddir";
4896                 my($name, $prereq) = ("", "");
4897                 while (<$fh>){
4898                     if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
4899                         if ($1 eq 'NAME') {
4900                             $state = "name";
4901                         } elsif ($1 eq 'PREREQUISITES') {
4902                             $state = "prereq";
4903                         }
4904                     } elsif ($state =~ m{^(name|prereq)$}) {
4905                         if (/^=/) {
4906                             $state = "poddir";
4907                         } elsif (/^\s*$/) {
4908                             # nop
4909                         } elsif ($state eq "name") {
4910                             if ($name eq "") {
4911                                 ($name) = /^(\S+)/;
4912                                 $state = "poddir";
4913                             }
4914                         } elsif ($state eq "prereq") {
4915                             $prereq .= $_;
4916                         }
4917                     } elsif (/^=cut\b/) {
4918                         last;
4919                     }
4920                 }
4921                 $fh->close;
4922
4923                 for ($name) {
4924                     s{.*<}{}; # strip X<...>
4925                     s{>.*}{};
4926                 }
4927                 chomp $prereq;
4928                 $prereq = join " ", split /\s+/, $prereq;
4929                 my($PREREQ_PM) = join("\n", map {
4930                     s{.*<}{}; # strip X<...>
4931                     s{>.*}{};
4932                     if (/[\s\'\"]/) { # prose?
4933                     } else {
4934                         s/[^\w:]$//; # period?
4935                         " "x28 . "'$_' => 0,";
4936                     }
4937                 } split /\s*,\s*/, $prereq);
4938
4939                 $script = "
4940               EXE_FILES => ['$name'],
4941               PREREQ_PM => {
4942 $PREREQ_PM
4943                            },
4944 ";
4945
4946                 my $to_file = File::Spec->catfile($packagedir, $name);
4947                 rename $script_file, $to_file
4948                   or die "Can't rename $script_file to $to_file: $!";
4949             }
4950
4951             my $fh = FileHandle->new;
4952             $fh->open(">$mpl")
4953                 or Carp::croak("Could not open >$mpl: $!");
4954             $fh->print(
4955 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4956 # because there was no Makefile.PL supplied.
4957 # Autogenerated on: }.scalar localtime().qq{
4958
4959 use ExtUtils::MakeMaker;
4960 WriteMakefile(
4961               NAME => q[$cf],$script
4962              );
4963 });
4964             $fh->close;
4965         }
4966     }
4967
4968     return $self;
4969 }
4970
4971 # CPAN::Distribution::untar_me ;
4972 sub untar_me {
4973     my($self,$ct) = @_;
4974     $self->{archived} = "tar";
4975     if ($ct->untar()) {
4976         $self->{unwrapped} = "YES";
4977     } else {
4978         $self->{unwrapped} = "NO";
4979     }
4980 }
4981
4982 # CPAN::Distribution::unzip_me ;
4983 sub unzip_me {
4984     my($self,$ct) = @_;
4985     $self->{archived} = "zip";
4986     if ($ct->unzip()) {
4987         $self->{unwrapped} = "YES";
4988     } else {
4989         $self->{unwrapped} = "NO";
4990     }
4991     return;
4992 }
4993
4994 sub handle_singlefile {
4995     my($self,$local_file) = @_;
4996
4997     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
4998         $self->{archived} = "pm";
4999     } else {
5000         $self->{archived} = "maybe_pl";
5001     }
5002
5003     my $to = File::Basename::basename($local_file);
5004     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
5005         if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
5006             $self->{unwrapped} = "YES";
5007         } else {
5008             $self->{unwrapped} = "NO";
5009         }
5010     } else {
5011         File::Copy::cp($local_file,".");
5012         $self->{unwrapped} = "YES";
5013     }
5014     return $to;
5015 }
5016
5017 #-> sub CPAN::Distribution::new ;
5018 sub new {
5019     my($class,%att) = @_;
5020
5021     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5022
5023     my $this = { %att };
5024     return bless $this, $class;
5025 }
5026
5027 #-> sub CPAN::Distribution::look ;
5028 sub look {
5029     my($self) = @_;
5030
5031     if ($^O eq 'MacOS') {
5032       $self->Mac::BuildTools::look;
5033       return;
5034     }
5035
5036     if (  $CPAN::Config->{'shell'} ) {
5037         $CPAN::Frontend->myprint(qq{
5038 Trying to open a subshell in the build directory...
5039 });
5040     } else {
5041         $CPAN::Frontend->myprint(qq{
5042 Your configuration does not define a value for subshells.
5043 Please define it with "o conf shell <your shell>"
5044 });
5045         return;
5046     }
5047     my $dist = $self->id;
5048     my $dir;
5049     unless ($dir = $self->dir) {
5050         $self->get;
5051     }
5052     unless ($dir ||= $self->dir) {
5053         $CPAN::Frontend->mywarn(qq{
5054 Could not determine which directory to use for looking at $dist.
5055 });
5056         return;
5057     }
5058     my $pwd  = CPAN::anycwd();
5059     $self->safe_chdir($dir);
5060     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5061     {
5062         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
5063         $ENV{CPAN_SHELL_LEVEL} += 1;
5064         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5065         unless (system($shell) == 0) {
5066             my $code = $? >> 8;
5067             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
5068         }
5069     }
5070     $self->safe_chdir($pwd);
5071 }
5072
5073 # CPAN::Distribution::cvs_import ;
5074 sub cvs_import {
5075     my($self) = @_;
5076     $self->get;
5077     my $dir = $self->dir;
5078
5079     my $package = $self->called_for;
5080     my $module = $CPAN::META->instance('CPAN::Module', $package);
5081     my $version = $module->cpan_version;
5082
5083     my $userid = $self->cpan_userid;
5084
5085     my $cvs_dir = (split /\//, $dir)[-1];
5086     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
5087     my $cvs_root =
5088       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
5089     my $cvs_site_perl =
5090       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
5091     if ($cvs_site_perl) {
5092         $cvs_dir = "$cvs_site_perl/$cvs_dir";
5093     }
5094     my $cvs_log = qq{"imported $package $version sources"};
5095     $version =~ s/\./_/g;
5096     # XXX cvs: undocumented and unclear how it was meant to work
5097     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
5098                "$cvs_dir", $userid, "v$version");
5099
5100     my $pwd  = CPAN::anycwd();
5101     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
5102
5103     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5104
5105     $CPAN::Frontend->myprint(qq{@cmd\n});
5106     system(@cmd) == 0 or
5107     # XXX cvs
5108         $CPAN::Frontend->mydie("cvs import failed");
5109     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5110 }
5111
5112 #-> sub CPAN::Distribution::readme ;
5113 sub readme {
5114     my($self) = @_;
5115     my($dist) = $self->id;
5116     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
5117     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
5118     my($local_file);
5119     my($local_wanted) =
5120          File::Spec->catfile(
5121                              $CPAN::Config->{keep_source_where},
5122                              "authors",
5123                              "id",
5124                              split(/\//,"$sans.readme"),
5125                             );
5126     $self->debug("Doing localize") if $CPAN::DEBUG;
5127     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
5128                                       $local_wanted)
5129         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
5130
5131     if ($^O eq 'MacOS') {
5132         Mac::BuildTools::launch_file($local_file);
5133         return;
5134     }
5135
5136     my $fh_pager = FileHandle->new;
5137     local($SIG{PIPE}) = "IGNORE";
5138     my $pager = $CPAN::Config->{'pager'} || "cat";
5139     $fh_pager->open("|$pager")
5140         or die "Could not open pager $pager\: $!";
5141     my $fh_readme = FileHandle->new;
5142     $fh_readme->open($local_file)
5143         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
5144     $CPAN::Frontend->myprint(qq{
5145 Displaying file
5146   $local_file
5147 with pager "$pager"
5148 });
5149     $fh_pager->print(<$fh_readme>);
5150     $fh_pager->close;
5151 }
5152
5153 #-> sub CPAN::Distribution::verifyCHECKSUM ;
5154 sub verifyCHECKSUM {
5155     my($self) = @_;
5156   EXCUSE: {
5157         my @e;
5158         $self->{CHECKSUM_STATUS} ||= "";
5159         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
5160         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5161     }
5162     my($lc_want,$lc_file,@local,$basename);
5163     @local = split(/\//,$self->id);
5164     pop @local;
5165     push @local, "CHECKSUMS";
5166     $lc_want =
5167         File::Spec->catfile($CPAN::Config->{keep_source_where},
5168                             "authors", "id", @local);
5169     local($") = "/";
5170     if (my $size = -s $lc_want) {
5171         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
5172         if ($self->CHECKSUM_check_file($lc_want,1)) {
5173             return $self->{CHECKSUM_STATUS} = "OK";
5174         }
5175     }
5176     $lc_file = CPAN::FTP->localize("authors/id/@local",
5177                                    $lc_want,1);
5178     unless ($lc_file) {
5179         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5180         $local[-1] .= ".gz";
5181         $lc_file = CPAN::FTP->localize("authors/id/@local",
5182                                        "$lc_want.gz",1);
5183         if ($lc_file) {
5184             $lc_file =~ s/\.gz(?!\n)\Z//;
5185             CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
5186         } else {
5187             return;
5188         }
5189     }
5190     if ($self->CHECKSUM_check_file($lc_file)) {
5191         return $self->{CHECKSUM_STATUS} = "OK";
5192     }
5193 }
5194
5195 #-> sub CPAN::Distribution::SIG_check_file ;
5196 sub SIG_check_file {
5197     my($self,$chk_file) = @_;
5198     my $rv = eval { Module::Signature::_verify($chk_file) };
5199
5200     if ($rv == Module::Signature::SIGNATURE_OK()) {
5201         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
5202         return $self->{SIG_STATUS} = "OK";
5203     } else {
5204         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
5205                                  qq{distribution file. }.
5206                                  qq{Please investigate.\n\n}.
5207                                  $self->as_string,
5208                                 $CPAN::META->instance(
5209                                                         'CPAN::Author',
5210                                                         $self->cpan_userid
5211                                                         )->as_string);
5212
5213         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
5214 is invalid. Maybe you have configured your 'urllist' with
5215 a bad URL. Please check this array with 'o conf urllist', and
5216 retry.};
5217
5218         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5219     }
5220 }
5221
5222 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
5223
5224 # sloppy is 1 when we have an old checksums file that maybe is good
5225 # enough
5226
5227 sub CHECKSUM_check_file {
5228     my($self,$chk_file,$sloppy) = @_;
5229     my($cksum,$file,$basename);
5230
5231     $sloppy ||= 0;
5232     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
5233     if ($CPAN::Config->{check_sigs}) {
5234         if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
5235             $self->debug("Module::Signature is installed, verifying");
5236             $self->SIG_check_file($chk_file);
5237         } else {
5238             $self->debug("Module::Signature is NOT installed");
5239         }
5240     }
5241
5242     $file = $self->{localfile};
5243     $basename = File::Basename::basename($file);
5244     my $fh = FileHandle->new;
5245     if (open $fh, $chk_file){
5246         local($/);
5247         my $eval = <$fh>;
5248         $eval =~ s/\015?\012/\n/g;
5249         close $fh;
5250         my($comp) = Safe->new();
5251         $cksum = $comp->reval($eval);
5252         if ($@) {
5253             rename $chk_file, "$chk_file.bad";
5254             Carp::confess($@) if $@;
5255         }
5256     } else {
5257         Carp::carp "Could not open $chk_file for reading";
5258     }
5259
5260     if (! ref $cksum or ref $cksum ne "HASH") {
5261         $CPAN::Frontend->mywarn(qq{
5262 Warning: checksum file '$chk_file' broken.
5263
5264 When trying to read that file I expected to get a hash reference
5265 for further processing, but got garbage instead.
5266 });
5267         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
5268         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5269         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
5270         return;
5271     } elsif (exists $cksum->{$basename}{sha256}) {
5272         $self->debug("Found checksum for $basename:" .
5273                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
5274
5275         open($fh, $file);
5276         binmode $fh;
5277         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
5278         $fh->close;
5279         $fh = CPAN::Tarzip->TIEHANDLE($file);
5280
5281         unless ($eq) {
5282           my $dg = Digest::SHA->new(256);
5283           my($data,$ref);
5284           $ref = \$data;
5285           while ($fh->READ($ref, 4096) > 0){
5286             $dg->add($data);
5287           }
5288           my $hexdigest = $dg->hexdigest;
5289           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
5290         }
5291
5292         if ($eq) {
5293           $CPAN::Frontend->myprint("Checksum for $file ok\n");
5294           return $self->{CHECKSUM_STATUS} = "OK";
5295         } else {
5296             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
5297                                      qq{distribution file. }.
5298                                      qq{Please investigate.\n\n}.
5299                                      $self->as_string,
5300                                      $CPAN::META->instance(
5301                                                            'CPAN::Author',
5302                                                            $self->cpan_userid
5303                                                           )->as_string);
5304
5305             my $wrap = qq{I\'d recommend removing $file. Its
5306 checksum is incorrect. Maybe you have configured your 'urllist' with
5307 a bad URL. Please check this array with 'o conf urllist', and
5308 retry.};
5309
5310             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5311
5312             # former versions just returned here but this seems a
5313             # serious threat that deserves a die
5314
5315             # $CPAN::Frontend->myprint("\n\n");
5316             # sleep 3;
5317             # return;
5318         }
5319         # close $fh if fileno($fh);
5320     } else {
5321         return if $sloppy;
5322         unless ($self->{CHECKSUM_STATUS}) {
5323             $CPAN::Frontend->mywarn(qq{
5324 Warning: No checksum for $basename in $chk_file.
5325
5326 The cause for this may be that the file is very new and the checksum
5327 has not yet been calculated, but it may also be that something is
5328 going awry right now.
5329 });
5330             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
5331             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5332         }
5333         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
5334         return;
5335     }
5336 }
5337
5338 #-> sub CPAN::Distribution::eq_CHECKSUM ;
5339 sub eq_CHECKSUM {
5340     my($self,$fh,$expect) = @_;
5341     if ($CPAN::META->has_inst("Digest::SHA")) {
5342         my $dg = Digest::SHA->new(256);
5343         my($data);
5344         while (read($fh, $data, 4096)){
5345             $dg->add($data);
5346         }
5347         my $hexdigest = $dg->hexdigest;
5348         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
5349         return $hexdigest eq $expect;
5350     }
5351     return 1;
5352 }
5353
5354 #-> sub CPAN::Distribution::force ;
5355
5356 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
5357 # effect by autoinspection, not by inspecting a global variable. One
5358 # of the reason why this was chosen to work that way was the treatment
5359 # of dependencies. They should not automatically inherit the force
5360 # status. But this has the downside that ^C and die() will return to
5361 # the prompt but will not be able to reset the force_update
5362 # attributes. We try to correct for it currently in the read_metadata
5363 # routine, and immediately before we check for a Signal. I hope this
5364 # works out in one of v1.57_53ff
5365
5366 # "Force get forgets previous error conditions"
5367
5368 #-> sub CPAN::Distribution::force ;
5369 sub force {
5370   my($self, $method) = @_;
5371   for my $att (qw(
5372   CHECKSUM_STATUS archived build_dir localfile make install unwrapped
5373   writemakefile modulebuild make_test signature_verify
5374  )) {
5375     delete $self->{$att};
5376   }
5377   if ($method && $method =~ /make|test|install/) {
5378     $self->{"force_update"}++; # name should probably have been force_install
5379   }
5380 }
5381
5382 sub notest {
5383   my($self, $method) = @_;
5384   # warn "XDEBUG: set notest for $self $method";
5385   $self->{"notest"}++; # name should probably have been force_install
5386 }
5387
5388 sub unnotest {
5389   my($self) = @_;
5390   # warn "XDEBUG: deleting notest";
5391   delete $self->{'notest'};
5392 }
5393
5394 #-> sub CPAN::Distribution::unforce ;
5395 sub unforce {
5396   my($self) = @_;
5397   delete $self->{'force_update'};
5398 }
5399
5400 #-> sub CPAN::Distribution::isa_perl ;
5401 sub isa_perl {
5402   my($self) = @_;
5403   my $file = File::Basename::basename($self->id);
5404   if ($file =~ m{ ^ perl
5405                   -?
5406                   (5)
5407                   ([._-])
5408                   (
5409                    \d{3}(_[0-4][0-9])?
5410                    |
5411                    \d+\.\d+
5412                   )
5413                   \.tar[._-]gz
5414                   (?!\n)\Z
5415                 }xs){
5416     return "$1.$3";
5417   } elsif ($self->cpan_comment
5418            &&
5419            $self->cpan_comment =~ /isa_perl\(.+?\)/){
5420     return $1;
5421   }
5422 }
5423
5424
5425 #-> sub CPAN::Distribution::perl ;
5426 sub perl {
5427     my ($self) = @_;
5428     if (! $self) {
5429         use Carp qw(carp);
5430         carp __PACKAGE__ . "::perl was called without parameters.";
5431     }
5432     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
5433 }
5434
5435
5436 #-> sub CPAN::Distribution::make ;
5437 sub make {
5438     my($self) = @_;
5439     my $make = $self->{modulebuild} ? "Build" : "make";
5440     # Emergency brake if they said install Pippi and get newest perl
5441     if ($self->isa_perl) {
5442       if (
5443           $self->called_for ne $self->id &&
5444           ! $self->{force_update}
5445          ) {
5446         # if we die here, we break bundles
5447         $CPAN::Frontend
5448             ->mywarn(sprintf(
5449                              qq{The most recent version "%s" of the module "%s"
5450 is part of the perl-%s distribution. To install that, you need to run
5451   force install %s   --or--
5452   install %s
5453 },
5454                              $CPAN::META->instance(
5455                                                    'CPAN::Module',
5456                                                    $self->called_for
5457                                                   )->cpan_version,
5458                              $self->called_for,
5459                              $self->isa_perl,
5460                              $self->called_for,
5461                              $self->id,
5462                             ));
5463         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
5464         $CPAN::Frontend->mysleep(1);
5465         return;
5466       }
5467     }
5468     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
5469     $self->get;
5470     if ($CPAN::Signal){
5471       delete $self->{force_update};
5472       return;
5473     }
5474   EXCUSE: {
5475         my @e;
5476         !$self->{archived} || $self->{archived} eq "NO" and push @e,
5477         "Is neither a tar nor a zip archive.";
5478
5479         !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
5480         "Had problems unarchiving. Please build manually";
5481
5482         unless ($self->{force_update}) {
5483             exists $self->{signature_verify} and (
5484                          $self->{signature_verify}->can("failed") ?
5485                          $self->{signature_verify}->failed :
5486                          $self->{signature_verify} =~ /^NO/
5487                         )
5488                 and push @e, "Did not pass the signature test.";
5489         }
5490
5491         if (exists $self->{writemakefile} &&
5492             (
5493              $self->{writemakefile}->can("failed") ?
5494              $self->{writemakefile}->failed :
5495              $self->{writemakefile} =~ /^NO/
5496             )) {
5497             # XXX maybe a retry would be in order?
5498             my $err = $self->{writemakefile}->can("text") ?
5499                 $self->{writemakefile}->text :
5500                     $self->{writemakefile};
5501             $err =~ s/^NO\s*//;
5502             $err ||= "Had some problem writing Makefile";
5503             $err .= ", won't make";
5504             push @e, $err;
5505         }
5506
5507         defined $self->{make} and push @e,
5508             "Has already been processed within this session";
5509
5510         if (exists $self->{later} and length($self->{later})) {
5511             if ($self->unsat_prereq) {
5512                 push @e, $self->{later};
5513 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
5514 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
5515 # are not sufficient to be sure if we really must/may do the delete
5516 # here. SO I accept the suggested patch for now. If we trigger a bug
5517 # again, I must go into deep contemplation about the {later} flag.
5518
5519 #            } else {
5520 #                delete $self->{later};
5521             }
5522         }
5523
5524         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
5525     }
5526     if ($CPAN::Signal){
5527       delete $self->{force_update};
5528       return;
5529     }
5530     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
5531     my $builddir = $self->dir or
5532         $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
5533     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
5534     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
5535
5536     if ($^O eq 'MacOS') {
5537         Mac::BuildTools::make($self);
5538         return;
5539     }
5540
5541     my $system;
5542     if ($self->{'configure'}) {
5543         $system = $self->{'configure'};
5544     } elsif ($self->{modulebuild}) {
5545         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5546         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
5547     } else {
5548         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5549         my $switch = "";
5550 # This needs a handler that can be turned on or off:
5551 #       $switch = "-MExtUtils::MakeMaker ".
5552 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
5553 #           if $] > 5.00310;
5554         my $makepl_arg = $self->make_x_arg("pl");
5555         $system = sprintf("%s%s Makefile.PL%s",
5556                           $perl,
5557                           $switch ? " $switch" : "",
5558                           $makepl_arg ? " $makepl_arg" : "",
5559                          );
5560     }
5561     local %ENV = %ENV;
5562     if (my $env = $self->prefs->{pl}{env}) {
5563         for my $e (keys %$env) {
5564             $ENV{$e} = $env->{$e};
5565         }
5566     }
5567     if (exists $self->{writemakefile}) {
5568     } else {
5569         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
5570         my($ret,$pid);
5571         $@ = "";
5572         my $go_via_alarm;
5573         if ($CPAN::Config->{inactivity_timeout}) {
5574             require Config;
5575             if ($Config::Config{d_alarm}
5576                 &&
5577                 $Config::Config{d_alarm} eq "define"
5578                ) {
5579                 $go_via_alarm++
5580             } else {
5581                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
5582                                         "variable 'inactivity_timeout' to ".
5583                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
5584                                         "on this machine the system call 'alarm' ".
5585                                         "isn't available. This means that we cannot ".
5586                                         "provide the feature of intercepting long ".
5587                                         "waiting code and will turn this feature off.\n"
5588                                        );
5589                 $CPAN::Config->{inactivity_timeout} = 0;
5590             }
5591         }
5592         if ($go_via_alarm) {
5593             eval {
5594                 alarm $CPAN::Config->{inactivity_timeout};
5595                 local $SIG{CHLD}; # = sub { wait };
5596                 if (defined($pid = fork)) {
5597                     if ($pid) { #parent
5598                         # wait;
5599                         waitpid $pid, 0;
5600                     } else {    #child
5601                         # note, this exec isn't necessary if
5602                         # inactivity_timeout is 0. On the Mac I'd
5603                         # suggest, we set it always to 0.
5604                         exec $system;
5605                     }
5606                 } else {
5607                     $CPAN::Frontend->myprint("Cannot fork: $!");
5608                     return;
5609                 }
5610             };
5611             alarm 0;
5612             if ($@){
5613                 kill 9, $pid;
5614                 waitpid $pid, 0;
5615                 my $err = "$@";
5616                 $CPAN::Frontend->myprint($err);
5617                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
5618                 $@ = "";
5619                 return;
5620             }
5621         } else {
5622             if (my $expect = $self->prefs->{pl}{expect}) {
5623                 $ret = $self->run_via_expect($system,$expect);
5624             } else {
5625                 $ret = system($system);
5626             }
5627             if ($ret != 0) {
5628                 $self->{writemakefile} = CPAN::Distrostatus
5629                     ->new("NO '$system' returned status $ret");
5630                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
5631                 return;
5632             }
5633         }
5634         if (-f "Makefile" || -f "Build") {
5635           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5636           delete $self->{make_clean}; # if cleaned before, enable next
5637         } else {
5638           $self->{writemakefile} = CPAN::Distrostatus
5639               ->new(qq{NO -- Unknown reason.});
5640         }
5641     }
5642     if ($CPAN::Signal){
5643       delete $self->{force_update};
5644       return;
5645     }
5646     if (my @prereq = $self->unsat_prereq){
5647         if ($prereq[0][0] eq "perl") {
5648             my $need = "requires perl '$prereq[0][1]'";
5649             my $id = $self->pretty_id;
5650             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
5651             $self->{make} = CPAN::Distrostatus->new("NO $need");
5652             return;
5653         } else {
5654             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
5655         }
5656     }
5657     if ($CPAN::Signal){
5658       delete $self->{force_update};
5659       return;
5660     }
5661     if ($self->{modulebuild}) {
5662         unless (-f "Build") {
5663             my $cwd = Cwd::cwd;
5664             $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
5665                                     " in cwd[$cwd]. Danger, Will Robinson!");
5666             $CPAN::Frontend->mysleep(5);
5667         }
5668         $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
5669     } else {
5670         $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
5671     }
5672     my $make_arg = $self->make_x_arg("make");
5673     $system = sprintf("%s%s",
5674                       $system,
5675                       $make_arg ? " $make_arg" : "",
5676                      );
5677     if (my $env = $self->prefs->{make}{env}) { # overriding the local
5678                                                # ENV of PL, not the
5679                                                # outer ENV, but
5680                                                # unlikely to be a risk
5681         for my $e (keys %$env) {
5682             $ENV{$e} = $env->{$e};
5683         }
5684     }
5685     if (system($system) == 0) {
5686          $CPAN::Frontend->myprint("  $system -- OK\n");
5687          $self->{make} = CPAN::Distrostatus->new("YES");
5688     } else {
5689          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
5690          $self->{make} = CPAN::Distrostatus->new("NO");
5691          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
5692     }
5693 }
5694
5695 # CPAN::Distribution::run_via_expect
5696 sub run_via_expect {
5697     my($self,$system,$expect) = @_;
5698     CPAN->debug("system[$system]expect[$expect]") if $CPAN::DEBUG;
5699     if ($CPAN::META->has_inst("Expect")) {
5700         my $expo = Expect->new;
5701         $expo->spawn($system);
5702       EXPECT: for (my $i = 0; $i < $#$expect; $i+=2) {
5703             my $regex = eval "qr{$expect->[$i]}";
5704             my $send = $expect->[$i+1];
5705             $expo->expect(10,
5706                           [ eof => sub {
5707                                 my $but = $expo->clear_accum;
5708                                 $CPAN::Frontend->mywarn("EOF (maybe harmless) system[$system]
5709 expected[$regex]\nbut[$but]\n\n");
5710                                 last EXPECT;
5711                             } ],
5712                           [ timeout => sub {
5713                                 my $but = $expo->clear_accum;
5714                                 $CPAN::Frontend->mydie("TIMEOUT system[$system]
5715 expected[$regex]\nbut[$but]\n\n");
5716                             } ],
5717                           -re => $regex);
5718             $expo->send($send);
5719         }
5720         $expo->soft_close;
5721         return $expo->exitstatus();
5722     } else {
5723         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
5724         return system($system);
5725     }
5726 }
5727
5728 # CPAN::Distribution::_find_prefs
5729 sub _find_prefs {
5730     my($self,$distro) = @_;
5731     my $distroid = $distro->pretty_id;
5732     CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
5733     my $prefs_dir = $CPAN::Config->{prefs_dir};
5734     eval { File::Path::mkpath($prefs_dir); };
5735     if ($@) {
5736         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
5737     }
5738     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
5739     if ($CPAN::META->has_inst($yaml_module)) {
5740         my $dh = DirHandle->new($prefs_dir)
5741             or die Carp::croak("Couldn't open '$prefs_dir': $!");
5742       DIRENT: for (sort $dh->read) {
5743             next if $_ eq "." || $_ eq "..";
5744             next unless /\.yml$/;
5745             my $abs = File::Spec->catfile($prefs_dir, $_);
5746             CPAN->debug("abs[$abs]") if $CPAN::DEBUG;
5747             if (-f $abs) {
5748                 my $yaml = CPAN->_yaml_loadfile($abs);
5749                 my $ok = 1;
5750                 my $match = $yaml->{match} or
5751                     $CPAN::Frontend->mydie("Nonconforming YAML file '$abs': ".
5752                                            "missing attribut 'match'. Please ".
5753                                            "remove, cannot continue.");
5754                 for my $sub_attribute (keys %$match) {
5755                     my $qr = eval "qr{$yaml->{match}{$sub_attribute}}";
5756                     if ($sub_attribute eq "module") {
5757                         my $okm = 0;
5758                         my @modules = $distro->containsmods;
5759                         for my $module (@modules) {
5760                             $okm ||= $module =~ /$qr/;
5761                             last if $okm;
5762                         }
5763                         $ok &&= $okm;
5764                     } elsif ($sub_attribute eq "distribution") {
5765                         my $okd = $distroid =~ /$qr/;
5766                         $ok &&= $okd;
5767                     } else {
5768                         $CPAN::Frontend->mydie("Nonconforming YAML file '$abs': ".
5769                                                "unknown sub_attribut '$sub_attribute'. ".
5770                                                "Please ".
5771                                                "remove, cannot continue.");
5772                     }
5773                 }
5774                 if ($ok) {
5775                     return {
5776                             prefs => $yaml,
5777                             prefs_file => $abs,
5778                            };
5779                 }
5780             }
5781         }
5782     } else {
5783         $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot read prefs '$prefs_dir'\n");
5784     }
5785     return;
5786 }
5787
5788 # CPAN::Distribution::prefs
5789 sub prefs {
5790     my($self) = @_;
5791     if (exists $self->{prefs}) {
5792         return $self->{prefs}; # XXX comment out during debugging
5793     }
5794     if ($CPAN::Config->{prefs_dir}) {
5795         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
5796         my $prefs = $self->_find_prefs($self);
5797         if ($prefs) {
5798             for my $x (qw(prefs prefs_file)) {
5799                 $self->{$x} = $prefs->{$x};
5800             }
5801             my $basename = File::Basename::basename($self->{prefs_file});
5802             my $filler1 = "_" x 22;
5803             my $filler2 = int(66 - length($basename))/2;
5804             $filler2 = 0 if $filler2 < 0;
5805             $filler2 = " " x $filler2;
5806             $CPAN::Frontend->myprint("
5807 $filler1 D i s t r o P r e f s $filler1
5808 $filler2 $basename $filler2
5809 ");
5810             $CPAN::Frontend->mysleep(1);
5811             return $self->{prefs};
5812         }
5813     }
5814     return +{};
5815 }
5816
5817 # CPAN::Distribution::make_x_arg
5818 sub make_x_arg {
5819     my($self, $whixh) = @_;
5820     my $make_x_arg;
5821     my $prefs = $self->prefs;
5822     if (
5823         $prefs
5824         && exists $prefs->{$whixh}
5825         && exists $prefs->{$whixh}{args}
5826         && $prefs->{$whixh}{args}
5827        ) {
5828         $make_x_arg = join(" ",
5829                            map {CPAN::HandleConfig
5830                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
5831                           );
5832     }
5833     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
5834     $make_x_arg ||= $CPAN::Config->{$what};
5835     return $make_x_arg;
5836 }
5837
5838 # CPAN::Distribution::_make_command
5839 sub _make_command {
5840     my ($self) = @_;
5841     if ($self) {
5842         return
5843             CPAN::HandleConfig
5844                 ->safe_quote(
5845                              $self->prefs->{cpanconfig}{make}
5846                              || $CPAN::Config->{make}
5847                              || $Config::Config{make}
5848                              || 'make'
5849                             );
5850     } else {
5851         # Old style call, without object. Deprecated
5852         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
5853         return
5854           safe_quote(undef,
5855                      $self->prefs->{cpanconfig}{make}
5856                      || $CPAN::Config->{make}
5857                      || $Config::Config{make}
5858                      || 'make');
5859     }
5860 }
5861
5862 #-> sub CPAN::Distribution::follow_prereqs ;
5863 sub follow_prereqs {
5864     my($self) = shift;
5865     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
5866     return unless @prereq_tuples;
5867     my @prereq = map { $_->[0] } @prereq_tuples;
5868     my $id = $self->id;
5869     my %map = (
5870                b => "build_requires",
5871                r => "requires",
5872                c => "commandline",
5873               );
5874     $CPAN::Frontend->
5875         myprint("---- Unsatisfied dependencies detected during\n".
5876                 "---- $id\n".
5877                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
5878                );
5879     my $follow = 0;
5880     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
5881         $follow = 1;
5882     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
5883         my $answer = CPAN::Shell::colorable_makemaker_prompt(
5884 "Shall I follow them and prepend them to the queue
5885 of modules we are processing right now?", "yes");
5886         $follow = $answer =~ /^\s*y/i;
5887     } else {
5888         local($") = ", ";
5889         $CPAN::Frontend->
5890             myprint("  Ignoring dependencies on modules @prereq\n");
5891     }
5892     if ($follow) {
5893         # color them as dirty
5894         for my $p (@prereq) {
5895             # warn "calling color_cmd_tmps(0,1)";
5896             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
5897         }
5898         # queue them and re-queue yourself
5899         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
5900                                reverse @prereq_tuples);
5901         $self->{later} = "Delayed until after prerequisites";
5902         return 1; # signal success to the queuerunner
5903     }
5904 }
5905
5906 #-> sub CPAN::Distribution::unsat_prereq ;
5907 # return ([Foo=>1],[Bar=>1.2]) for normal modules
5908 # return ([perl=>5.008]) if we need a newer perl than we are running under
5909 sub unsat_prereq {
5910     my($self) = @_;
5911     my $prereq_pm = $self->prereq_pm or return;
5912     my(@need);
5913     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
5914   NEED: while (my($need_module, $need_version) = each %merged) {
5915         my($have_version,$inst_file);
5916         if ($need_module eq "perl") {
5917             $have_version = $];
5918             $inst_file = $^X;
5919         } else {
5920             my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
5921             next if $nmo->uptodate;
5922             $inst_file = $nmo->inst_file;
5923
5924             # if they have not specified a version, we accept any installed one
5925             if (not defined $need_version or
5926                 $need_version eq "0" or
5927                 $need_version eq "undef") {
5928                 next if defined $inst_file;
5929             }
5930
5931             $have_version = $nmo->inst_version;
5932         }
5933
5934         # We only want to install prereqs if either they're not installed
5935         # or if the installed version is too old. We cannot omit this
5936         # check, because if 'force' is in effect, nobody else will check.
5937         if (defined $inst_file) {
5938             my(@all_requirements) = split /\s*,\s*/, $need_version;
5939             local($^W) = 0;
5940             my $ok = 0;
5941           RQ: for my $rq (@all_requirements) {
5942                 if ($rq =~ s|>=\s*||) {
5943                 } elsif ($rq =~ s|>\s*||) {
5944                     # 2005-12: one user
5945                     if (CPAN::Version->vgt($have_version,$rq)){
5946                         $ok++;
5947                     }
5948                     next RQ;
5949                 } elsif ($rq =~ s|!=\s*||) {
5950                     # 2005-12: no user
5951                     if (CPAN::Version->vcmp($have_version,$rq)){
5952                         $ok++;
5953                         next RQ;
5954                     } else {
5955                         last RQ;
5956                     }
5957                 } elsif ($rq =~ m|<=?\s*|) {
5958                     # 2005-12: no user
5959                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
5960                     $ok++;
5961                     next RQ;
5962                 }
5963                 if (! CPAN::Version->vgt($rq, $have_version)){
5964                     $ok++;
5965                 }
5966                 CPAN->debug(sprintf("need_module[%s]inst_file[%s]".
5967                                     "inst_version[%s]rq[%s]ok[%d]",
5968                                     $need_module,
5969                                     $inst_file,
5970                                     $have_version,
5971                                     CPAN::Version->readable($rq),
5972                                     $ok,
5973                                    )) if $CPAN::DEBUG;
5974             }
5975             next NEED if $ok == @all_requirements;
5976         }
5977
5978         if ($need_module eq "perl") {
5979             return ["perl", $need_version];
5980         }
5981         if ($self->{sponsored_mods}{$need_module}++){
5982             # We have already sponsored it and for some reason it's still
5983             # not available. So we do nothing. Or what should we do?
5984             # if we push it again, we have a potential infinite loop
5985             next;
5986         }
5987         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
5988         push @need, [$need_module,$needed_as];
5989     }
5990     @need;
5991 }
5992
5993 #-> sub CPAN::Distribution::read_yaml ;
5994 sub read_yaml {
5995     my($self) = @_;
5996     return $self->{yaml_content} if exists $self->{yaml_content};
5997     my $build_dir = $self->{build_dir};
5998     my $yaml = File::Spec->catfile($build_dir,"META.yml");
5999     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6000     return unless -f $yaml;
6001     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml); };
6002     if ($@) {
6003         return; # if we die, then we cannot read our own META.yml
6004     }
6005     if (not exists $self->{yaml_content}{dynamic_config}
6006         or $self->{yaml_content}{dynamic_config}
6007        ) {
6008         $self->{yaml_content} = undef;
6009     }
6010     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
6011         if $CPAN::DEBUG;
6012     return $self->{yaml_content};
6013 }
6014
6015 #-> sub CPAN::Distribution::prereq_pm ;
6016 sub prereq_pm {
6017     my($self) = @_;
6018     return $self->{prereq_pm} if
6019         exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
6020     return unless $self->{writemakefile}  # no need to have succeeded
6021                                           # but we must have run it
6022         || $self->{modulebuild};
6023     my($req,$breq);
6024     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
6025         $req =  $yaml->{requires} || {};
6026         $breq =  $yaml->{build_requires} || {};
6027         undef $req unless ref $req eq "HASH" && %$req;
6028         if ($req) {
6029             if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
6030                 my $eummv = do { local $^W = 0; $1+0; };
6031                 if ($eummv < 6.2501) {
6032                     # thanks to Slaven for digging that out: MM before
6033                     # that could be wrong because it could reflect a
6034                     # previous release
6035                     undef $req;
6036                 }
6037             }
6038             my $areq;
6039             my $do_replace;
6040             while (my($k,$v) = each %{$req||{}}) {
6041                 if ($v =~ /\d/) {
6042                     $areq->{$k} = $v;
6043                 } elsif ($k =~ /[A-Za-z]/ &&
6044                          $v =~ /[A-Za-z]/ &&
6045                          $CPAN::META->exists("Module",$v)
6046                         ) {
6047                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
6048                                             "requires hash: $k => $v; I'll take both ".
6049                                             "key and value as a module name\n");
6050                     $CPAN::Frontend->mysleep(1);
6051                     $areq->{$k} = 0;
6052                     $areq->{$v} = 0;
6053                     $do_replace++;
6054                 }
6055             }
6056             $req = $areq if $do_replace;
6057         }
6058     }
6059     unless ($req || $breq) {
6060         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
6061         my $makefile = File::Spec->catfile($build_dir,"Makefile");
6062         my $fh;
6063         if (-f $makefile
6064             and
6065             $fh = FileHandle->new("<$makefile\0")) {
6066             local($/) = "\n";
6067             while (<$fh>) {
6068                 last if /MakeMaker post_initialize section/;
6069                 my($p) = m{^[\#]
6070                            \s+PREREQ_PM\s+=>\s+(.+)
6071                        }x;
6072                 next unless $p;
6073                 # warn "Found prereq expr[$p]";
6074
6075                 #  Regexp modified by A.Speer to remember actual version of file
6076                 #  PREREQ_PM hash key wants, then add to
6077                 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
6078                     # In case a prereq is mentioned twice, complain.
6079                     if ( defined $req->{$1} ) {
6080                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
6081                             "last mention wins";
6082                     }
6083                     $req->{$1} = $2;
6084                 }
6085                 last;
6086             }
6087         } elsif (-f "Build") {
6088             if ($CPAN::META->has_inst("Module::Build")) {
6089                 eval {
6090                     $req  = Module::Build->current->requires();
6091                     $breq = Module::Build->current->build_requires();
6092                 };
6093                 if ($@) {
6094                     # HTML::Mason prompted for this with bleadperl@28900 or so
6095                     $CPAN::Frontend
6096                         ->mywarn(
6097                                  sprintf("Warning: while trying to determine ".
6098                                          "prerequisites for %s with the help of ".
6099                                          "Module::Build the following error ".
6100                                          "occurred: '%s'\n\nCannot care for prerequisites\n",
6101                                          $self->id,
6102                                          $@
6103                                         ));
6104                     $self->{prereq_pm_detected}++;
6105                     return $self->{prereq_pm} = {requires=>{},build_requires=>{}};
6106                 }
6107             }
6108         }
6109     }
6110     if (-f "Build.PL"
6111         && ! -f "Makefile.PL"
6112         && ! exists $req->{"Module::Build"}
6113         && ! $CPAN::META->has_inst("Module::Build")) {
6114         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
6115                                 "undeclared prerequisite.\n".
6116                                 "  Adding it now as such.\n"
6117                                );
6118         $CPAN::Frontend->mysleep(5);
6119         $req->{"Module::Build"} = 0;
6120         delete $self->{writemakefile};
6121     }
6122     $self->{prereq_pm_detected}++;
6123     return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
6124 }
6125
6126 #-> sub CPAN::Distribution::test ;
6127 sub test {
6128     my($self) = @_;
6129     $self->make;
6130     if ($CPAN::Signal){
6131       delete $self->{force_update};
6132       return;
6133     }
6134     # warn "XDEBUG: checking for notest: $self->{notest} $self";
6135     if ($self->{notest}) {
6136         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
6137         return 1;
6138     }
6139
6140     my $make = $self->{modulebuild} ? "Build" : "make";
6141     $CPAN::Frontend->myprint("Running $make test\n");
6142     if (my @prereq = $self->unsat_prereq){
6143         unless ($prereq[0][0] eq "perl") {
6144             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6145         }
6146     }
6147   EXCUSE: {
6148         my @e;
6149         unless (exists $self->{make} or exists $self->{later}) {
6150             push @e,
6151                 "Make had some problems, won't test";
6152         }
6153
6154         exists $self->{make} and
6155             (
6156              $self->{make}->can("failed") ?
6157              $self->{make}->failed :
6158              $self->{make} =~ /^NO/
6159             ) and push @e, "Can't test without successful make";
6160
6161         $self->{badtestcnt} ||= 0;
6162         $self->{badtestcnt} > 0 and
6163             push @e, "Won't repeat unsuccessful test during this command";
6164
6165         exists $self->{later} and length($self->{later}) and
6166             push @e, $self->{later};
6167
6168         if (exists $self->{build_dir}) {
6169             if ($CPAN::META->{is_tested}{$self->{build_dir}}
6170                 &&
6171                 exists $self->{make_test}
6172                 &&
6173                 !(
6174                   $self->{make_test}->can("failed") ?
6175                   $self->{make_test}->failed :
6176                   $self->{make_test} =~ /^NO/
6177                  )
6178                ) {
6179                 push @e, "Already tested successfully";
6180             }
6181         } elsif (!@e) {
6182             push @e, "Has no own directory";
6183         }
6184
6185         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6186     }
6187     chdir $self->{'build_dir'} or
6188         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
6189     $self->debug("Changed directory to $self->{'build_dir'}")
6190         if $CPAN::DEBUG;
6191
6192     if ($^O eq 'MacOS') {
6193         Mac::BuildTools::make_test($self);
6194         return;
6195     }
6196
6197     if ($self->{modulebuild}) {
6198         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
6199         if (CPAN::Version->vlt($v,2.62)) {
6200             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
6201   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
6202             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
6203             return;
6204         }
6205     }
6206
6207     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6208                            ? $ENV{PERL5LIB}
6209                            : ($ENV{PERLLIB} || "");
6210
6211     $CPAN::META->set_perl5lib;
6212     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6213
6214     my $system;
6215     if ($self->{modulebuild}) {
6216         $system = sprintf "%s test", $self->_build_command();
6217     } else {
6218         $system = join " ", $self->_make_command(), "test";
6219     }
6220     my($tests_ok);
6221     local %ENV = %ENV;
6222     if (my $env = $self->prefs->{test}{env}) {
6223         for my $e (keys %$env) {
6224             $ENV{$e} = $env->{$e};
6225         }
6226     }
6227     my $expect = $self->prefs->{test}{expect};
6228     if ($expect && @$expect) {
6229         $tests_ok = $self->run_via_expect($system,$expect) == 0;
6230     } elsif ( $CPAN::Config->{test_report} &&
6231               $CPAN::META->has_inst("CPAN::Reporter") ) {
6232         $tests_ok = CPAN::Reporter::test($self, $system);
6233     } else {
6234         $tests_ok = system($system) == 0;
6235     }
6236     if ( $tests_ok ) {
6237         {
6238             my @prereq;
6239             for my $m (keys %{$self->{sponsored_mods}}) {
6240                 my $m_obj = CPAN::Shell->expand("Module",$m);
6241                 my $d_obj = $m_obj->distribution;
6242                 if ($d_obj) {
6243                     if (!$d_obj->{make_test}
6244                         ||
6245                         $d_obj->{make_test}->failed){
6246                         #$m_obj->dump;
6247                         push @prereq, $m;
6248                     }
6249                 }
6250             }
6251             if (@prereq){
6252                 my $cnt = @prereq;
6253                 my $which = join ",", @prereq;
6254                 my $verb = $cnt == 1 ? "one dependency not OK ($which)" :
6255                     "$cnt dependencies missing ($which)";
6256                 $CPAN::Frontend->mywarn("Tests succeeded but $verb\n");
6257                 $self->{make_test} = CPAN::Distrostatus->new("NO -- $verb");
6258                 return;
6259             }
6260         }
6261
6262         $CPAN::Frontend->myprint("  $system -- OK\n");
6263         $CPAN::META->is_tested($self->{'build_dir'});
6264         $self->{make_test} = CPAN::Distrostatus->new("YES");
6265     } else {
6266         $self->{make_test} = CPAN::Distrostatus->new("NO");
6267         $self->{badtestcnt}++;
6268         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6269     }
6270 }
6271
6272 #-> sub CPAN::Distribution::clean ;
6273 sub clean {
6274     my($self) = @_;
6275     my $make = $self->{modulebuild} ? "Build" : "make";
6276     $CPAN::Frontend->myprint("Running $make clean\n");
6277     unless (exists $self->{archived}) {
6278         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
6279                                 "/untarred, nothing done\n");
6280         return 1;
6281     }
6282     unless (exists $self->{build_dir}) {
6283         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
6284         return 1;
6285     }
6286   EXCUSE: {
6287         my @e;
6288         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
6289             push @e, "make clean already called once";
6290         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6291     }
6292     chdir $self->{'build_dir'} or
6293         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
6294     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
6295
6296     if ($^O eq 'MacOS') {
6297         Mac::BuildTools::make_clean($self);
6298         return;
6299     }
6300
6301     my $system;
6302     if ($self->{modulebuild}) {
6303         unless (-f "Build") {
6304             my $cwd = Cwd::cwd;
6305             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
6306                                     " in cwd[$cwd]. Danger, Will Robinson!");
6307             $CPAN::Frontend->mysleep(5);
6308         }
6309         $system = sprintf "%s clean", $self->_build_command();
6310     } else {
6311         $system  = join " ", $self->_make_command(), "clean";
6312     }
6313     if (system($system) == 0) {
6314       $CPAN::Frontend->myprint("  $system -- OK\n");
6315
6316       # $self->force;
6317
6318       # Jost Krieger pointed out that this "force" was wrong because
6319       # it has the effect that the next "install" on this distribution
6320       # will untar everything again. Instead we should bring the
6321       # object's state back to where it is after untarring.
6322
6323       for my $k (qw(
6324                     force_update
6325                     install
6326                     writemakefile
6327                     make
6328                     make_test
6329                    )) {
6330           delete $self->{$k};
6331       }
6332       $self->{make_clean} = CPAN::Distrostatus->new("YES");
6333
6334     } else {
6335       # Hmmm, what to do if make clean failed?
6336
6337       $self->{make_clean} = CPAN::Distrostatus->new("NO");
6338       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
6339
6340       # 2006-02-27: seems silly to me to force a make now
6341       # $self->force("make"); # so that this directory won't be used again
6342
6343     }
6344 }
6345
6346 #-> sub CPAN::Distribution::install ;
6347 sub install {
6348     my($self) = @_;
6349     $self->test;
6350     if ($CPAN::Signal){
6351       delete $self->{force_update};
6352       return;
6353     }
6354     my $make = $self->{modulebuild} ? "Build" : "make";
6355     $CPAN::Frontend->myprint("Running $make install\n");
6356   EXCUSE: {
6357         my @e;
6358         unless (exists $self->{make} or exists $self->{later}) {
6359             push @e,
6360                 "Make had some problems, won't install";
6361         }
6362
6363         exists $self->{make} and
6364             (
6365              $self->{make}->can("failed") ?
6366              $self->{make}->failed :
6367              $self->{make} =~ /^NO/
6368             ) and
6369                 push @e, "Make had returned bad status, install seems impossible";
6370
6371         if (exists $self->{build_dir}) {
6372         } elsif (!@e) {
6373             push @e, "Has no own directory";
6374         }
6375
6376         if (exists $self->{make_test} and
6377             (
6378              $self->{make_test}->can("failed") ?
6379              $self->{make_test}->failed :
6380              $self->{make_test} =~ /^NO/
6381             )){
6382             if ($self->{force_update}) {
6383                 $self->{make_test}->text("FAILED but failure ignored because ".
6384                                          "'force' in effect");
6385             } else {
6386                 push @e, "make test had returned bad status, ".
6387                     "won't install without force"
6388             }
6389         }
6390         if (exists $self->{'install'}) {
6391             if ($self->{'install'}->can("text") ?
6392                 $self->{'install'}->text eq "YES" :
6393                 $self->{'install'} =~ /^YES/
6394                ) {
6395                 push @e, "Already done";
6396             } else {
6397                 # comment in Todo on 2006-02-11; maybe retry?
6398                 push @e, "Already tried without success";
6399             }
6400         }
6401
6402         exists $self->{later} and length($self->{later}) and
6403             push @e, $self->{later};
6404
6405         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6406     }
6407     chdir $self->{'build_dir'} or
6408         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
6409     $self->debug("Changed directory to $self->{'build_dir'}")
6410         if $CPAN::DEBUG;
6411
6412     if ($^O eq 'MacOS') {
6413         Mac::BuildTools::make_install($self);
6414         return;
6415     }
6416
6417     my $system;
6418     if ($self->{modulebuild}) {
6419         my($mbuild_install_build_command) =
6420             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
6421                 $CPAN::Config->{mbuild_install_build_command} ?
6422                     $CPAN::Config->{mbuild_install_build_command} :
6423                         $self->_build_command();
6424         $system = sprintf("%s install %s",
6425                           $mbuild_install_build_command,
6426                           $CPAN::Config->{mbuild_install_arg},
6427                          );
6428     } else {
6429         my($make_install_make_command) =
6430             $self->prefs->{cpanconfig}{make_install_make_command}
6431                 || $CPAN::Config->{make_install_make_command}
6432                     || $self->_make_command();
6433         $system = sprintf("%s install %s",
6434                           $make_install_make_command,
6435                           $CPAN::Config->{make_install_arg},
6436                          );
6437     }
6438
6439     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
6440     my $brip = $self->prefs->{cpanconfig}{build_requires_install_policy};
6441     $brip ||= $CPAN::Config->{build_requires_install_policy};
6442     $brip ||="ask/yes";
6443     my $id = $self->id;
6444     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
6445     my $want_install = "yes";
6446     if ($reqtype eq "b") {
6447         if ($brip eq "no") {
6448             $want_install = "no";
6449         } elsif ($brip =~ m|^ask/(.+)|) {
6450             my $default = $1;
6451             $default = "yes" unless $default =~ /^(y|n)/i;
6452             $want_install =
6453                 CPAN::Shell::colorable_makemaker_prompt
6454                       ("$id is just needed temporarily during building or testing. ".
6455                        "Do you want to install it permanently? (Y/n)",
6456                        $default);
6457         }
6458     }
6459     unless ($want_install =~ /^y/i) {
6460         my $is_only = "is only 'build_requires'";
6461         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
6462         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
6463         delete $self->{force_update};
6464         return;
6465     }
6466     my($pipe) = FileHandle->new("$system $stderr |");
6467     my($makeout) = "";
6468     while (<$pipe>){
6469         print $_; # intentionally NOT use Frontend->myprint because it
6470                   # looks irritating when we markup in color what we
6471                   # just pass through from an external program
6472         $makeout .= $_;
6473     }
6474     $pipe->close;
6475     if ($?==0) {
6476         $CPAN::Frontend->myprint("  $system -- OK\n");
6477         $CPAN::META->is_installed($self->{build_dir});
6478         return $self->{install} = CPAN::Distrostatus->new("YES");
6479     } else {
6480         $self->{install} = CPAN::Distrostatus->new("NO");
6481         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
6482         my $mimc =
6483             $self->prefs->{cpanconfig}{make_install_make_command} ||
6484                 $CPAN::Config->{make_install_make_command};
6485         if (
6486             $makeout =~ /permission/s
6487             && $> > 0
6488             && (
6489                 ! $mimc
6490                 || $mimc eq ($self->prefs->{cpanconfig}{make}
6491                              || $CPAN::Config->{make})
6492                )
6493            ) {
6494             $CPAN::Frontend->myprint(
6495                                      qq{----\n}.
6496                                      qq{  You may have to su }.
6497                                      qq{to root to install the package\n}.
6498                                      qq{  (Or you may want to run something like\n}.
6499                                      qq{    o conf make_install_make_command 'sudo make'\n}.
6500                                      qq{  to raise your permissions.}
6501                                     );
6502         }
6503     }
6504     delete $self->{force_update};
6505 }
6506
6507 #-> sub CPAN::Distribution::dir ;
6508 sub dir {
6509     shift->{'build_dir'};
6510 }
6511
6512 #-> sub CPAN::Distribution::perldoc ;
6513 sub perldoc {
6514     my($self) = @_;
6515
6516     my($dist) = $self->id;
6517     my $package = $self->called_for;
6518
6519     $self->_display_url( $CPAN::Defaultdocs . $package );
6520 }
6521
6522 #-> sub CPAN::Distribution::_check_binary ;
6523 sub _check_binary {
6524     my ($dist,$shell,$binary) = @_;
6525     my ($pid,$out);
6526
6527     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
6528       if $CPAN::DEBUG;
6529
6530     local *README;
6531     $pid = open README, "which $binary|"
6532       or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
6533     while (<README>) {
6534         $out .= $_;
6535     }
6536     close README or die "Could not run 'which $binary': $!";
6537
6538     $CPAN::Frontend->myprint(qq{   + $out \n})
6539       if $CPAN::DEBUG && $out;
6540
6541     return $out;
6542 }
6543
6544 #-> sub CPAN::Distribution::_display_url ;
6545 sub _display_url {
6546     my($self,$url) = @_;
6547     my($res,$saved_file,$pid,$out);
6548
6549     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
6550       if $CPAN::DEBUG;
6551
6552     # should we define it in the config instead?
6553     my $html_converter = "html2text";
6554
6555     my $web_browser = $CPAN::Config->{'lynx'} || undef;
6556     my $web_browser_out = $web_browser
6557       ? CPAN::Distribution->_check_binary($self,$web_browser)
6558         : undef;
6559
6560     if ($web_browser_out) {
6561         # web browser found, run the action
6562         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
6563         $CPAN::Frontend->myprint(qq{system[$browser $url]})
6564           if $CPAN::DEBUG;
6565         $CPAN::Frontend->myprint(qq{
6566 Displaying URL
6567   $url
6568 with browser $browser
6569 });
6570         $CPAN::Frontend->mysleep(1);
6571         system("$browser $url");
6572         if ($saved_file) { 1 while unlink($saved_file) }
6573     } else {
6574         # web browser not found, let's try text only
6575         my $html_converter_out =
6576           CPAN::Distribution->_check_binary($self,$html_converter);
6577         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
6578
6579         if ($html_converter_out ) {
6580             # html2text found, run it
6581             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
6582             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
6583                 unless defined($saved_file);
6584
6585             local *README;
6586             $pid = open README, "$html_converter $saved_file |"
6587               or $CPAN::Frontend->mydie(qq{
6588 Could not fork '$html_converter $saved_file': $!});
6589             my($fh,$filename);
6590             if ($CPAN::META->has_inst("File::Temp")) {
6591                 $fh = File::Temp->new(
6592                                       template => 'cpan_htmlconvert_XXXX',
6593                                       suffix => '.txt',
6594                                       unlink => 0,
6595                                      );
6596                 $filename = $fh->filename;
6597             } else {
6598                 $filename = "cpan_htmlconvert_$$.txt";
6599                 $fh = FileHandle->new();
6600                 open $fh, ">$filename" or die;
6601             }
6602             while (<README>) {
6603                 $fh->print($_);
6604             }
6605             close README or
6606                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
6607             my $tmpin = $fh->filename;
6608             $CPAN::Frontend->myprint(sprintf(qq{
6609 Run '%s %s' and
6610 saved output to %s\n},
6611                                              $html_converter,
6612                                              $saved_file,
6613                                              $tmpin,
6614                                             )) if $CPAN::DEBUG;
6615             close $fh;
6616             local *FH;
6617             open FH, $tmpin
6618                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
6619             my $fh_pager = FileHandle->new;
6620             local($SIG{PIPE}) = "IGNORE";
6621             my $pager = $CPAN::Config->{'pager'} || "cat";
6622             $fh_pager->open("|$pager")
6623                 or $CPAN::Frontend->mydie(qq{
6624 Could not open pager '$pager': $!});
6625             $CPAN::Frontend->myprint(qq{
6626 Displaying URL
6627   $url
6628 with pager "$pager"
6629 });
6630             $CPAN::Frontend->mysleep(1);
6631             $fh_pager->print(<FH>);
6632             $fh_pager->close;
6633         } else {
6634             # coldn't find the web browser or html converter
6635             $CPAN::Frontend->myprint(qq{
6636 You need to install lynx or $html_converter to use this feature.});
6637         }
6638     }
6639 }
6640
6641 #-> sub CPAN::Distribution::_getsave_url ;
6642 sub _getsave_url {
6643     my($dist, $shell, $url) = @_;
6644
6645     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
6646       if $CPAN::DEBUG;
6647
6648     my($fh,$filename);
6649     if ($CPAN::META->has_inst("File::Temp")) {
6650         $fh = File::Temp->new(
6651                               template => "cpan_getsave_url_XXXX",
6652                               suffix => ".html",
6653                               unlink => 0,
6654                              );
6655         $filename = $fh->filename;
6656     } else {
6657         $fh = FileHandle->new;
6658         $filename = "cpan_getsave_url_$$.html";
6659     }
6660     my $tmpin = $filename;
6661     if ($CPAN::META->has_usable('LWP')) {
6662         $CPAN::Frontend->myprint("Fetching with LWP:
6663   $url
6664 ");
6665         my $Ua;
6666         CPAN::LWP::UserAgent->config;
6667         eval { $Ua = CPAN::LWP::UserAgent->new; };
6668         if ($@) {
6669             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
6670             return;
6671         } else {
6672             my($var);
6673             $Ua->proxy('http', $var)
6674                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
6675             $Ua->no_proxy($var)
6676                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
6677         }
6678
6679         my $req = HTTP::Request->new(GET => $url);
6680         $req->header('Accept' => 'text/html');
6681         my $res = $Ua->request($req);
6682         if ($res->is_success) {
6683             $CPAN::Frontend->myprint(" + request successful.\n")
6684                 if $CPAN::DEBUG;
6685             print $fh $res->content;
6686             close $fh;
6687             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
6688                 if $CPAN::DEBUG;
6689             return $tmpin;
6690         } else {
6691             $CPAN::Frontend->myprint(sprintf(
6692                                              "LWP failed with code[%s], message[%s]\n",
6693                                              $res->code,
6694                                              $res->message,
6695                                             ));
6696             return;
6697         }
6698     } else {
6699         $CPAN::Frontend->mywarn("  LWP not available\n");
6700         return;
6701     }
6702 }
6703
6704 # sub CPAN::Distribution::_build_command
6705 sub _build_command {
6706     my($self) = @_;
6707     if ($^O eq "MSWin32") { # special code needed at least up to
6708                             # Module::Build 0.2611 and 0.2706; a fix
6709                             # in M:B has been promised 2006-01-30
6710         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
6711         return "$perl ./Build";
6712     }
6713     return "./Build";
6714 }
6715
6716 package CPAN::Bundle;
6717 use strict;
6718
6719 sub look {
6720     my $self = shift;
6721     $CPAN::Frontend->myprint($self->as_string);
6722 }
6723
6724 sub undelay {
6725     my $self = shift;
6726     delete $self->{later};
6727     for my $c ( $self->contains ) {
6728         my $obj = CPAN::Shell->expandany($c) or next;
6729         $obj->undelay;
6730     }
6731 }
6732
6733 # mark as dirty/clean
6734 #-> sub CPAN::Bundle::color_cmd_tmps ;
6735 sub color_cmd_tmps {
6736     my($self) = shift;
6737     my($depth) = shift || 0;
6738     my($color) = shift || 0;
6739     my($ancestors) = shift || [];
6740     # a module needs to recurse to its cpan_file, a distribution needs
6741     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
6742
6743     return if exists $self->{incommandcolor}
6744         && $self->{incommandcolor}==$color;
6745     if ($depth>=100){
6746         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
6747     }
6748     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6749
6750     for my $c ( $self->contains ) {
6751         my $obj = CPAN::Shell->expandany($c) or next;
6752         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
6753         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6754     }
6755     if ($color==0) {
6756         delete $self->{badtestcnt};
6757     }
6758     $self->{incommandcolor} = $color;
6759 }
6760
6761 #-> sub CPAN::Bundle::as_string ;
6762 sub as_string {
6763     my($self) = @_;
6764     $self->contains;
6765     # following line must be "=", not "||=" because we have a moving target
6766     $self->{INST_VERSION} = $self->inst_version;
6767     return $self->SUPER::as_string;
6768 }
6769
6770 #-> sub CPAN::Bundle::contains ;
6771 sub contains {
6772     my($self) = @_;
6773     my($inst_file) = $self->inst_file || "";
6774     my($id) = $self->id;
6775     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
6776     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
6777         undef $inst_file;
6778     }
6779     unless ($inst_file) {
6780         # Try to get at it in the cpan directory
6781         $self->debug("no inst_file") if $CPAN::DEBUG;
6782         my $cpan_file;
6783         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
6784               $cpan_file = $self->cpan_file;
6785         if ($cpan_file eq "N/A") {
6786             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
6787   Maybe stale symlink? Maybe removed during session? Giving up.\n");
6788         }
6789         my $dist = $CPAN::META->instance('CPAN::Distribution',
6790                                          $self->cpan_file);
6791         $dist->get;
6792         $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
6793         my($todir) = $CPAN::Config->{'cpan_home'};
6794         my(@me,$from,$to,$me);
6795         @me = split /::/, $self->id;
6796         $me[-1] .= ".pm";
6797         $me = File::Spec->catfile(@me);
6798         $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
6799         $to = File::Spec->catfile($todir,$me);
6800         File::Path::mkpath(File::Basename::dirname($to));
6801         File::Copy::copy($from, $to)
6802               or Carp::confess("Couldn't copy $from to $to: $!");
6803         $inst_file = $to;
6804     }
6805     my @result;
6806     my $fh = FileHandle->new;
6807     local $/ = "\n";
6808     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
6809     my $in_cont = 0;
6810     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
6811     while (<$fh>) {
6812         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
6813             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
6814         next unless $in_cont;
6815         next if /^=/;
6816         s/\#.*//;
6817         next if /^\s+$/;
6818         chomp;
6819         push @result, (split " ", $_, 2)[0];
6820     }
6821     close $fh;
6822     delete $self->{STATUS};
6823     $self->{CONTAINS} = \@result;
6824     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
6825     unless (@result) {
6826         $CPAN::Frontend->mywarn(qq{
6827 The bundle file "$inst_file" may be a broken
6828 bundlefile. It seems not to contain any bundle definition.
6829 Please check the file and if it is bogus, please delete it.
6830 Sorry for the inconvenience.
6831 });
6832     }
6833     @result;
6834 }
6835
6836 #-> sub CPAN::Bundle::find_bundle_file
6837 # $where is in local format, $what is in unix format
6838 sub find_bundle_file {
6839     my($self,$where,$what) = @_;
6840     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
6841 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
6842 ###    my $bu = File::Spec->catfile($where,$what);
6843 ###    return $bu if -f $bu;
6844     my $manifest = File::Spec->catfile($where,"MANIFEST");
6845     unless (-f $manifest) {
6846         require ExtUtils::Manifest;
6847         my $cwd = CPAN::anycwd();
6848         $self->safe_chdir($where);
6849         ExtUtils::Manifest::mkmanifest();
6850         $self->safe_chdir($cwd);
6851     }
6852     my $fh = FileHandle->new($manifest)
6853         or Carp::croak("Couldn't open $manifest: $!");
6854     local($/) = "\n";
6855     my $bundle_filename = $what;
6856     $bundle_filename =~ s|Bundle.*/||;
6857     my $bundle_unixpath;
6858     while (<$fh>) {
6859         next if /^\s*\#/;
6860         my($file) = /(\S+)/;
6861         if ($file =~ m|\Q$what\E$|) {
6862             $bundle_unixpath = $file;
6863             # return File::Spec->catfile($where,$bundle_unixpath); # bad
6864             last;
6865         }
6866         # retry if she managed to have no Bundle directory
6867         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
6868     }
6869     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
6870         if $bundle_unixpath;
6871     Carp::croak("Couldn't find a Bundle file in $where");
6872 }
6873
6874 # needs to work quite differently from Module::inst_file because of
6875 # cpan_home/Bundle/ directory and the possibility that we have
6876 # shadowing effect. As it makes no sense to take the first in @INC for
6877 # Bundles, we parse them all for $VERSION and take the newest.
6878
6879 #-> sub CPAN::Bundle::inst_file ;
6880 sub inst_file {
6881     my($self) = @_;
6882     my($inst_file);
6883     my(@me);
6884     @me = split /::/, $self->id;
6885     $me[-1] .= ".pm";
6886     my($incdir,$bestv);
6887     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
6888         my $bfile = File::Spec->catfile($incdir, @me);
6889         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
6890         next unless -f $bfile;
6891         my $foundv = MM->parse_version($bfile);
6892         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
6893             $self->{INST_FILE} = $bfile;
6894             $self->{INST_VERSION} = $bestv = $foundv;
6895         }
6896     }
6897     $self->{INST_FILE};
6898 }
6899
6900 #-> sub CPAN::Bundle::inst_version ;
6901 sub inst_version {
6902     my($self) = @_;
6903     $self->inst_file; # finds INST_VERSION as side effect
6904     $self->{INST_VERSION};
6905 }
6906
6907 #-> sub CPAN::Bundle::rematein ;
6908 sub rematein {
6909     my($self,$meth) = @_;
6910     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
6911     my($id) = $self->id;
6912     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
6913         unless $self->inst_file || $self->cpan_file;
6914     my($s,%fail);
6915     for $s ($self->contains) {
6916         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
6917             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
6918         if ($type eq 'CPAN::Distribution') {
6919             $CPAN::Frontend->mywarn(qq{
6920 The Bundle }.$self->id.qq{ contains
6921 explicitly a file $s.
6922 });
6923             $CPAN::Frontend->mysleep(3);
6924         }
6925         # possibly noisy action:
6926         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
6927         my $obj = $CPAN::META->instance($type,$s);
6928         $obj->{reqtype} = $self->{reqtype};
6929         $obj->$meth();
6930         if ($obj->isa('CPAN::Bundle')
6931             &&
6932             exists $obj->{install_failed}
6933             &&
6934             ref($obj->{install_failed}) eq "HASH"
6935            ) {
6936           for (keys %{$obj->{install_failed}}) {
6937             $self->{install_failed}{$_} = undef; # propagate faiure up
6938                                                  # to me in a
6939                                                  # recursive call
6940             $fail{$s} = 1; # the bundle itself may have succeeded but
6941                            # not all children
6942           }
6943         } else {
6944           my $success;
6945           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
6946           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
6947           if ($success) {
6948             delete $self->{install_failed}{$s};
6949           } else {
6950             $fail{$s} = 1;
6951           }
6952         }
6953     }
6954
6955     # recap with less noise
6956     if ( $meth eq "install" ) {
6957         if (%fail) {
6958             require Text::Wrap;
6959             my $raw = sprintf(qq{Bundle summary:
6960 The following items in bundle %s had installation problems:},
6961                               $self->id
6962                              );
6963             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
6964             $CPAN::Frontend->myprint("\n");
6965             my $paragraph = "";
6966             my %reported;
6967             for $s ($self->contains) {
6968               if ($fail{$s}){
6969                 $paragraph .= "$s ";
6970                 $self->{install_failed}{$s} = undef;
6971                 $reported{$s} = undef;
6972               }
6973             }
6974             my $report_propagated;
6975             for $s (sort keys %{$self->{install_failed}}) {
6976               next if exists $reported{$s};
6977               $paragraph .= "and the following items had problems
6978 during recursive bundle calls: " unless $report_propagated++;
6979               $paragraph .= "$s ";
6980             }
6981             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
6982             $CPAN::Frontend->myprint("\n");
6983         } else {
6984             $self->{'install'} = 'YES';
6985         }
6986     }
6987 }
6988
6989 # If a bundle contains another that contains an xs_file we have here,
6990 # we just don't bother I suppose
6991 #-> sub CPAN::Bundle::xs_file
6992 sub xs_file {
6993     return 0;
6994 }
6995
6996 #-> sub CPAN::Bundle::force ;
6997 sub force   { shift->rematein('force',@_); }
6998 #-> sub CPAN::Bundle::notest ;
6999 sub notest  { shift->rematein('notest',@_); }
7000 #-> sub CPAN::Bundle::get ;
7001 sub get     { shift->rematein('get',@_); }
7002 #-> sub CPAN::Bundle::make ;
7003 sub make    { shift->rematein('make',@_); }
7004 #-> sub CPAN::Bundle::test ;
7005 sub test    {
7006     my $self = shift;
7007     $self->{badtestcnt} ||= 0;
7008     $self->rematein('test',@_);
7009 }
7010 #-> sub CPAN::Bundle::install ;
7011 sub install {
7012   my $self = shift;
7013   $self->rematein('install',@_);
7014 }
7015 #-> sub CPAN::Bundle::clean ;
7016 sub clean   { shift->rematein('clean',@_); }
7017
7018 #-> sub CPAN::Bundle::uptodate ;
7019 sub uptodate {
7020     my($self) = @_;
7021     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
7022     my $c;
7023     foreach $c ($self->contains) {
7024         my $obj = CPAN::Shell->expandany($c);
7025         return 0 unless $obj->uptodate;
7026     }
7027     return 1;
7028 }
7029
7030 #-> sub CPAN::Bundle::readme ;
7031 sub readme  {
7032     my($self) = @_;
7033     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
7034 No File found for bundle } . $self->id . qq{\n}), return;
7035     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
7036     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
7037 }
7038
7039 package CPAN::Module;
7040 use strict;
7041
7042 # Accessors
7043 # sub CPAN::Module::userid
7044 sub userid {
7045     my $self = shift;
7046     my $ro = $self->ro;
7047     return unless $ro;
7048     return $ro->{userid} || $ro->{CPAN_USERID};
7049 }
7050 # sub CPAN::Module::description
7051 sub description {
7052     my $self = shift;
7053     my $ro = $self->ro or return "";
7054     $ro->{description}
7055 }
7056
7057 sub distribution {
7058     my($self) = @_;
7059     CPAN::Shell->expand("Distribution",$self->cpan_file);
7060 }
7061
7062 # sub CPAN::Module::undelay
7063 sub undelay {
7064     my $self = shift;
7065     delete $self->{later};
7066     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
7067         $dist->undelay;
7068     }
7069 }
7070
7071 # mark as dirty/clean
7072 #-> sub CPAN::Module::color_cmd_tmps ;
7073 sub color_cmd_tmps {
7074     my($self) = shift;
7075     my($depth) = shift || 0;
7076     my($color) = shift || 0;
7077     my($ancestors) = shift || [];
7078     # a module needs to recurse to its cpan_file
7079
7080     return if exists $self->{incommandcolor}
7081         && $self->{incommandcolor}==$color;
7082     return if $depth>=1 && $self->uptodate;
7083     if ($depth>=100){
7084         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
7085     }
7086     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
7087
7088     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
7089         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
7090     }
7091     if ($color==0) {
7092         delete $self->{badtestcnt};
7093     }
7094     $self->{incommandcolor} = $color;
7095 }
7096
7097 #-> sub CPAN::Module::as_glimpse ;
7098 sub as_glimpse {
7099     my($self) = @_;
7100     my(@m);
7101     my $class = ref($self);
7102     $class =~ s/^CPAN:://;
7103     my $color_on = "";
7104     my $color_off = "";
7105     if (
7106         $CPAN::Shell::COLOR_REGISTERED
7107         &&
7108         $CPAN::META->has_inst("Term::ANSIColor")
7109         &&
7110         $self->description
7111        ) {
7112         $color_on = Term::ANSIColor::color("green");
7113         $color_off = Term::ANSIColor::color("reset");
7114     }
7115     my $uptodateness = " ";
7116     if ($class eq "Bundle") {
7117     } elsif ($self->uptodate) {
7118         $uptodateness = "=";
7119     } elsif ($self->inst_version) {
7120         $uptodateness = "<";
7121     }
7122     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
7123                      $class,
7124                      $uptodateness,
7125                      $color_on,
7126                      $self->id,
7127                      $color_off,
7128                      ($self->distribution ?
7129                       $self->distribution->pretty_id :
7130                       $self->cpan_userid
7131                      ),
7132                     );
7133     join "", @m;
7134 }
7135
7136 #-> sub CPAN::Module::dslip_status
7137 sub dslip_status {
7138     my($self) = @_;
7139     my($stat);
7140     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
7141                                               pre-alpha alpha beta released
7142                                               mature standard,;
7143     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
7144                                               developer comp.lang.perl.*
7145                                               none abandoned,;
7146     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
7147     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
7148                                               references+ties
7149                                               object-oriented pragma
7150                                               hybrid none,;
7151     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
7152                                               GPL LGPL
7153                                               BSD Artistic
7154                                               open-source
7155                                               distribution_allowed
7156                                               restricted_distribution
7157                                               no_licence,;
7158     for my $x (qw(d s l i p)) {
7159         $stat->{$x}{' '} = 'unknown';
7160         $stat->{$x}{'?'} = 'unknown';
7161     }
7162     my $ro = $self->ro;
7163     return +{} unless $ro && $ro->{statd};
7164     return {
7165             D  => $ro->{statd},
7166             S  => $ro->{stats},
7167             L  => $ro->{statl},
7168             I  => $ro->{stati},
7169             P  => $ro->{statp},
7170             DV => $stat->{D}{$ro->{statd}},
7171             SV => $stat->{S}{$ro->{stats}},
7172             LV => $stat->{L}{$ro->{statl}},
7173             IV => $stat->{I}{$ro->{stati}},
7174             PV => $stat->{P}{$ro->{statp}},
7175            };
7176 }
7177
7178 #-> sub CPAN::Module::as_string ;
7179 sub as_string {
7180     my($self) = @_;
7181     my(@m);
7182     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
7183     my $class = ref($self);
7184     $class =~ s/^CPAN:://;
7185     local($^W) = 0;
7186     push @m, $class, " id = $self->{ID}\n";
7187     my $sprintf = "    %-12s %s\n";
7188     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
7189         if $self->description;
7190     my $sprintf2 = "    %-12s %s (%s)\n";
7191     my($userid);
7192     $userid = $self->userid;
7193     if ( $userid ){
7194         my $author;
7195         if ($author = CPAN::Shell->expand('Author',$userid)) {
7196           my $email = "";
7197           my $m; # old perls
7198           if ($m = $author->email) {
7199             $email = " <$m>";
7200           }
7201           push @m, sprintf(
7202                            $sprintf2,
7203                            'CPAN_USERID',
7204                            $userid,
7205                            $author->fullname . $email
7206                           );
7207         }
7208     }
7209     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
7210         if $self->cpan_version;
7211     if (my $cpan_file = $self->cpan_file){
7212         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
7213         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
7214             my $upload_date = $dist->upload_date;
7215             if ($upload_date) {
7216                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
7217             }
7218         }
7219     }
7220     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
7221     my $dslip = $self->dslip_status;
7222     push @m, sprintf(
7223                      $sprintf3,
7224                      'DSLIP_STATUS',
7225                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
7226                     ) if $dslip->{D};
7227     my $local_file = $self->inst_file;
7228     unless ($self->{MANPAGE}) {
7229         my $manpage;
7230         if ($local_file) {
7231             $manpage = $self->manpage_headline($local_file);
7232         } else {
7233             # If we have already untarred it, we should look there
7234             my $dist = $CPAN::META->instance('CPAN::Distribution',
7235                                              $self->cpan_file);
7236             # warn "dist[$dist]";
7237             # mff=manifest file; mfh=manifest handle
7238             my($mff,$mfh);
7239             if (
7240                 $dist->{build_dir}
7241                 and
7242                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
7243                 and
7244                 $mfh = FileHandle->new($mff)
7245                ) {
7246                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
7247                 my $lfre = $self->id; # local file RE
7248                 $lfre =~ s/::/./g;
7249                 $lfre .= "\\.pm\$";
7250                 my($lfl); # local file file
7251                 local $/ = "\n";
7252                 my(@mflines) = <$mfh>;
7253                 for (@mflines) {
7254                     s/^\s+//;
7255                     s/\s.*//s;
7256                 }
7257                 while (length($lfre)>5 and !$lfl) {
7258                     ($lfl) = grep /$lfre/, @mflines;
7259                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
7260                     $lfre =~ s/.+?\.//;
7261                 }
7262                 $lfl =~ s/\s.*//; # remove comments
7263                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
7264                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
7265                 # warn "lfl_abs[$lfl_abs]";
7266                 if (-f $lfl_abs) {
7267                     $manpage = $self->manpage_headline($lfl_abs);
7268                 }
7269             }
7270         }
7271         $self->{MANPAGE} = $manpage if $manpage;
7272     }
7273     my($item);
7274     for $item (qw/MANPAGE/) {
7275         push @m, sprintf($sprintf, $item, $self->{$item})
7276             if exists $self->{$item};
7277     }
7278     for $item (qw/CONTAINS/) {
7279         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
7280             if exists $self->{$item} && @{$self->{$item}};
7281     }
7282     push @m, sprintf($sprintf, 'INST_FILE',
7283                      $local_file || "(not installed)");
7284     push @m, sprintf($sprintf, 'INST_VERSION',
7285                      $self->inst_version) if $local_file;
7286     join "", @m, "\n";
7287 }
7288
7289 sub manpage_headline {
7290   my($self,$local_file) = @_;
7291   my(@local_file) = $local_file;
7292   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
7293   push @local_file, $local_file;
7294   my(@result,$locf);
7295   for $locf (@local_file) {
7296     next unless -f $locf;
7297     my $fh = FileHandle->new($locf)
7298         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
7299     my $inpod = 0;
7300     local $/ = "\n";
7301     while (<$fh>) {
7302       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
7303           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
7304       next unless $inpod;
7305       next if /^=/;
7306       next if /^\s+$/;
7307       chomp;
7308       push @result, $_;
7309     }
7310     close $fh;
7311     last if @result;
7312   }
7313   for (@result) {
7314       s/^\s+//;
7315       s/\s+$//;
7316   }
7317   join " ", @result;
7318 }
7319
7320 #-> sub CPAN::Module::cpan_file ;
7321 # Note: also inherited by CPAN::Bundle
7322 sub cpan_file {
7323     my $self = shift;
7324     CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
7325     unless ($self->ro) {
7326         CPAN::Index->reload;
7327     }
7328     my $ro = $self->ro;
7329     if ($ro && defined $ro->{CPAN_FILE}){
7330         return $ro->{CPAN_FILE};
7331     } else {
7332         my $userid = $self->userid;
7333         if ( $userid ) {
7334             if ($CPAN::META->exists("CPAN::Author",$userid)) {
7335                 my $author = $CPAN::META->instance("CPAN::Author",
7336                                                    $userid);
7337                 my $fullname = $author->fullname;
7338                 my $email = $author->email;
7339                 unless (defined $fullname && defined $email) {
7340                     return sprintf("Contact Author %s",
7341                                    $userid,
7342                                   );
7343                 }
7344                 return "Contact Author $fullname <$email>";
7345             } else {
7346                 return "Contact Author $userid (Email address not available)";
7347             }
7348         } else {
7349             return "N/A";
7350         }
7351     }
7352 }
7353
7354 #-> sub CPAN::Module::cpan_version ;
7355 sub cpan_version {
7356     my $self = shift;
7357
7358     my $ro = $self->ro;
7359     unless ($ro) {
7360         # Can happen with modules that are not on CPAN
7361         $ro = {};
7362     }
7363     $ro->{CPAN_VERSION} = 'undef'
7364         unless defined $ro->{CPAN_VERSION};
7365     $ro->{CPAN_VERSION};
7366 }
7367
7368 #-> sub CPAN::Module::force ;
7369 sub force {
7370     my($self) = @_;
7371     $self->{'force_update'}++;
7372 }
7373
7374 sub notest {
7375     my($self) = @_;
7376     # warn "XDEBUG: set notest for Module";
7377     $self->{'notest'}++;
7378 }
7379
7380 #-> sub CPAN::Module::rematein ;
7381 sub rematein {
7382     my($self,$meth) = @_;
7383     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
7384                                      $meth,
7385                                      $self->id));
7386     my $cpan_file = $self->cpan_file;
7387     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
7388       $CPAN::Frontend->mywarn(sprintf qq{
7389   The module %s isn\'t available on CPAN.
7390
7391   Either the module has not yet been uploaded to CPAN, or it is
7392   temporary unavailable. Please contact the author to find out
7393   more about the status. Try 'i %s'.
7394 },
7395                               $self->id,
7396                               $self->id,
7397                              );
7398       return;
7399     }
7400     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
7401     $pack->called_for($self->id);
7402     $pack->force($meth) if exists $self->{'force_update'};
7403     $pack->notest($meth) if exists $self->{'notest'};
7404
7405     $pack->{reqtype} ||= "";
7406     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
7407                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
7408         if ($pack->{reqtype}) {
7409             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
7410                 $pack->{reqtype} = $self->{reqtype};
7411                 if (
7412                     exists $pack->{install}
7413                     &&
7414                     (
7415                      $pack->{install}->can("failed") ?
7416                      $pack->{install}->failed :
7417                      $pack->{install} =~ /^NO/
7418                     )
7419                    ) {
7420                     delete $pack->{install};
7421                     $CPAN::Frontend->mywarn
7422                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
7423                 }
7424             }
7425         } else {
7426             $pack->{reqtype} = $self->{reqtype};
7427         }
7428
7429     eval {
7430         $pack->$meth();
7431     };
7432     my $err = $@;
7433     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
7434     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
7435     delete $self->{'force_update'};
7436     delete $self->{'notest'};
7437     if ($err) {
7438         die $err;
7439     }
7440 }
7441
7442 #-> sub CPAN::Module::perldoc ;
7443 sub perldoc { shift->rematein('perldoc') }
7444 #-> sub CPAN::Module::readme ;
7445 sub readme  { shift->rematein('readme') }
7446 #-> sub CPAN::Module::look ;
7447 sub look    { shift->rematein('look') }
7448 #-> sub CPAN::Module::cvs_import ;
7449 sub cvs_import { shift->rematein('cvs_import') }
7450 #-> sub CPAN::Module::get ;
7451 sub get     { shift->rematein('get',@_) }
7452 #-> sub CPAN::Module::make ;
7453 sub make    { shift->rematein('make') }
7454 #-> sub CPAN::Module::test ;
7455 sub test   {
7456     my $self = shift;
7457     $self->{badtestcnt} ||= 0;
7458     $self->rematein('test',@_);
7459 }
7460 #-> sub CPAN::Module::uptodate ;
7461 sub uptodate {
7462     my($self) = @_;
7463     local($_); # protect against a bug in MakeMaker 6.17
7464     my($latest) = $self->cpan_version;
7465     $latest ||= 0;
7466     my($inst_file) = $self->inst_file;
7467     my($have) = 0;
7468     if (defined $inst_file) {
7469         $have = $self->inst_version;
7470     }
7471     local($^W)=0;
7472     if ($inst_file
7473         &&
7474         ! CPAN::Version->vgt($latest, $have)
7475        ) {
7476         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
7477                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
7478         return 1;
7479     }
7480     return;
7481 }
7482 #-> sub CPAN::Module::install ;
7483 sub install {
7484     my($self) = @_;
7485     my($doit) = 0;
7486     if ($self->uptodate
7487         &&
7488         not exists $self->{'force_update'}
7489        ) {
7490         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
7491                                          $self->id,
7492                                          $self->inst_version,
7493                                         ));
7494     } else {
7495         $doit = 1;
7496     }
7497     my $ro = $self->ro;
7498     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
7499         $CPAN::Frontend->mywarn(qq{
7500 \n\n\n     ***WARNING***
7501      The module $self->{ID} has no active maintainer.\n\n\n
7502 });
7503         $CPAN::Frontend->mysleep(5);
7504     }
7505     $self->rematein('install') if $doit;
7506 }
7507 #-> sub CPAN::Module::clean ;
7508 sub clean  { shift->rematein('clean') }
7509
7510 #-> sub CPAN::Module::inst_file ;
7511 sub inst_file {
7512     my($self) = @_;
7513     my($dir,@packpath);
7514     @packpath = split /::/, $self->{ID};
7515     $packpath[-1] .= ".pm";
7516     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
7517         unshift @packpath, "Term", "ReadLine"; # historical reasons
7518     }
7519     foreach $dir (@INC) {
7520         my $pmfile = File::Spec->catfile($dir,@packpath);
7521         if (-f $pmfile){
7522             return $pmfile;
7523         }
7524     }
7525     return;
7526 }
7527
7528 #-> sub CPAN::Module::xs_file ;
7529 sub xs_file {
7530     my($self) = @_;
7531     my($dir,@packpath);
7532     @packpath = split /::/, $self->{ID};
7533     push @packpath, $packpath[-1];
7534     $packpath[-1] .= "." . $Config::Config{'dlext'};
7535     foreach $dir (@INC) {
7536         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
7537         if (-f $xsfile){
7538             return $xsfile;
7539         }
7540     }
7541     return;
7542 }
7543
7544 #-> sub CPAN::Module::inst_version ;
7545 sub inst_version {
7546     my($self) = @_;
7547     my $parsefile = $self->inst_file or return;
7548     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
7549     my $have;
7550
7551     $have = MM->parse_version($parsefile) || "undef";
7552     $have =~ s/^ //; # since the %vd hack these two lines here are needed
7553     $have =~ s/ $//; # trailing whitespace happens all the time
7554
7555     # My thoughts about why %vd processing should happen here
7556
7557     # Alt1 maintain it as string with leading v:
7558     # read index files     do nothing
7559     # compare it           use utility for compare
7560     # print it             do nothing
7561
7562     # Alt2 maintain it as what it is
7563     # read index files     convert
7564     # compare it           use utility because there's still a ">" vs "gt" issue
7565     # print it             use CPAN::Version for print
7566
7567     # Seems cleaner to hold it in memory as a string starting with a "v"
7568
7569     # If the author of this module made a mistake and wrote a quoted
7570     # "v1.13" instead of v1.13, we simply leave it at that with the
7571     # effect that *we* will treat it like a v-tring while the rest of
7572     # perl won't. Seems sensible when we consider that any action we
7573     # could take now would just add complexity.
7574
7575     $have = CPAN::Version->readable($have);
7576
7577     $have =~ s/\s*//g; # stringify to float around floating point issues
7578     $have; # no stringify needed, \s* above matches always
7579 }
7580
7581 package CPAN;
7582 use strict;
7583
7584 1;
7585
7586
7587 __END__
7588
7589 =head1 NAME
7590
7591 CPAN - query, download and build perl modules from CPAN sites
7592
7593 =head1 SYNOPSIS
7594
7595 Interactive mode:
7596
7597   perl -MCPAN -e shell;
7598
7599 Batch mode:
7600
7601   use CPAN;
7602
7603   # Modules:
7604
7605   cpan> install Acme::Meta                       # in the shell
7606
7607   CPAN::Shell->install("Acme::Meta");            # in perl
7608
7609   # Distributions:
7610
7611   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
7612
7613   CPAN::Shell->
7614     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
7615
7616   # module objects:
7617
7618   $mo = CPAN::Shell->expandany($mod);
7619   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
7620
7621   # distribution objects:
7622
7623   $do = CPAN::Shell->expand("Module",$mod)->distribution;
7624   $do = CPAN::Shell->expandany($distro);         # same thing
7625   $do = CPAN::Shell->expand("Distribution",
7626                             $distro);            # same thing
7627
7628 =head1 STATUS
7629
7630 This module and its competitor, the CPANPLUS module, are both much
7631 cooler than the other.
7632
7633 =head1 COMPATIBILITY
7634
7635 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
7636 newer versions. It is getting more and more difficult to get the
7637 minimal prerequisites working on older perls. It is close to
7638 impossible to get the whole Bundle::CPAN working there. If you're in
7639 the position to have only these old versions, be advised that CPAN is
7640 designed to work fine without the Bundle::CPAN installed.
7641
7642 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
7643 compatible with ancient perls and that File::Temp is listed as a
7644 prerequisite but CPAN has reasonable workarounds if it is missing.
7645
7646 =head1 DESCRIPTION
7647
7648 The CPAN module is designed to automate the make and install of perl
7649 modules and extensions. It includes some primitive searching
7650 capabilities and knows how to use Net::FTP or LWP (or some external
7651 download clients) to fetch the raw data from the net.
7652
7653 Modules are fetched from one or more of the mirrored CPAN
7654 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
7655 directory.
7656
7657 The CPAN module also supports the concept of named and versioned
7658 I<bundles> of modules. Bundles simplify the handling of sets of
7659 related modules. See Bundles below.
7660
7661 The package contains a session manager and a cache manager. There is
7662 no status retained between sessions. The session manager keeps track
7663 of what has been fetched, built and installed in the current
7664 session. The cache manager keeps track of the disk space occupied by
7665 the make processes and deletes excess space according to a simple FIFO
7666 mechanism.
7667
7668 All methods provided are accessible in a programmer style and in an
7669 interactive shell style.
7670
7671 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
7672
7673 The interactive mode is entered by running
7674
7675     perl -MCPAN -e shell
7676
7677 which puts you into a readline interface. You will have the most fun if
7678 you install Term::ReadKey and Term::ReadLine to enjoy both history and
7679 command completion.
7680
7681 Once you are on the command line, type 'h' and the rest should be
7682 self-explanatory.
7683
7684 The function call C<shell> takes two optional arguments, one is the
7685 prompt, the second is the default initial command line (the latter
7686 only works if a real ReadLine interface module is installed).
7687
7688 The most common uses of the interactive modes are
7689
7690 =over 2
7691
7692 =item Searching for authors, bundles, distribution files and modules
7693
7694 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
7695 for each of the four categories and another, C<i> for any of the
7696 mentioned four. Each of the four entities is implemented as a class
7697 with slightly differing methods for displaying an object.
7698
7699 Arguments you pass to these commands are either strings exactly matching
7700 the identification string of an object or regular expressions that are
7701 then matched case-insensitively against various attributes of the
7702 objects. The parser recognizes a regular expression only if you
7703 enclose it between two slashes.
7704
7705 The principle is that the number of found objects influences how an
7706 item is displayed. If the search finds one item, the result is
7707 displayed with the rather verbose method C<as_string>, but if we find
7708 more than one, we display each object with the terse method
7709 C<as_glimpse>.
7710
7711 =item make, test, install, clean  modules or distributions
7712
7713 These commands take any number of arguments and investigate what is
7714 necessary to perform the action. If the argument is a distribution
7715 file name (recognized by embedded slashes), it is processed. If it is
7716 a module, CPAN determines the distribution file in which this module
7717 is included and processes that, following any dependencies named in
7718 the module's META.yml or Makefile.PL (this behavior is controlled by
7719 the configuration parameter C<prerequisites_policy>.)
7720
7721 Any C<make> or C<test> are run unconditionally. An
7722
7723   install <distribution_file>
7724
7725 also is run unconditionally. But for
7726
7727   install <module>
7728
7729 CPAN checks if an install is actually needed for it and prints
7730 I<module up to date> in the case that the distribution file containing
7731 the module doesn't need to be updated.
7732
7733 CPAN also keeps track of what it has done within the current session
7734 and doesn't try to build a package a second time regardless if it
7735 succeeded or not. The C<force> pragma may precede another command
7736 (currently: C<make>, C<test>, or C<install>) and executes the
7737 command from scratch and tries to continue in case of some errors.
7738
7739 Example:
7740
7741     cpan> install OpenGL
7742     OpenGL is up to date.
7743     cpan> force install OpenGL
7744     Running make
7745     OpenGL-0.4/
7746     OpenGL-0.4/COPYRIGHT
7747     [...]
7748
7749 The C<notest> pragma may be set to skip the test part in the build
7750 process.
7751
7752 Example:
7753
7754     cpan> notest install Tk
7755
7756 A C<clean> command results in a
7757
7758   make clean
7759
7760 being executed within the distribution file's working directory.
7761
7762 =item get, readme, perldoc, look module or distribution
7763
7764 C<get> downloads a distribution file without further action. C<readme>
7765 displays the README file of the associated distribution. C<Look> gets
7766 and untars (if not yet done) the distribution file, changes to the
7767 appropriate directory and opens a subshell process in that directory.
7768 C<perldoc> displays the pod documentation of the module in html or
7769 plain text format.
7770
7771 =item ls author
7772
7773 =item ls globbing_expression
7774
7775 The first form lists all distribution files in and below an author's
7776 CPAN directory as they are stored in the CHECKUMS files distributed on
7777 CPAN. The listing goes recursive into all subdirectories.
7778
7779 The second form allows to limit or expand the output with shell
7780 globbing as in the following examples:
7781
7782           ls JV/make*
7783           ls GSAR/*make*
7784           ls */*make*
7785
7786 The last example is very slow and outputs extra progress indicators
7787 that break the alignment of the result.
7788
7789 Note that globbing only lists directories explicitly asked for, for
7790 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
7791 regarded as a bug and may be changed in future versions.
7792
7793 =item failed
7794
7795 The C<failed> command reports all distributions that failed on one of
7796 C<make>, C<test> or C<install> for some reason in the currently
7797 running shell session.
7798
7799 =item Lockfile
7800
7801 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>
7802 (but the directory can be configured via the C<cpan_home> config
7803 variable). The shell is a bit picky if you try to start another CPAN
7804 session. It dies immediately if there is a lockfile and the lock seems
7805 to belong to a running process. In case you want to run a second shell
7806 session, it is probably safest to maintain another directory, say
7807 C<~/.cpan-for-X/> and a C<~/.cpan-for-X/CPAN/MyConfig.pm> that
7808 contains the configuration options. Then you can start the second
7809 shell with
7810
7811   perl -I ~/.cpan-for-X -MCPAN::MyConfig -MCPAN -e shell
7812
7813 =item Signals
7814
7815 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
7816 in the cpan-shell it is intended that you can press C<^C> anytime and
7817 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
7818 to clean up and leave the shell loop. You can emulate the effect of a
7819 SIGTERM by sending two consecutive SIGINTs, which usually means by
7820 pressing C<^C> twice.
7821
7822 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
7823 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
7824 Build.PL> subprocess.
7825
7826 =back
7827
7828 =head2 CPAN::Shell
7829
7830 The commands that are available in the shell interface are methods in
7831 the package CPAN::Shell. If you enter the shell command, all your
7832 input is split by the Text::ParseWords::shellwords() routine which
7833 acts like most shells do. The first word is being interpreted as the
7834 method to be called and the rest of the words are treated as arguments
7835 to this method. Continuation lines are supported if a line ends with a
7836 literal backslash.
7837
7838 =head2 autobundle
7839
7840 C<autobundle> writes a bundle file into the
7841 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
7842 a list of all modules that are both available from CPAN and currently
7843 installed within @INC. The name of the bundle file is based on the
7844 current date and a counter.
7845
7846 =head2 recompile
7847
7848 recompile() is a very special command in that it takes no argument and
7849 runs the make/test/install cycle with brute force over all installed
7850 dynamically loadable extensions (aka XS modules) with 'force' in
7851 effect. The primary purpose of this command is to finish a network
7852 installation. Imagine, you have a common source tree for two different
7853 architectures. You decide to do a completely independent fresh
7854 installation. You start on one architecture with the help of a Bundle
7855 file produced earlier. CPAN installs the whole Bundle for you, but
7856 when you try to repeat the job on the second architecture, CPAN
7857 responds with a C<"Foo up to date"> message for all modules. So you
7858 invoke CPAN's recompile on the second architecture and you're done.
7859
7860 Another popular use for C<recompile> is to act as a rescue in case your
7861 perl breaks binary compatibility. If one of the modules that CPAN uses
7862 is in turn depending on binary compatibility (so you cannot run CPAN
7863 commands), then you should try the CPAN::Nox module for recovery.
7864
7865 =head2 upgrade [Module|/Regex/]...
7866
7867 The C<upgrade> command first runs an C<r> command with the given
7868 arguments and then installs the newest versions of all modules that
7869 were listed by that.
7870
7871 =head2 mkmyconfig
7872
7873 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
7874 directory so that you can save your own preferences instead of the
7875 system wide ones.
7876
7877 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
7878
7879 Although it may be considered internal, the class hierarchy does matter
7880 for both users and programmer. CPAN.pm deals with above mentioned four
7881 classes, and all those classes share a set of methods. A classical
7882 single polymorphism is in effect. A metaclass object registers all
7883 objects of all kinds and indexes them with a string. The strings
7884 referencing objects have a separated namespace (well, not completely
7885 separated):
7886
7887          Namespace                         Class
7888
7889    words containing a "/" (slash)      Distribution
7890     words starting with Bundle::          Bundle
7891           everything else            Module or Author
7892
7893 Modules know their associated Distribution objects. They always refer
7894 to the most recent official release. Developers may mark their releases
7895 as unstable development versions (by inserting an underbar into the
7896 module version number which will also be reflected in the distribution
7897 name when you run 'make dist'), so the really hottest and newest
7898 distribution is not always the default.  If a module Foo circulates
7899 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
7900 way to install version 1.23 by saying
7901
7902     install Foo
7903
7904 This would install the complete distribution file (say
7905 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
7906 like to install version 1.23_90, you need to know where the
7907 distribution file resides on CPAN relative to the authors/id/
7908 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
7909 so you would have to say
7910
7911     install BAR/Foo-1.23_90.tar.gz
7912
7913 The first example will be driven by an object of the class
7914 CPAN::Module, the second by an object of class CPAN::Distribution.
7915
7916 =head1 PROGRAMMER'S INTERFACE
7917
7918 If you do not enter the shell, the available shell commands are both
7919 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
7920 functions in the calling package (C<install(...)>).
7921
7922 There's currently only one class that has a stable interface -
7923 CPAN::Shell. All commands that are available in the CPAN shell are
7924 methods of the class CPAN::Shell. Each of the commands that produce
7925 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
7926 the IDs of all modules within the list.
7927
7928 =over 2
7929
7930 =item expand($type,@things)
7931
7932 The IDs of all objects available within a program are strings that can
7933 be expanded to the corresponding real objects with the
7934 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
7935 list of CPAN::Module objects according to the C<@things> arguments
7936 given. In scalar context it only returns the first element of the
7937 list.
7938
7939 =item expandany(@things)
7940
7941 Like expand, but returns objects of the appropriate type, i.e.
7942 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
7943 CPAN::Distribution objects for distributions. Note: it does not expand
7944 to CPAN::Author objects.
7945
7946 =item Programming Examples
7947
7948 This enables the programmer to do operations that combine
7949 functionalities that are available in the shell.
7950
7951     # install everything that is outdated on my disk:
7952     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
7953
7954     # install my favorite programs if necessary:
7955     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
7956         CPAN::Shell->install($mod);
7957     }
7958
7959     # list all modules on my disk that have no VERSION number
7960     for $mod (CPAN::Shell->expand("Module","/./")){
7961         next unless $mod->inst_file;
7962         # MakeMaker convention for undefined $VERSION:
7963         next unless $mod->inst_version eq "undef";
7964         print "No VERSION in ", $mod->id, "\n";
7965     }
7966
7967     # find out which distribution on CPAN contains a module:
7968     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
7969
7970 Or if you want to write a cronjob to watch The CPAN, you could list
7971 all modules that need updating. First a quick and dirty way:
7972
7973     perl -e 'use CPAN; CPAN::Shell->r;'
7974
7975 If you don't want to get any output in the case that all modules are
7976 up to date, you can parse the output of above command for the regular
7977 expression //modules are up to date// and decide to mail the output
7978 only if it doesn't match. Ick?
7979
7980 If you prefer to do it more in a programmer style in one single
7981 process, maybe something like this suits you better:
7982
7983   # list all modules on my disk that have newer versions on CPAN
7984   for $mod (CPAN::Shell->expand("Module","/./")){
7985     next unless $mod->inst_file;
7986     next if $mod->uptodate;
7987     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
7988         $mod->id, $mod->inst_version, $mod->cpan_version;
7989   }
7990
7991 If that gives you too much output every day, you maybe only want to
7992 watch for three modules. You can write
7993
7994   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
7995
7996 as the first line instead. Or you can combine some of the above
7997 tricks:
7998
7999   # watch only for a new mod_perl module
8000   $mod = CPAN::Shell->expand("Module","mod_perl");
8001   exit if $mod->uptodate;
8002   # new mod_perl arrived, let me know all update recommendations
8003   CPAN::Shell->r;
8004
8005 =back
8006
8007 =head2 Methods in the other Classes
8008
8009 The programming interface for the classes CPAN::Module,
8010 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
8011 beta and partially even alpha. In the following paragraphs only those
8012 methods are documented that have proven useful over a longer time and
8013 thus are unlikely to change.
8014
8015 =over 4
8016
8017 =item CPAN::Author::as_glimpse()
8018
8019 Returns a one-line description of the author
8020
8021 =item CPAN::Author::as_string()
8022
8023 Returns a multi-line description of the author
8024
8025 =item CPAN::Author::email()
8026
8027 Returns the author's email address
8028
8029 =item CPAN::Author::fullname()
8030
8031 Returns the author's name
8032
8033 =item CPAN::Author::name()
8034
8035 An alias for fullname
8036
8037 =item CPAN::Bundle::as_glimpse()
8038
8039 Returns a one-line description of the bundle
8040
8041 =item CPAN::Bundle::as_string()
8042
8043 Returns a multi-line description of the bundle
8044
8045 =item CPAN::Bundle::clean()
8046
8047 Recursively runs the C<clean> method on all items contained in the bundle.
8048
8049 =item CPAN::Bundle::contains()
8050
8051 Returns a list of objects' IDs contained in a bundle. The associated
8052 objects may be bundles, modules or distributions.
8053
8054 =item CPAN::Bundle::force($method,@args)
8055
8056 Forces CPAN to perform a task that normally would have failed. Force
8057 takes as arguments a method name to be called and any number of
8058 additional arguments that should be passed to the called method. The
8059 internals of the object get the needed changes so that CPAN.pm does
8060 not refuse to take the action. The C<force> is passed recursively to
8061 all contained objects.
8062
8063 =item CPAN::Bundle::get()
8064
8065 Recursively runs the C<get> method on all items contained in the bundle
8066
8067 =item CPAN::Bundle::inst_file()
8068
8069 Returns the highest installed version of the bundle in either @INC or
8070 C<$CPAN::Config->{cpan_home}>. Note that this is different from
8071 CPAN::Module::inst_file.
8072
8073 =item CPAN::Bundle::inst_version()
8074
8075 Like CPAN::Bundle::inst_file, but returns the $VERSION
8076
8077 =item CPAN::Bundle::uptodate()
8078
8079 Returns 1 if the bundle itself and all its members are uptodate.
8080
8081 =item CPAN::Bundle::install()
8082
8083 Recursively runs the C<install> method on all items contained in the bundle
8084
8085 =item CPAN::Bundle::make()
8086
8087 Recursively runs the C<make> method on all items contained in the bundle
8088
8089 =item CPAN::Bundle::readme()
8090
8091 Recursively runs the C<readme> method on all items contained in the bundle
8092
8093 =item CPAN::Bundle::test()
8094
8095 Recursively runs the C<test> method on all items contained in the bundle
8096
8097 =item CPAN::Distribution::as_glimpse()
8098
8099 Returns a one-line description of the distribution
8100
8101 =item CPAN::Distribution::as_string()
8102
8103 Returns a multi-line description of the distribution
8104
8105 =item CPAN::Distribution::author
8106
8107 Returns the CPAN::Author object of the maintainer who uploaded this
8108 distribution
8109
8110 =item CPAN::Distribution::clean()
8111
8112 Changes to the directory where the distribution has been unpacked and
8113 runs C<make clean> there.
8114
8115 =item CPAN::Distribution::containsmods()
8116
8117 Returns a list of IDs of modules contained in a distribution file.
8118 Only works for distributions listed in the 02packages.details.txt.gz
8119 file. This typically means that only the most recent version of a
8120 distribution is covered.
8121
8122 =item CPAN::Distribution::cvs_import()
8123
8124 Changes to the directory where the distribution has been unpacked and
8125 runs something like
8126
8127     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
8128
8129 there.
8130
8131 =item CPAN::Distribution::dir()
8132
8133 Returns the directory into which this distribution has been unpacked.
8134
8135 =item CPAN::Distribution::force($method,@args)
8136
8137 Forces CPAN to perform a task that normally would have failed. Force
8138 takes as arguments a method name to be called and any number of
8139 additional arguments that should be passed to the called method. The
8140 internals of the object get the needed changes so that CPAN.pm does
8141 not refuse to take the action.
8142
8143 =item CPAN::Distribution::get()
8144
8145 Downloads the distribution from CPAN and unpacks it. Does nothing if
8146 the distribution has already been downloaded and unpacked within the
8147 current session.
8148
8149 =item CPAN::Distribution::install()
8150
8151 Changes to the directory where the distribution has been unpacked and
8152 runs the external command C<make install> there. If C<make> has not
8153 yet been run, it will be run first. A C<make test> will be issued in
8154 any case and if this fails, the install will be canceled. The
8155 cancellation can be avoided by letting C<force> run the C<install> for
8156 you.
8157
8158 This install method has only the power to install the distribution if
8159 there are no dependencies in the way. To install an object and all of
8160 its dependencies, use CPAN::Shell->install.
8161
8162 Note that install() gives no meaningful return value. See uptodate().
8163
8164 =item CPAN::Distribution::isa_perl()
8165
8166 Returns 1 if this distribution file seems to be a perl distribution.
8167 Normally this is derived from the file name only, but the index from
8168 CPAN can contain a hint to achieve a return value of true for other
8169 filenames too.
8170
8171 =item CPAN::Distribution::look()
8172
8173 Changes to the directory where the distribution has been unpacked and
8174 opens a subshell there. Exiting the subshell returns.
8175
8176 =item CPAN::Distribution::make()
8177
8178 First runs the C<get> method to make sure the distribution is
8179 downloaded and unpacked. Changes to the directory where the
8180 distribution has been unpacked and runs the external commands C<perl
8181 Makefile.PL> or C<perl Build.PL> and C<make> there.
8182
8183 =item CPAN::Distribution::perldoc()
8184
8185 Downloads the pod documentation of the file associated with a
8186 distribution (in html format) and runs it through the external
8187 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
8188 isn't available, it converts it to plain text with external
8189 command html2text and runs it through the pager specified
8190 in C<$CPAN::Config->{pager}>
8191
8192 =item CPAN::Distribution::prefs()
8193
8194 Returns the hash reference from the first matching YAML file that the
8195 user has deposited in the C<prefs_dir/> directory. The first
8196 succeeding match wins. The files in the C<prefs_dir/> are processed
8197 alphabetically and the canonical distroname (e.g.
8198 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
8199 stored in the $root->{match}{distribution} attribute value.
8200 Additionally all module names contained in a distribution are matched
8201 agains the regular expressions in the $root->{match}{module} attribute
8202 value. The two match values are ANDed together. Each of the two
8203 attributes are optional.
8204
8205 =item CPAN::Distribution::prereq_pm()
8206
8207 Returns the hash reference that has been announced by a distribution
8208 as the merge of the C<requires> element and the C<build_requires>
8209 element of the META.yml or the C<PREREQ_PM> hash in the
8210 C<Makefile.PL>. Note: works only after an attempt has been made to
8211 C<make> the distribution. Returns undef otherwise.
8212
8213 =item CPAN::Distribution::readme()
8214
8215 Downloads the README file associated with a distribution and runs it
8216 through the pager specified in C<$CPAN::Config->{pager}>.
8217
8218 =item CPAN::Distribution::read_yaml()
8219
8220 Returns the content of the META.yml of this distro as a hashref. Note:
8221 works only after an attempt has been made to C<make> the distribution.
8222 Returns undef otherwise.
8223
8224 =item CPAN::Distribution::test()
8225
8226 Changes to the directory where the distribution has been unpacked and
8227 runs C<make test> there.
8228
8229 =item CPAN::Distribution::uptodate()
8230
8231 Returns 1 if all the modules contained in the distribution are
8232 uptodate. Relies on containsmods.
8233
8234 =item CPAN::Index::force_reload()
8235
8236 Forces a reload of all indices.
8237
8238 =item CPAN::Index::reload()
8239
8240 Reloads all indices if they have not been read for more than
8241 C<$CPAN::Config->{index_expire}> days.
8242
8243 =item CPAN::InfoObj::dump()
8244
8245 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
8246 inherit this method. It prints the data structure associated with an
8247 object. Useful for debugging. Note: the data structure is considered
8248 internal and thus subject to change without notice.
8249
8250 =item CPAN::Module::as_glimpse()
8251
8252 Returns a one-line description of the module in four columns: The
8253 first column contains the word C<Module>, the second column consists
8254 of one character: an equals sign if this module is already installed
8255 and uptodate, a less-than sign if this module is installed but can be
8256 upgraded, and a space if the module is not installed. The third column
8257 is the name of the module and the fourth column gives maintainer or
8258 distribution information.
8259
8260 =item CPAN::Module::as_string()
8261
8262 Returns a multi-line description of the module
8263
8264 =item CPAN::Module::clean()
8265
8266 Runs a clean on the distribution associated with this module.
8267
8268 =item CPAN::Module::cpan_file()
8269
8270 Returns the filename on CPAN that is associated with the module.
8271
8272 =item CPAN::Module::cpan_version()
8273
8274 Returns the latest version of this module available on CPAN.
8275
8276 =item CPAN::Module::cvs_import()
8277
8278 Runs a cvs_import on the distribution associated with this module.
8279
8280 =item CPAN::Module::description()
8281
8282 Returns a 44 character description of this module. Only available for
8283 modules listed in The Module List (CPAN/modules/00modlist.long.html
8284 or 00modlist.long.txt.gz)
8285
8286 =item CPAN::Module::distribution()
8287
8288 Returns the CPAN::Distribution object that contains the current
8289 version of this module.
8290
8291 =item CPAN::Module::dslip_status()
8292
8293 Returns a hash reference. The keys of the hash are the letters C<D>,
8294 C<S>, C<L>, C<I>, and <P>, for development status, support level,
8295 language, interface and public licence respectively. The data for the
8296 DSLIP status are collected by pause.perl.org when authors register
8297 their namespaces. The values of the 5 hash elements are one-character
8298 words whose meaning is described in the table below. There are also 5
8299 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
8300 verbose value of the 5 status variables.
8301
8302 Where the 'DSLIP' characters have the following meanings:
8303
8304   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
8305     i   - Idea, listed to gain consensus or as a placeholder
8306     c   - under construction but pre-alpha (not yet released)
8307     a/b - Alpha/Beta testing
8308     R   - Released
8309     M   - Mature (no rigorous definition)
8310     S   - Standard, supplied with Perl 5
8311
8312   S - Support Level:
8313     m   - Mailing-list
8314     d   - Developer
8315     u   - Usenet newsgroup comp.lang.perl.modules
8316     n   - None known, try comp.lang.perl.modules
8317     a   - abandoned; volunteers welcome to take over maintainance
8318
8319   L - Language Used:
8320     p   - Perl-only, no compiler needed, should be platform independent
8321     c   - C and perl, a C compiler will be needed
8322     h   - Hybrid, written in perl with optional C code, no compiler needed
8323     +   - C++ and perl, a C++ compiler will be needed
8324     o   - perl and another language other than C or C++
8325
8326   I - Interface Style
8327     f   - plain Functions, no references used
8328     h   - hybrid, object and function interfaces available
8329     n   - no interface at all (huh?)
8330     r   - some use of unblessed References or ties
8331     O   - Object oriented using blessed references and/or inheritance
8332
8333   P - Public License
8334     p   - Standard-Perl: user may choose between GPL and Artistic
8335     g   - GPL: GNU General Public License
8336     l   - LGPL: "GNU Lesser General Public License" (previously known as
8337           "GNU Library General Public License")
8338     b   - BSD: The BSD License
8339     a   - Artistic license alone
8340     o   - open source: appoved by www.opensource.org
8341     d   - allows distribution without restrictions
8342     r   - restricted distribtion
8343     n   - no license at all
8344
8345 =item CPAN::Module::force($method,@args)
8346
8347 Forces CPAN to perform a task that normally would have failed. Force
8348 takes as arguments a method name to be called and any number of
8349 additional arguments that should be passed to the called method. The
8350 internals of the object get the needed changes so that CPAN.pm does
8351 not refuse to take the action.
8352
8353 =item CPAN::Module::get()
8354
8355 Runs a get on the distribution associated with this module.
8356
8357 =item CPAN::Module::inst_file()
8358
8359 Returns the filename of the module found in @INC. The first file found
8360 is reported just like perl itself stops searching @INC when it finds a
8361 module.
8362
8363 =item CPAN::Module::inst_version()
8364
8365 Returns the version number of the module in readable format.
8366
8367 =item CPAN::Module::install()
8368
8369 Runs an C<install> on the distribution associated with this module.
8370
8371 =item CPAN::Module::look()
8372
8373 Changes to the directory where the distribution associated with this
8374 module has been unpacked and opens a subshell there. Exiting the
8375 subshell returns.
8376
8377 =item CPAN::Module::make()
8378
8379 Runs a C<make> on the distribution associated with this module.
8380
8381 =item CPAN::Module::manpage_headline()
8382
8383 If module is installed, peeks into the module's manpage, reads the
8384 headline and returns it. Moreover, if the module has been downloaded
8385 within this session, does the equivalent on the downloaded module even
8386 if it is not installed.
8387
8388 =item CPAN::Module::perldoc()
8389
8390 Runs a C<perldoc> on this module.
8391
8392 =item CPAN::Module::readme()
8393
8394 Runs a C<readme> on the distribution associated with this module.
8395
8396 =item CPAN::Module::test()
8397
8398 Runs a C<test> on the distribution associated with this module.
8399
8400 =item CPAN::Module::uptodate()
8401
8402 Returns 1 if the module is installed and up-to-date.
8403
8404 =item CPAN::Module::userid()
8405
8406 Returns the author's ID of the module.
8407
8408 =back
8409
8410 =head2 Cache Manager
8411
8412 Currently the cache manager only keeps track of the build directory
8413 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
8414 deletes complete directories below C<build_dir> as soon as the size of
8415 all directories there gets bigger than $CPAN::Config->{build_cache}
8416 (in MB). The contents of this cache may be used for later
8417 re-installations that you intend to do manually, but will never be
8418 trusted by CPAN itself. This is due to the fact that the user might
8419 use these directories for building modules on different architectures.
8420
8421 There is another directory ($CPAN::Config->{keep_source_where}) where
8422 the original distribution files are kept. This directory is not
8423 covered by the cache manager and must be controlled by the user. If
8424 you choose to have the same directory as build_dir and as
8425 keep_source_where directory, then your sources will be deleted with
8426 the same fifo mechanism.
8427
8428 =head2 Bundles
8429
8430 A bundle is just a perl module in the namespace Bundle:: that does not
8431 define any functions or methods. It usually only contains documentation.
8432
8433 It starts like a perl module with a package declaration and a $VERSION
8434 variable. After that the pod section looks like any other pod with the
8435 only difference being that I<one special pod section> exists starting with
8436 (verbatim):
8437
8438         =head1 CONTENTS
8439
8440 In this pod section each line obeys the format
8441
8442         Module_Name [Version_String] [- optional text]
8443
8444 The only required part is the first field, the name of a module
8445 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
8446 of the line is optional. The comment part is delimited by a dash just
8447 as in the man page header.
8448
8449 The distribution of a bundle should follow the same convention as
8450 other distributions.
8451
8452 Bundles are treated specially in the CPAN package. If you say 'install
8453 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
8454 the modules in the CONTENTS section of the pod. You can install your
8455 own Bundles locally by placing a conformant Bundle file somewhere into
8456 your @INC path. The autobundle() command which is available in the
8457 shell interface does that for you by including all currently installed
8458 modules in a snapshot bundle file.
8459
8460 =head1 PREREQUISITES
8461
8462 If you have a local mirror of CPAN and can access all files with
8463 "file:" URLs, then you only need a perl better than perl5.003 to run
8464 this module. Otherwise Net::FTP is strongly recommended. LWP may be
8465 required for non-UNIX systems or if your nearest CPAN site is
8466 associated with a URL that is not C<ftp:>.
8467
8468 If you have neither Net::FTP nor LWP, there is a fallback mechanism
8469 implemented for an external ftp command or for an external lynx
8470 command.
8471
8472 =head1 UTILITIES
8473
8474 =head2 Finding packages and VERSION
8475
8476 This module presumes that all packages on CPAN
8477
8478 =over 2
8479
8480 =item *
8481
8482 declare their $VERSION variable in an easy to parse manner. This
8483 prerequisite can hardly be relaxed because it consumes far too much
8484 memory to load all packages into the running program just to determine
8485 the $VERSION variable. Currently all programs that are dealing with
8486 version use something like this
8487
8488     perl -MExtUtils::MakeMaker -le \
8489         'print MM->parse_version(shift)' filename
8490
8491 If you are author of a package and wonder if your $VERSION can be
8492 parsed, please try the above method.
8493
8494 =item *
8495
8496 come as compressed or gzipped tarfiles or as zip files and contain a
8497 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
8498 without much enthusiasm).
8499
8500 =back
8501
8502 =head2 Debugging
8503
8504 The debugging of this module is a bit complex, because we have
8505 interferences of the software producing the indices on CPAN, of the
8506 mirroring process on CPAN, of packaging, of configuration, of
8507 synchronicity, and of bugs within CPAN.pm.
8508
8509 For debugging the code of CPAN.pm itself in interactive mode some more
8510 or less useful debugging aid can be turned on for most packages within
8511 CPAN.pm with one of
8512
8513 =over 2
8514
8515 =item o debug package...
8516
8517 sets debug mode for packages.
8518
8519 =item o debug -package...
8520
8521 unsets debug mode for packages.
8522
8523 =item o debug all
8524
8525 turns debugging on for all packages.
8526
8527 =item o debug number
8528
8529 =back
8530
8531 which sets the debugging packages directly. Note that C<o debug 0>
8532 turns debugging off.
8533
8534 What seems quite a successful strategy is the combination of C<reload
8535 cpan> and the debugging switches. Add a new debug statement while
8536 running in the shell and then issue a C<reload cpan> and see the new
8537 debugging messages immediately without losing the current context.
8538
8539 C<o debug> without an argument lists the valid package names and the
8540 current set of packages in debugging mode. C<o debug> has built-in
8541 completion support.
8542
8543 For debugging of CPAN data there is the C<dump> command which takes
8544 the same arguments as make/test/install and outputs each object's
8545 Data::Dumper dump. If an argument looks like a perl variable and
8546 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
8547 Data::Dumper directly.
8548
8549 =head2 Floppy, Zip, Offline Mode
8550
8551 CPAN.pm works nicely without network too. If you maintain machines
8552 that are not networked at all, you should consider working with file:
8553 URLs. Of course, you have to collect your modules somewhere first. So
8554 you might use CPAN.pm to put together all you need on a networked
8555 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
8556 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
8557 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
8558 with this floppy. See also below the paragraph about CD-ROM support.
8559
8560 =head2 Basic Utilities for Programmers
8561
8562 =over 2
8563
8564 =item has_inst($module)
8565
8566 Returns true if the module is installed. See the source for details.
8567
8568 =item has_usable($module)
8569
8570 Returns true if the module is installed and several and is in a usable
8571 state. Only useful for a handful of modules that are used internally.
8572 See the source for details.
8573
8574 =item instance($module)
8575
8576 The constructor for all the singletons used to represent modules,
8577 distributions, authors and bundles. If the object already exists, this
8578 method returns the object, otherwise it calls the constructor.
8579
8580 =back
8581
8582 =head1 CONFIGURATION
8583
8584 When the CPAN module is used for the first time, a configuration
8585 dialog tries to determine a couple of site specific options. The
8586 result of the dialog is stored in a hash reference C< $CPAN::Config >
8587 in a file CPAN/Config.pm.
8588
8589 The default values defined in the CPAN/Config.pm file can be
8590 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
8591 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
8592 added to the search path of the CPAN module before the use() or
8593 require() statements.
8594
8595 The configuration dialog can be started any time later again by
8596 issuing the command C< o conf init > in the CPAN shell. A subset of
8597 the configuration dialog can be run by issuing C<o conf init WORD>
8598 where WORD is any valid config variable or a regular expression.
8599
8600 Currently the following keys in the hash reference $CPAN::Config are
8601 defined:
8602
8603   build_cache        size of cache for directories to build modules
8604   build_dir          locally accessible directory to build modules
8605   build_requires_install_policy
8606                      to install or not to install: when a module is
8607                      only needed for building. yes|no|ask/yes|ask/no
8608   bzip2              path to external prg
8609   cache_metadata     use serializer to cache metadata
8610   commands_quote     prefered character to use for quoting external
8611                      commands when running them. Defaults to double
8612                      quote on Windows, single tick everywhere else;
8613                      can be set to space to disable quoting
8614   check_sigs         if signatures should be verified
8615   colorize_output    boolean if Term::ANSIColor should colorize output
8616   colorize_print     Term::ANSIColor attributes for normal output
8617   colorize_warn      Term::ANSIColor attributes for warnings
8618   commandnumber_in_prompt
8619                      boolean if you want to see current command number
8620   cpan_home          local directory reserved for this package
8621   curl               path to external prg
8622   dontload_hash      DEPRECATED
8623   dontload_list      arrayref: modules in the list will not be
8624                      loaded by the CPAN::has_inst() routine
8625   ftp                path to external prg
8626   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
8627   ftp_proxy          proxy host for ftp requests
8628   getcwd             see below
8629   gpg                path to external prg
8630   gzip               location of external program gzip
8631   histfile           file to maintain history between sessions
8632   histsize           maximum number of lines to keep in histfile
8633   http_proxy         proxy host for http requests
8634   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
8635                      after this many seconds inactivity. Set to 0 to
8636                      never break.
8637   index_expire       after this many days refetch index files
8638   inhibit_startup_message
8639                      if true, does not print the startup message
8640   keep_source_where  directory in which to keep the source (if we do)
8641   lynx               path to external prg
8642   make               location of external make program
8643   make_arg           arguments that should always be passed to 'make'
8644   make_install_make_command
8645                      the make command for running 'make install', for
8646                      example 'sudo make'
8647   make_install_arg   same as make_arg for 'make install'
8648   makepl_arg         arguments passed to 'perl Makefile.PL'
8649   mbuild_arg         arguments passed to './Build'
8650   mbuild_install_arg arguments passed to './Build install'
8651   mbuild_install_build_command
8652                      command to use instead of './Build' when we are
8653                      in the install stage, for example 'sudo ./Build'
8654   mbuildpl_arg       arguments passed to 'perl Build.PL'
8655   ncftp              path to external prg
8656   ncftpget           path to external prg
8657   no_proxy           don't proxy to these hosts/domains (comma separated list)
8658   pager              location of external program more (or any pager)
8659   password           your password if you CPAN server wants one
8660   prefer_installer   legal values are MB and EUMM: if a module comes
8661                      with both a Makefile.PL and a Build.PL, use the
8662                      former (EUMM) or the latter (MB); if the module
8663                      comes with only one of the two, that one will be
8664                      used in any case
8665   prerequisites_policy
8666                      what to do if you are missing module prerequisites
8667                      ('follow' automatically, 'ask' me, or 'ignore')
8668   prefs_dir          local directory to store per-distro build options
8669   proxy_user         username for accessing an authenticating proxy
8670   proxy_pass         password for accessing an authenticating proxy
8671   scan_cache         controls scanning of cache ('atstart' or 'never')
8672   shell              your favorite shell
8673   show_upload_date   boolean if commands should try to determine upload date
8674   tar                location of external program tar
8675   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
8676                      (and nonsense for characters outside latin range)
8677   term_ornaments     boolean to turn ReadLine ornamenting on/off
8678   test_report        email test reports (if CPAN::Reporter is installed)
8679   unzip              location of external program unzip
8680   urllist            arrayref to nearby CPAN sites (or equivalent locations)
8681   username           your username if you CPAN server wants one
8682   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
8683   wget               path to external prg
8684   yaml_module        which module to use to read/write YAML files
8685
8686 You can set and query each of these options interactively in the cpan
8687 shell with the command set defined within the C<o conf> command:
8688
8689 =over 2
8690
8691 =item C<o conf E<lt>scalar optionE<gt>>
8692
8693 prints the current value of the I<scalar option>
8694
8695 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
8696
8697 Sets the value of the I<scalar option> to I<value>
8698
8699 =item C<o conf E<lt>list optionE<gt>>
8700
8701 prints the current value of the I<list option> in MakeMaker's
8702 neatvalue format.
8703
8704 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
8705
8706 shifts or pops the array in the I<list option> variable
8707
8708 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
8709
8710 works like the corresponding perl commands.
8711
8712 =back
8713
8714 =head2 CPAN::anycwd($path): Note on config variable getcwd
8715
8716 CPAN.pm changes the current working directory often and needs to
8717 determine its own current working directory. Per default it uses
8718 Cwd::cwd but if this doesn't work on your system for some reason,
8719 alternatives can be configured according to the following table:
8720
8721 =over 2
8722
8723 =item cwd
8724
8725 Calls Cwd::cwd
8726
8727 =item getcwd
8728
8729 Calls Cwd::getcwd
8730
8731 =item fastcwd
8732
8733 Calls Cwd::fastcwd
8734
8735 =item backtickcwd
8736
8737 Calls the external command cwd.
8738
8739 =back
8740
8741 =head2 Note on urllist parameter's format
8742
8743 urllist parameters are URLs according to RFC 1738. We do a little
8744 guessing if your URL is not compliant, but if you have problems with
8745 file URLs, please try the correct format. Either:
8746
8747     file://localhost/whatever/ftp/pub/CPAN/
8748
8749 or
8750
8751     file:///home/ftp/pub/CPAN/
8752
8753 =head2 urllist parameter has CD-ROM support
8754
8755 The C<urllist> parameter of the configuration table contains a list of
8756 URLs that are to be used for downloading. If the list contains any
8757 C<file> URLs, CPAN always tries to get files from there first. This
8758 feature is disabled for index files. So the recommendation for the
8759 owner of a CD-ROM with CPAN contents is: include your local, possibly
8760 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
8761
8762   o conf urllist push file://localhost/CDROM/CPAN
8763
8764 CPAN.pm will then fetch the index files from one of the CPAN sites
8765 that come at the beginning of urllist. It will later check for each
8766 module if there is a local copy of the most recent version.
8767
8768 Another peculiarity of urllist is that the site that we could
8769 successfully fetch the last file from automatically gets a preference
8770 token and is tried as the first site for the next request. So if you
8771 add a new site at runtime it may happen that the previously preferred
8772 site will be tried another time. This means that if you want to disallow
8773 a site for the next transfer, it must be explicitly removed from
8774 urllist.
8775
8776 =head2 prefs_dir for avoiding interactive questions (ALPHA)
8777
8778 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
8779 still considered experimental and may still be changed)
8780
8781 The files in the directory specified in C<prefs_dir> are YAML files
8782 that specify how CPAN.pm shall treat distributions that deviate from
8783 the normal non-interactive model of building and installing CPAN
8784 modules.
8785
8786 Some modules try to get some data from the user interactively thus
8787 disturbing the installation of large bundles like Phalanx100 or
8788 modules like Plagger.
8789
8790 CPAN.pm can use YAML files to either pass additional arguments to one
8791 of the four commands, set environment variables or instantiate an
8792 Expect object that reads from the console, waits for some regular
8793 expression and enters some answer. Needless to say that for the latter
8794 option Expect.pm needs to be installed.
8795
8796 CPAN.pm comes with a couple of such YAML files. The structure is
8797 currently not documented. Please see the distroprefs directory of the
8798 CPAN distribution for examples and follow the README in there.
8799
8800 Please note that setting the environment variable PERL_MM_USE_DEFAULT
8801 to a true value can also get you a long way if you want to always pick
8802 the default answers. But this only works if the author of apackage
8803 used the prompt function provided by ExtUtils::MakeMaker and if the
8804 defaults are OK for you.
8805
8806 =head1 SECURITY
8807
8808 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
8809 install foreign, unmasked, unsigned code on your machine. We compare
8810 to a checksum that comes from the net just as the distribution file
8811 itself. But we try to make it easy to add security on demand:
8812
8813 =head2 Cryptographically signed modules
8814
8815 Since release 1.77 CPAN.pm has been able to verify cryptographically
8816 signed module distributions using Module::Signature.  The CPAN modules
8817 can be signed by their authors, thus giving more security.  The simple
8818 unsigned MD5 checksums that were used before by CPAN protect mainly
8819 against accidental file corruption.
8820
8821 You will need to have Module::Signature installed, which in turn
8822 requires that you have at least one of Crypt::OpenPGP module or the
8823 command-line F<gpg> tool installed.
8824
8825 You will also need to be able to connect over the Internet to the public
8826 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
8827
8828 The configuration parameter check_sigs is there to turn signature
8829 checking on or off.
8830
8831 =head1 EXPORT
8832
8833 Most functions in package CPAN are exported per default. The reason
8834 for this is that the primary use is intended for the cpan shell or for
8835 one-liners.
8836
8837 =head1 ENVIRONMENT
8838
8839 When the CPAN shell enters a subshell via the look command, it sets
8840 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
8841 already set.
8842
8843 When the config variable ftp_passive is set, all downloads will be run
8844 with the environment variable FTP_PASSIVE set to this value. This is
8845 in general a good idea as it influences both Net::FTP and LWP based
8846 connections. The same effect can be achieved by starting the cpan
8847 shell with this environment variable set. For Net::FTP alone, one can
8848 also always set passive mode by running libnetcfg.
8849
8850 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
8851
8852 Populating a freshly installed perl with my favorite modules is pretty
8853 easy if you maintain a private bundle definition file. To get a useful
8854 blueprint of a bundle definition file, the command autobundle can be used
8855 on the CPAN shell command line. This command writes a bundle definition
8856 file for all modules that are installed for the currently running perl
8857 interpreter. It's recommended to run this command only once and from then
8858 on maintain the file manually under a private name, say
8859 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
8860
8861     cpan> install Bundle::my_bundle
8862
8863 then answer a few questions and then go out for a coffee.
8864
8865 Maintaining a bundle definition file means keeping track of two
8866 things: dependencies and interactivity. CPAN.pm sometimes fails on
8867 calculating dependencies because not all modules define all MakeMaker
8868 attributes correctly, so a bundle definition file should specify
8869 prerequisites as early as possible. On the other hand, it's a bit
8870 annoying that many distributions need some interactive configuring. So
8871 what I try to accomplish in my private bundle file is to have the
8872 packages that need to be configured early in the file and the gentle
8873 ones later, so I can go out after a few minutes and leave CPAN.pm
8874 untended.
8875
8876 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
8877
8878 Thanks to Graham Barr for contributing the following paragraphs about
8879 the interaction between perl, and various firewall configurations. For
8880 further information on firewalls, it is recommended to consult the
8881 documentation that comes with the ncftp program. If you are unable to
8882 go through the firewall with a simple Perl setup, it is very likely
8883 that you can configure ncftp so that it works for your firewall.
8884
8885 =head2 Three basic types of firewalls
8886
8887 Firewalls can be categorized into three basic types.
8888
8889 =over 4
8890
8891 =item http firewall
8892
8893 This is where the firewall machine runs a web server and to access the
8894 outside world you must do it via the web server. If you set environment
8895 variables like http_proxy or ftp_proxy to a values beginning with http://
8896 or in your web browser you have to set proxy information then you know
8897 you are running an http firewall.
8898
8899 To access servers outside these types of firewalls with perl (even for
8900 ftp) you will need to use LWP.
8901
8902 =item ftp firewall
8903
8904 This where the firewall machine runs an ftp server. This kind of
8905 firewall will only let you access ftp servers outside the firewall.
8906 This is usually done by connecting to the firewall with ftp, then
8907 entering a username like "user@outside.host.com"
8908
8909 To access servers outside these type of firewalls with perl you
8910 will need to use Net::FTP.
8911
8912 =item One way visibility
8913
8914 I say one way visibility as these firewalls try to make themselves look
8915 invisible to the users inside the firewall. An FTP data connection is
8916 normally created by sending the remote server your IP address and then
8917 listening for the connection. But the remote server will not be able to
8918 connect to you because of the firewall. So for these types of firewall
8919 FTP connections need to be done in a passive mode.
8920
8921 There are two that I can think off.
8922
8923 =over 4
8924
8925 =item SOCKS
8926
8927 If you are using a SOCKS firewall you will need to compile perl and link
8928 it with the SOCKS library, this is what is normally called a 'socksified'
8929 perl. With this executable you will be able to connect to servers outside
8930 the firewall as if it is not there.
8931
8932 =item IP Masquerade
8933
8934 This is the firewall implemented in the Linux kernel, it allows you to
8935 hide a complete network behind one IP address. With this firewall no
8936 special compiling is needed as you can access hosts directly.
8937
8938 For accessing ftp servers behind such firewalls you usually need to
8939 set the environment variable C<FTP_PASSIVE> or the config variable
8940 ftp_passive to a true value.
8941
8942 =back
8943
8944 =back
8945
8946 =head2 Configuring lynx or ncftp for going through a firewall
8947
8948 If you can go through your firewall with e.g. lynx, presumably with a
8949 command such as
8950
8951     /usr/local/bin/lynx -pscott:tiger
8952
8953 then you would configure CPAN.pm with the command
8954
8955     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
8956
8957 That's all. Similarly for ncftp or ftp, you would configure something
8958 like
8959
8960     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
8961
8962 Your mileage may vary...
8963
8964 =head1 FAQ
8965
8966 =over 4
8967
8968 =item 1)
8969
8970 I installed a new version of module X but CPAN keeps saying,
8971 I have the old version installed
8972
8973 Most probably you B<do> have the old version installed. This can
8974 happen if a module installs itself into a different directory in the
8975 @INC path than it was previously installed. This is not really a
8976 CPAN.pm problem, you would have the same problem when installing the
8977 module manually. The easiest way to prevent this behaviour is to add
8978 the argument C<UNINST=1> to the C<make install> call, and that is why
8979 many people add this argument permanently by configuring
8980
8981   o conf make_install_arg UNINST=1
8982
8983 =item 2)
8984
8985 So why is UNINST=1 not the default?
8986
8987 Because there are people who have their precise expectations about who
8988 may install where in the @INC path and who uses which @INC array. In
8989 fine tuned environments C<UNINST=1> can cause damage.
8990
8991 =item 3)
8992
8993 I want to clean up my mess, and install a new perl along with
8994 all modules I have. How do I go about it?
8995
8996 Run the autobundle command for your old perl and optionally rename the
8997 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
8998 with the Configure option prefix, e.g.
8999
9000     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
9001
9002 Install the bundle file you produced in the first step with something like
9003
9004     cpan> install Bundle::mybundle
9005
9006 and you're done.
9007
9008 =item 4)
9009
9010 When I install bundles or multiple modules with one command
9011 there is too much output to keep track of.
9012
9013 You may want to configure something like
9014
9015   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
9016   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
9017
9018 so that STDOUT is captured in a file for later inspection.
9019
9020
9021 =item 5)
9022
9023 I am not root, how can I install a module in a personal directory?
9024
9025 First of all, you will want to use your own configuration, not the one
9026 that your root user installed. If you do not have permission to write
9027 in the cpan directory that root has configured, you will be asked if
9028 you want to create your own config. Answering "yes" will bring you into
9029 CPAN's configuration stage, using the system config for all defaults except
9030 things that have to do with CPAN's work directory, saving your choices to
9031 your MyConfig.pm file.
9032
9033 You can also manually initiate this process with the following command:
9034
9035     % perl -MCPAN -e 'mkmyconfig'
9036
9037 or by running
9038
9039     mkmyconfig
9040
9041 from the CPAN shell.
9042
9043 You will most probably also want to configure something like this:
9044
9045   o conf makepl_arg "LIB=~/myperl/lib \
9046                     INSTALLMAN1DIR=~/myperl/man/man1 \
9047                     INSTALLMAN3DIR=~/myperl/man/man3"
9048
9049 You can make this setting permanent like all C<o conf> settings with
9050 C<o conf commit>.
9051
9052 You will have to add ~/myperl/man to the MANPATH environment variable
9053 and also tell your perl programs to look into ~/myperl/lib, e.g. by
9054 including
9055
9056   use lib "$ENV{HOME}/myperl/lib";
9057
9058 or setting the PERL5LIB environment variable.
9059
9060 While we're speaking about $ENV{HOME}, it might be worth mentioning,
9061 that for Windows we use the File::HomeDir module that provides an
9062 equivalent to the concept of the home directory on Unix.
9063
9064 Another thing you should bear in mind is that the UNINST parameter can
9065 be dnagerous when you are installing into a private area because you
9066 might accidentally remove modules that other people depend on that are
9067 not using the private area.
9068
9069 =item 6)
9070
9071 How to get a package, unwrap it, and make a change before building it?
9072
9073 Have a look at the C<look> (!) command.
9074
9075 =item 7)
9076
9077 I installed a Bundle and had a couple of fails. When I
9078 retried, everything resolved nicely. Can this be fixed to work
9079 on first try?
9080
9081 The reason for this is that CPAN does not know the dependencies of all
9082 modules when it starts out. To decide about the additional items to
9083 install, it just uses data found in the META.yml file or the generated
9084 Makefile. An undetected missing piece breaks the process. But it may
9085 well be that your Bundle installs some prerequisite later than some
9086 depending item and thus your second try is able to resolve everything.
9087 Please note, CPAN.pm does not know the dependency tree in advance and
9088 cannot sort the queue of things to install in a topologically correct
9089 order. It resolves perfectly well IF all modules declare the
9090 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
9091 the C<requires> stanza of Module::Build. For bundles which fail and
9092 you need to install often, it is recommended to sort the Bundle
9093 definition file manually.
9094
9095 =item 8)
9096
9097 In our intranet we have many modules for internal use. How
9098 can I integrate these modules with CPAN.pm but without uploading
9099 the modules to CPAN?
9100
9101 Have a look at the CPAN::Site module.
9102
9103 =item 9)
9104
9105 When I run CPAN's shell, I get an error message about things in my
9106 /etc/inputrc (or ~/.inputrc) file.
9107
9108 These are readline issues and can only be fixed by studying readline
9109 configuration on your architecture and adjusting the referenced file
9110 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
9111 and edit them. Quite often harmless changes like uppercasing or
9112 lowercasing some arguments solves the problem.
9113
9114 =item 10)
9115
9116 Some authors have strange characters in their names.
9117
9118 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
9119 expecting ISO-8859-1 charset, a converter can be activated by setting
9120 term_is_latin to a true value in your config file. One way of doing so
9121 would be
9122
9123     cpan> o conf term_is_latin 1
9124
9125 If other charset support is needed, please file a bugreport against
9126 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
9127 the support or maybe UTF-8 terminals become widely available.
9128
9129 =item 11)
9130
9131 When an install fails for some reason and then I correct the error
9132 condition and retry, CPAN.pm refuses to install the module, saying
9133 C<Already tried without success>.
9134
9135 Use the force pragma like so
9136
9137   force install Foo::Bar
9138
9139 This does a bit more than really needed because it untars the
9140 distribution again and runs make and test and only then install.
9141
9142 Or, if you find this is too fast and you would prefer to do smaller
9143 steps, say
9144
9145   force get Foo::Bar
9146
9147 first and then continue as always. C<Force get> I<forgets> previous
9148 error conditions.
9149
9150 Or you can use
9151
9152   look Foo::Bar
9153
9154 and then 'make install' directly in the subshell.
9155
9156 Or you leave the CPAN shell and start it again.
9157
9158 For the really curious, by accessing internals directly, you I<could>
9159
9160   !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
9161
9162 but this is neither guaranteed to work in the future nor is it a
9163 decent command.
9164
9165 =item 12)
9166
9167 How do I install a "DEVELOPER RELEASE" of a module?
9168
9169 By default, CPAN will install the latest non-developer release of a
9170 module. If you want to install a dev release, you have to specify the
9171 partial path starting with the author id to the tarball you wish to
9172 install, like so:
9173
9174     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
9175
9176 Note that you can use the C<ls> command to get this path listed.
9177
9178 =item 13)
9179
9180 How do I install a module and all its dependencies from the commandline,
9181 without being prompted for anything, despite my CPAN configuration
9182 (or lack thereof)?
9183
9184 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
9185 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
9186 asked any questions at all (assuming the modules you are installing are
9187 nice about obeying that variable as well):
9188
9189     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
9190
9191 =item 14)
9192
9193 How do I create a Module::Build based Build.PL derived from an
9194 ExtUtils::MakeMaker focused Makefile.PL?
9195
9196 http://search.cpan.org/search?query=Module::Build::Convert
9197
9198 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
9199
9200
9201 =back
9202
9203 =head1 BUGS
9204
9205 Please report bugs via http://rt.cpan.org/
9206
9207 Before submitting a bug, please make sure that the traditional method
9208 of building a Perl module package from a shell by following the
9209 installation instructions of that package still works in your
9210 environment.
9211
9212 =head1 SECURITY ADVICE
9213
9214 This software enables you to upgrade software on your computer and so
9215 is inherently dangerous because the newly installed software may
9216 contain bugs and may alter the way your computer works or even make it
9217 unusable. Please consider backing up your data before every upgrade.
9218
9219 =head1 AUTHOR
9220
9221 Andreas Koenig C<< <andk@cpan.org> >>
9222
9223 =head1 LICENSE
9224
9225 This program is free software; you can redistribute it and/or
9226 modify it under the same terms as Perl itself.
9227
9228 See L<http://www.perl.com/perl/misc/Artistic.html>
9229
9230 =head1 TRANSLATIONS
9231
9232 Kawai,Takanori provides a Japanese translation of this manpage at
9233 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
9234
9235 =head1 SEE ALSO
9236
9237 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
9238
9239 =cut