cpan.pm

MSYS在windows下模拟了一个类unix的终端

# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
$VERSION = '1.59_54';
# $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $

# only used during development:
$Revision = "";
# $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";

use Carp ();
use Config ();
use Cwd ();
use DirHandle;
use Exporter ();
use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
use File::Basename ();
use File::Copy ();
use File::Find;
use File::Path ();
use FileHandle ();
use Safe ();
use Text::ParseWords ();
use Text::Wrap;
use File::Spec;
no lib "."; # we need to run chdir all over and we would get at wrong
            # libraries there

END { $End++; &cleanup; }

%CPAN::DEBUG = qw[
		  CPAN              1
		  Index             2
		  InfoObj           4
		  Author            8
		  Distribution     16
		  Bundle           32
		  Module           64
		  CacheMgr        128
		  Complete        256
		  FTP             512
		  Shell          1024
		  Eval           2048
		  Config         4096
		  Tarzip         8192
		  Version       16384
		  Queue         32768
];

$CPAN::DEBUG ||= 0;
$CPAN::Signal ||= 0;
$CPAN::Frontend ||= "CPAN::Shell";
$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";

package CPAN;
use strict qw(vars);

use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
            $Revision $Signal $End $Suppress_readline $Frontend
            $Defaultsite $Have_warned);

@CPAN::ISA = qw(CPAN::Debug Exporter);

@EXPORT = qw(
	     autobundle bundle expand force get cvs_import
	     install make readme recompile shell test clean
	    );

#-> sub CPAN::AUTOLOAD ;
sub AUTOLOAD {
    my($l) = $AUTOLOAD;
    $l =~ s/.*:://;
    my(%EXPORT);
    @EXPORT{@EXPORT} = '';
    CPAN::Config->load unless $CPAN::Config_loaded++;
    if (exists $EXPORT{$l}){
	CPAN::Shell->$l(@_);
    } else {
	$CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
				qq{Type ? for help.
});
    }
}

#-> sub CPAN::shell ;
sub shell {
    my($self) = @_;
    $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
    CPAN::Config->load unless $CPAN::Config_loaded++;

    my $oprompt = shift || "cpan> ";
    my $prompt = $oprompt;
    my $commandline = shift || "";

    local($^W) = 1;
    unless ($Suppress_readline) {
	require Term::ReadLine;
        if (! $term
            or
            $term->ReadLine eq "Term::ReadLine::Stub"
           ) {
            $term = Term::ReadLine->new('CPAN Monitor');
        }
	if ($term->ReadLine eq "Term::ReadLine::Gnu") {
	    my $attribs = $term->Attribs;
	     $attribs->{attempted_completion_function} = sub {
		 &CPAN::Complete::gnu_cpl;
	     }
	} else {
	    $readline::rl_completion_function =
		$readline::rl_completion_function = 'CPAN::Complete::cpl';
	}
	# $term->OUT is autoflushed anyway
	my $odef = select STDERR;
	$| = 1;
	select STDOUT;
	$| = 1;
	select $odef;
    }

    # no strict; # I do not recall why no strict was here (2000-09-03)
    $META->checklock();
    my $cwd = CPAN::anycwd();
    my $try_detect_readline;
    $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
    my $rl_avail = $Suppress_readline ? "suppressed" :
	($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
	    "available (try 'install Bundle::CPAN')";

    $CPAN::Frontend->myprint(
			     sprintf qq{
cpan shell -- CPAN exploration and modules installation (v%s%s)
ReadLine support %s

},
                             $CPAN::VERSION,
                             $CPAN::Revision,
                             $rl_avail
                            )
        unless $CPAN::Config->{'inhibit_startup_message'} ;
    my($continuation) = "";
  SHELLCOMMAND: while () {
	if ($Suppress_readline) {
	    print $prompt;
	    last SHELLCOMMAND unless defined ($_ = <> );
	    chomp;
	} else {
	    last SHELLCOMMAND unless
                defined ($_ = $term->readline($prompt, $commandline));
	}
	$_ = "$continuation$_" if $continuation;
	s/^\s+//;
	next SHELLCOMMAND if /^$/;
	$_ = 'h' if /^\s*\?/;
	if (/^(?:q(?:uit)?|bye|exit)$/i) {
	    last SHELLCOMMAND;
	} elsif (s/\\$//s) {
	    chomp;
	    $continuation = $_;
	    $prompt = "    > ";
	} elsif (/^\!/) {
	    s/^\!//;
	    my($eval) = $_;
	    package CPAN::Eval;
	    use vars qw($import_done);
	    CPAN->import(':DEFAULT') unless $import_done++;
	    CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
	    eval($eval);
	    warn $@ if $@;
	    $continuation = "";
	    $prompt = $oprompt;
	} elsif (/./) {
	    my(@line);
	    if ($] < 5.00322) { # parsewords had a bug until recently
		@line = split;
	    } else {
		eval { @line = Text::ParseWords::shellwords($_) };
		warn($@), next SHELLCOMMAND if $@;
                warn("Text::Parsewords could not parse the line [$_]"),
                    next SHELLCOMMAND unless @line;
	    }
	    $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
	    my $command = shift @line;
	    eval { CPAN::Shell->$command(@line) };
	    warn $@ if $@;
	    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
	    $CPAN::Frontend->myprint("\n");
	    $continuation = "";
	    $prompt = $oprompt;
	}
    } continue {
      $commandline = ""; # I do want to be able to pass a default to
                         # shell, but on the second command I see no
                         # use in that
      $Signal=0;
      CPAN::Queue->nullify_queue;
      if ($try_detect_readline) {
	if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
	    ||
	    $CPAN::META->has_inst("Term::ReadLine::Perl")
	   ) {
	    delete $INC{"Term/ReadLine.pm"};
	    my $redef = 0;
	    local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
	    require Term::ReadLine;
	    $CPAN::Frontend->myprint("\n$redef subroutines in ".
				     "Term::ReadLine redefined\n");
            @_ = ($oprompt,"");
	    goto &shell;
	}
      }
    }
    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
}

