lib/CPAN.pm

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