lib/CPAN.pm

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