package CPAN::CacheMgr;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use File::Find;

package CPAN::Config;
use vars qw(%can $dot_cpan);

%can = (
  'commit' => "Commit changes to disk",
  'defaults' => "Reload defaults from disk",
  'init'   => "Interactive setting of all options",
);

package CPAN::FTP;
use vars qw($Ua $Thesite $Themethod);
@CPAN::FTP::ISA = qw(CPAN::Debug);

package CPAN::LWP::UserAgent;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
# we delay requiring LWP::UserAgent and setting up inheritence until we need it

package CPAN::Complete;
@CPAN::Complete::ISA = qw(CPAN::Debug);
@CPAN::Complete::COMMANDS = sort qw(
		       ! a b d h i m o q r u autobundle clean dump
		       make test install force readme reload look
                       cvs_import ls
) unless @CPAN::Complete::COMMANDS;

package CPAN::Index;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
sub PROTOCOL { 2.0 }

package CPAN::InfoObj;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);

package CPAN::Author;
@CPAN::Author::ISA = qw(CPAN::InfoObj);

package CPAN::Distribution;
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);

package CPAN::Bundle;
@CPAN::Bundle::ISA = qw(CPAN::Module);

package CPAN::Module;
@CPAN::Module::ISA = qw(CPAN::InfoObj);

package CPAN::Shell;
use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
@CPAN::Shell::ISA = qw(CPAN::Debug);
$COLOR_REGISTERED ||= 0;
$PRINT_ORNAMENTING ||= 0;

#-> sub CPAN::Shell::AUTOLOAD ;
sub AUTOLOAD {
    my($autoload) = $AUTOLOAD;
    my $class = shift(@_);
    # warn "autoload[$autoload] class[$class]";
    $autoload =~ s/.*:://;
    if ($autoload =~ /^w/) {
	if ($CPAN::META->has_inst('CPAN::WAIT')) {
	    CPAN::WAIT->$autoload(@_);
	} else {
	    $CPAN::Frontend->mywarn(qq{
Commands starting with "w" require CPAN::WAIT to be installed.
Please consider installing CPAN::WAIT to use the fulltext index.
For this you just need to type
    install CPAN::WAIT
});
	}
    } else {
	$CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
				qq{Type ? for help.
});
    }
}

