cpan.pm

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

    my $time = time;
    my($debug,$t2);
    $debug = "";
    my $self = {
		ID => $CPAN::Config->{'build_dir'},
		MAX => $CPAN::Config->{'build_cache'},
		SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
		DU => 0
	       };
    File::Path::mkpath($self->{ID});
    my $dh = DirHandle->new($self->{ID});
    bless $self, $class;
    $self->scan_cache;
    $t2 = time;
    $debug .= "timing of CacheMgr->new: ".($t2 - $time);
    $time = $t2;
    CPAN->debug($debug) if $CPAN::DEBUG;
    $self;
}

#-> sub CPAN::CacheMgr::scan_cache ;
sub scan_cache {
    my $self = shift;
    return if $self->{SCAN} eq 'never';
    $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
	unless $self->{SCAN} eq 'atstart';
    $CPAN::Frontend->myprint(
			     sprintf("Scanning cache %s for sizes\n",
				     $self->{ID}));
    my $e;
    for $e ($self->entries($self->{ID})) {
	next if $e eq ".." || $e eq ".";
	$self->disk_usage($e);
	return if $CPAN::Signal;
    }
    $self->tidyup;
}

package CPAN::Debug;

#-> sub CPAN::Debug::debug ;
sub debug {
    my($self,$arg) = @_;
    my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
                                               # Complete, caller(1)
                                               # eg readline
    ($caller) = caller(0);
    $caller =~ s/.*:://;
    $arg = "" unless defined $arg;
    my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
    if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
	if ($arg and ref $arg) {
	    eval { require Data::Dumper };
	    if ($@) {
		$CPAN::Frontend->myprint($arg->as_string);
	    } else {
		$CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
	    }
	} else {
	    $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
	}
    }
}

package CPAN::Config;

#-> sub CPAN::Config::edit ;
# returns true on successful action
sub edit {
    my($self,@args) = @_;
    return unless @args;
    CPAN->debug("self[$self]args[".join(" | ",@args)."]");
    my($o,$str,$func,$args,$key_exists);
    $o = shift @args;
    if($can{$o}) {
	$self->$o(@args);
	return 1;
    } else {
        CPAN->debug("o[$o]") if $CPAN::DEBUG;
	if ($o =~ /list$/) {
	    $func = shift @args;
	    $func ||= "";
            CPAN->debug("func[$func]") if $CPAN::DEBUG;
            my $changed;
	    # Let's avoid eval, it's easier to comprehend without.
	    if ($func eq "push") {
		push @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
	    } elsif ($func eq "pop") {
		pop @{$CPAN::Config->{$o}};
                $changed = 1;
	    } elsif ($func eq "shift") {
		shift @{$CPAN::Config->{$o}};
                $changed = 1;
	    } elsif ($func eq "unshift") {
		unshift @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
	    } elsif ($func eq "splice") {
		splice @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
	    } elsif (@args) {
		$CPAN::Config->{$o} = [@args];
                $changed = 1;
	    } else {
                $self->prettyprint($o);
	    }
            if ($o eq "urllist" && $changed) {
                # reset the cached values
                undef $CPAN::FTP::Thesite;
                undef $CPAN::FTP::Themethod;
            }
            return $changed;
	} else {
	    $CPAN::Config->{$o} = $args[0] if defined $args[0];
	    $self->prettyprint($o);
	}
    }
}

sub prettyprint {
  my($self,$k) = @_;
  my $v = $CPAN::Config->{$k};
  if (ref $v) {
    my(@report) = ref $v eq "ARRAY" ?
        @$v :
            map { sprintf("   %-18s => %s\n",
                          $_,
                          defined $v->{$_} ? $v->{$_} : "UNDEFINED"
                         )} keys %$v;
    $CPAN::Frontend->myprint(
                             join(
                                  "",
                                  sprintf(
                                          "    %-18s\n",
                                          $k
                                         ),
                                  map {"\t$_\n"} @report
                                 )
                            );
  } elsif (defined $v) {
    $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
  } else {
    $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, "UNDEFINED");
  }
}

