lib/CPAN.pm

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