lib/CPAN.pm

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