#-> sub CPAN::Config::commit ;
sub commit {
    my($self,$configpm) = @_;
    unless (defined $configpm){
	$configpm ||= $INC{"CPAN/MyConfig.pm"};
	$configpm ||= $INC{"CPAN/Config.pm"};
	$configpm || Carp::confess(q{
CPAN::Config::commit called without an argument.
Please specify a filename where to save the configuration or try
"o conf init" to have an interactive course through configing.
});
    }
    my($mode);
    if (-f $configpm) {
	$mode = (stat $configpm)[2];
	if ($mode && ! -w _) {
	    Carp::confess("$configpm is not writable");
	}
    }

    my $msg;
    $msg = <<EOF unless $configpm =~ /MyConfig/;

# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
# configuration file. The user-config file is being looked for as
# ~/.cpan/CPAN/MyConfig.pm.

EOF
    $msg ||= "\n";
    my($fh) = FileHandle->new;
    rename $configpm, "$configpm~" if -f $configpm;
    open $fh, ">$configpm" or
        $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
    $fh->print(qq[$msg\$CPAN::Config = \{\n]);
    foreach (sort keys %$CPAN::Config) {
	$fh->print(
		   "  '$_' => ",
		   ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
		   ",\n"
		  );
    }

    $fh->print("};\n1;\n__END__\n");
    close $fh;

    #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
    #chmod $mode, $configpm;
###why was that so?    $self->defaults;
    $CPAN::Frontend->myprint("commit: wrote $configpm\n");
    1;
}

*default = \&defaults;
#-> sub CPAN::Config::defaults ;
sub defaults {
    my($self) = @_;
    $self->unload;
    $self->load;
    1;
}

sub init {
    my($self) = @_;
    undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
                                                      # have the least
                                                      # important
                                                      # variable
                                                      # undefined
    $self->load;
    1;
}

#-> sub CPAN::Config::load ;
sub load {
    my($self) = shift;
    my(@miss);
    use Carp;
    eval {require CPAN::Config;};       # We eval because of some
                                        # MakeMaker problems
    unless ($dot_cpan++){
      unshift @INC, MM->catdir($ENV{HOME},".cpan");
      eval {require CPAN::MyConfig;};   # where you can override
                                        # system wide settings
      shift @INC;
    }
    return unless @miss = $self->missing_config_data;

    require CPAN::FirstTime;
    my($configpm,$fh,$redo,$theycalled);
    $redo ||= "";
    $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
    if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
	$configpm = $INC{"CPAN/Config.pm"};
	$redo++;
    } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
	$configpm = $INC{"CPAN/MyConfig.pm"};
	$redo++;
    } else {
	my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
	my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
	my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
	if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
	    if (-w $configpmtest) {
		$configpm = $configpmtest;
	    } elsif (-w $configpmdir) {
		#_#_# following code dumped core on me with 5.003_11, a.k.
		unlink "$configpmtest.bak" if -f "$configpmtest.bak";
		rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
		my $fh = FileHandle->new;
		if ($fh->open(">$configpmtest")) {
		    $fh->print("1;\n");
		    $configpm = $configpmtest;
		} else {
		    # Should never happen
		    Carp::confess("Cannot open >$configpmtest");
		}
	    }
	}
	unless ($configpm) {
	    $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
	    File::Path::mkpath($configpmdir);
	    $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
	    if (-w $configpmtest) {
		$configpm = $configpmtest;
	    } elsif (-w $configpmdir) {
		#_#_# following code dumped core on me with 5.003_11, a.k.
		my $fh = FileHandle->new;
		if ($fh->open(">$configpmtest")) {
		    $fh->print("1;\n");
		    $configpm = $configpmtest;
		} else {
		    # Should never happen
		    Carp::confess("Cannot open >$configpmtest");
		}
	    } else {
		Carp::confess(qq{WARNING: CPAN.pm is unable to }.
			      qq{create a configuration file.});
	    }
	}
    }
    local($") = ", ";
    $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
We have to reconfigure CPAN.pm due to following uninitialized parameters:

@miss
END
    $CPAN::Frontend->myprint(qq{
$configpm initialized.
});
    sleep 2;
    CPAN::FirstTime::init($configpm);
}

