lib/CPAN.pm

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