lib/CPAN.pm

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