#-> sub CPAN::Config::missing_config_data ;
sub missing_config_data {
    my(@miss);
    for (
         "cpan_home", "keep_source_where", "build_dir", "build_cache",
         "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
         "pager",
         "makepl_arg", "make_arg", "make_install_arg", "urllist",
         "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
         "prerequisites_policy",
         "cache_metadata",
        ) {
	push @miss, $_ unless defined $CPAN::Config->{$_};
    }
    return @miss;
}

#-> sub CPAN::Config::unload ;
sub unload {
    delete $INC{'CPAN/MyConfig.pm'};
    delete $INC{'CPAN/Config.pm'};
}

#-> sub CPAN::Config::help ;
sub help {
    $CPAN::Frontend->myprint(q[
Known options:
  defaults  reload default config values from disk
  commit    commit session changes to disk
  init      go through a dialog to set all parameters

You may edit key values in the follow fashion (the "o" is a literal
letter o):

  o conf build_cache 15

  o conf build_dir "/foo/bar"

  o conf urllist shift

  o conf urllist unshift ftp://ftp.foo.bar/

]);
    undef; #don't reprint CPAN::Config
}

#-> sub CPAN::Config::cpl ;
sub cpl {
    my($word,$line,$pos) = @_;
    $word ||= "";
    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    my(@words) = split " ", substr($line,0,$pos+1);
    if (
	defined($words[2])
	and
	(
	 $words[2] =~ /list$/ && @words == 3
	 ||
	 $words[2] =~ /list$/ && @words == 4 && length($word)
	)
       ) {
	return grep /^\Q$word\E/, qw(splice shift unshift pop push);
    } elsif (@words >= 4) {
	return ();
    }
    my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
    return grep /^\Q$word\E/, @o_conf;
}

package CPAN::Shell;

#-> sub CPAN::Shell::h ;
sub h {
    my($class,$about) = @_;
    if (defined $about) {
	$CPAN::Frontend->myprint("Detailed help not yet implemented\n");
    } else {
	$CPAN::Frontend->myprint(q{
Display Information
 command  argument          description
 a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
 i        WORD or /REGEXP/  about anything of above
 r        NONE              reinstall recommendations
 ls       AUTHOR            about files in the author's directory

Download, Test, Make, Install...
 get                        download
 make                       make (implies get)
 test      MODULES,         make test (implies make)
 install   DISTS, BUNDLES   make install (implies test)
 clean                      make clean
 look                       open subshell in these dists' directories
 readme                     display these dists' README files

Other
 h,?           display this menu       ! perl-code   eval a perl command
 o conf [opt]  set and query options   q             quit the cpan shell
 reload cpan   load CPAN.pm again      reload index  load newer indices
 autobundle    Snapshot                force cmd     unconditionally do cmd});
    }
}

*help = \&h;

#-> sub CPAN::Shell::a ;
sub a {
  my($self,@arg) = @_;
  # authors are always UPPERCASE
  for (@arg) {
    $_ = uc $_ unless /=/;
  }
  $CPAN::Frontend->myprint($self->format_result('Author',@arg));
}

#-> sub CPAN::Shell::ls ;
sub ls      {
    my($self,@arg) = @_;
    my @accept;
    for (@arg) {
        unless (/^[A-Z\-]+$/i) {
            $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
            next;
        }
        push @accept, uc $_;
    }
    for my $a (@accept){
        my $author = $self->expand('Author',$a) or die "No author found for $a";
        $author->ls;
    }
}

#-> sub CPAN::Shell::local_bundles ;
sub local_bundles {
    my($self,@which) = @_;
    my($incdir,$bdir,$dh);
    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
        my @bbase = "Bundle";
        while (my $bbase = shift @bbase) {