lib/CPAN.pm

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