package CPAN::Tarzip;
use vars qw($AUTOLOAD @ISA $BUGHUNTING);
@CPAN::Tarzip::ISA = qw(CPAN::Debug);
$BUGHUNTING = 0; # released code must have turned off

package CPAN::Queue;

# One use of the queue is to determine if we should or shouldn't
# announce the availability of a new CPAN module

# Now we try to use it for dependency tracking. For that to happen
# we need to draw a dependency tree and do the leaves first. This can
# easily be reached by running CPAN.pm recursively, but we don't want
# to waste memory and run into deep recursion. So what we can do is
# this:

# CPAN::Queue is the package where the queue is maintained. Dependencies
# often have high priority and must be brought to the head of the queue,
# possibly by jumping the queue if they are already there. My first code
# attempt tried to be extremely correct. Whenever a module needed
# immediate treatment, I either unshifted it to the front of the queue,
# or, if it was already in the queue, I spliced and let it bypass the
# others. This became a too correct model that made it impossible to put
# an item more than once into the queue. Why would you need that? Well,
# you need temporary duplicates as the manager of the queue is a loop
# that
#
#  (1) looks at the first item in the queue without shifting it off
#
#  (2) cares for the item
#
#  (3) removes the item from the queue, *even if its agenda failed and
#      even if the item isn't the first in the queue anymore* (that way
#      protecting against never ending queues)
#
# So if an item has prerequisites, the installation fails now, but we
# want to retry later. That's easy if we have it twice in the queue.
#
# I also expect insane dependency situations where an item gets more
# than two lives in the queue. Simplest example is triggered by 'install
# Foo Foo Foo'. People make this kind of mistakes and I don't want to
# get in the way. I wanted the queue manager to be a dumb servant, not
# one that knows everything.
#
# Who would I tell in this model that the user wants to be asked before
# processing? I can't attach that information to the module object,
# because not modules are installed but distributions. So I'd have to
# tell the distribution object that it should ask the user before
# processing. Where would the question be triggered then? Most probably
# in CPAN::Distribution::rematein.
# Hope that makes sense, my head is a bit off:-) -- AK

use vars qw{ @All };

# CPAN::Queue::new ;
sub new {
  my($class,$s) = @_;
  my $self = bless { qmod => $s }, $class;
  push @All, $self;
  return $self;
}

# CPAN::Queue::first ;
sub first {
  my $obj = $All[0];
  $obj->{qmod};
}

# CPAN::Queue::delete_first ;
sub delete_first {
  my($class,$what) = @_;
  my $i;
  for my $i (0..$#All) {
    if (  $All[$i]->{qmod} eq $what ) {
      splice @All, $i, 1;
      return;
    }
  }
}

# CPAN::Queue::jumpqueue ;
sub jumpqueue {
    my $class = shift;
    my @what = @_;
    CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
                        join(",",map {$_->{qmod}} @All),
                        join(",",@what)
                       )) if $CPAN::DEBUG;
  WHAT: for my $what (reverse @what) {
        my $jumped = 0;
        for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
            CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
            if ($All[$i]->{qmod} eq $what){
                $jumped++;
                if ($jumped > 100) { # one's OK if e.g. just
                                     # processing now; more are OK if
                                     # user typed it several times
                    $CPAN::Frontend->mywarn(
qq{Object [$what] queued more than 100 times, ignoring}
				 );
                    next WHAT;
                }
            }
        }
        my $obj = bless { qmod => $what }, $class;
        unshift @All, $obj;
    }
    CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
                        join(",",map {$_->{qmod}} @All),
                        join(",",@what)
                       )) if $CPAN::DEBUG;
}

# CPAN::Queue::exists ;
sub exists {
  my($self,$what) = @_;
  my @all = map { $_->{qmod} } @All;
  my $exists = grep { $_->{qmod} eq $what } @All;
  # warn "in exists what[$what] all[@all] exists[$exists]";
  $exists;
}

# CPAN::Queue::delete ;
sub delete {
  my($self,$mod) = @_;
  @All = grep { $_->{qmod} ne $mod } @All;
}

# CPAN::Queue::nullify_queue ;
sub nullify_queue {
  @All = ();
}



package CPAN;

$META ||= CPAN->new; # In case we re-eval ourselves we need the ||

# from here on only subs.
################################################################################