cpan.pm

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

#-> sub CPAN::all_objects ;
sub all_objects {
    my($mgr,$class) = @_;
    CPAN::Config->load unless $CPAN::Config_loaded++;
    CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
    CPAN::Index->reload;
    values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
}
*all = \&all_objects;

# Called by shell, not in batch mode. In batch mode I see no risk in
# having many processes updating something as installations are
# continually checked at runtime. In shell mode I suspect it is
# unintentional to open more than one shell at a time

#-> sub CPAN::checklock ;
sub checklock {
    my($self) = @_;
    my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
    if (-f $lockfile && -M _ > 0) {
	my $fh = FileHandle->new($lockfile) or
            $CPAN::Frontend->mydie("Could not open $lockfile: $!");
	my $other = <$fh>;
	$fh->close;
	if (defined $other && $other) {
	    chomp $other;
	    return if $$==$other; # should never happen
	    $CPAN::Frontend->mywarn(
				    qq{
There seems to be running another CPAN process ($other). Contacting...
});
	    if (kill 0, $other) {
		$CPAN::Frontend->mydie(qq{Other job is running.
You may want to kill it and delete the lockfile, maybe. On UNIX try:
    kill $other
    rm $lockfile
});
	    } elsif (-w $lockfile) {
		my($ans) =
		    ExtUtils::MakeMaker::prompt
			(qq{Other job not responding. Shall I overwrite }.
			 qq{the lockfile? (Y/N)},"y");
		$CPAN::Frontend->myexit("Ok, bye\n")
		    unless $ans =~ /^y/i;
	    } else {
		Carp::croak(
			    qq{Lockfile $lockfile not writeable by you. }.
			    qq{Cannot proceed.\n}.
			    qq{    On UNIX try:\n}.
			    qq{    rm $lockfile\n}.
			    qq{  and then rerun us.\n}
			   );
	    }
	} else {
            $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
                                           "reports other process with ID ".
                                           "$other. Cannot proceed.\n"));
        }
    }
    my $dotcpan = $CPAN::Config->{cpan_home};
    eval { File::Path::mkpath($dotcpan);};
    if ($@) {
      # A special case at least for Jarkko.
      my $firsterror = $@;
      my $seconderror;
      my $symlinkcpan;
      if (-l $dotcpan) {
	$symlinkcpan = readlink $dotcpan;
	die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
	eval { File::Path::mkpath($symlinkcpan); };
	if ($@) {
	  $seconderror = $@;
	} else {
	  $CPAN::Frontend->mywarn(qq{
Working directory $symlinkcpan created.
});
	}
      }
      unless (-d $dotcpan) {
	my $diemess = qq{
Your configuration suggests "$dotcpan" as your
CPAN.pm working directory. I could not create this directory due
to this error: $firsterror\n};
	$diemess .= qq{
As "$dotcpan" is a symlink to "$symlinkcpan",
I tried to create that, but I failed with this error: $seconderror
} if $seconderror;
	$diemess .= qq{
Please make sure the directory exists and is writable.
};
	$CPAN::Frontend->mydie($diemess);
      }
    }
    my $fh;
    unless ($fh = FileHandle->new(">$lockfile")) {
	if ($! =~ /Permission/) {
	    my $incc = $INC{'CPAN/Config.pm'};
	    my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
	    $CPAN::Frontend->myprint(qq{

Your configuration suggests that CPAN.pm should use a working
directory of
    $CPAN::Config->{cpan_home}
Unfortunately we could not create the lock file
    $lockfile
due to permission problems.

Please make sure that the configuration variable
    \$CPAN::Config->{cpan_home}
points to a directory where you can write a .lock file. You can set
this variable in either
    $incc
or
    $myincc

});
	}
	$CPAN::Frontend->mydie("Could not open >$lockfile: $!");
    }
    $fh->print($$, "\n");
    $self->{LOCK} = $lockfile;
    $fh->close;
    $SIG{TERM} = sub {
      &cleanup;
      $CPAN::Frontend->mydie("Got SIGTERM, leaving");
    };
    $SIG{INT} = sub {
      # no blocks!!!
      &cleanup if $Signal;
      $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
      print "Caught SIGINT\n";
      $Signal++;
    };

#       From: Larry Wall <[e-mail]>
#       Subject: Re: deprecating SIGDIE
#       To: [e-mail]
#       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
#
#       The original intent of __DIE__ was only to allow you to substitute one
#       kind of death for another on an application-wide basis without respect
#       to whether you were in an eval or not.  As a global backstop, it should
#       not be used any more lightly (or any more heavily :-) than class
#       UNIVERSAL.  Any attempt to build a general exception model on it should
#       be politely squashed.  Any bug that causes every eval {} to have to be
#       modified should be not so politely squashed.
#
#       Those are my current opinions.  It is also my optinion that polite
#       arguments degenerate to personal arguments far too frequently, and that
#       when they do, it's because both people wanted it to, or at least didn't
#       sufficiently want it not to.
#
#       Larry

    # global backstop to cleanup if we should really die
    $SIG{__DIE__} = \&cleanup;
    $self->debug("Signal handler set.") if $CPAN::DEBUG;
}

#-> sub CPAN::DESTROY ;
sub DESTROY {
    &cleanup; # need an eval?
}

#-> sub CPAN::anycwd ;
sub anycwd () {
    my $getcwd;
    $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
    CPAN->$getcwd();
}

#-> sub CPAN::cwd ;
sub cwd {Cwd::cwd();}

#-> sub CPAN::getcwd ;
sub getcwd {Cwd::getcwd();}

#-> sub CPAN::exists ;
sub exists {
    my($mgr,$class,$id) = @_;
    CPAN::Config->load unless $CPAN::Config_loaded++;
    CPAN::Index->reload;
    ### Carp::croak "exists called without class argument" unless $class;
    $id ||= "";
    exists $META->{readonly}{$class}{$id} or
        exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
}

#-> sub CPAN::delete ;
sub delete {
  my($mgr,$class,$id) = @_;
  delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
  delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
}

#-> sub CPAN::has_usable
# has_inst is sometimes too optimistic, we should replace it with this
# has_usable whenever a case is given
sub has_usable {
    my($self,$mod,$message) = @_;
    return 1 if $HAS_USABLE->{$mod};
    my $has_inst = $self->has_inst($mod,$message);
    return unless $has_inst;
    my $usable;
    $usable = {
               LWP => [ # we frequently had "Can't locate object
                        # method "new" via package "LWP::UserAgent" at
                        # (eval 69) line 2006
                       sub {require LWP},
                       sub {require LWP::UserAgent},
                       sub {require HTTP::Request},
                       sub {require URI::URL},
                      ],
               Net::FTP => [
                            sub {require Net::FTP},
                            sub {require Net::Config},
                           ]
              };
    if ($usable->{$mod}) {
      for my $c (0..$#{$usable->{$mod}}) {
        my $code = $usable->{$mod}[$c];
        my $ret = eval { &$code() };
        if ($@) {
          warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
          return;
        }
      }
    }
    return $HAS_USABLE->{$mod} = 1;
}

#-> sub CPAN::has_inst
sub has_inst {
    my($self,$mod,$message) = @_;
    Carp::croak("CPAN->has_inst() called without an argument")
	unless defined $mod;
    if (defined $message && $message eq "no"
        ||
        exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
        ||
        exists $CPAN::Config->{dontload_hash}{$mod}
       ) {
      $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
      return 0;
    }
    my $file = $mod;
    my $obj;
    $file =~ s|::|/|g;
    $file =~ s|/|\\|g if $^O eq 'MSWin32';
    $file .= ".pm";
    if ($INC{$file}) {
	# checking %INC is wrong, because $INC{LWP} may be true
	# although $INC{"URI/URL.pm"} may have failed. But as
	# I really want to say "bla loaded OK", I have to somehow
	# cache results.
	### warn "$file in %INC"; #debug
	return 1;
    } elsif (eval { require $file }) {
	# eval is good: if we haven't yet read the database it's
	# perfect and if we have installed the module in the meantime,
	# it tries again. The second require is only a NOOP returning
	# 1 if we had success, otherwise it's retrying

	$CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
	if ($mod eq "CPAN::WAIT") {
	    push @CPAN::Shell::ISA, CPAN::WAIT;
	}
	return 1;
    } elsif ($mod eq "Net::FTP") {
	$CPAN::Frontend->mywarn(qq{
  Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
  if you just type
      install Bundle::libnet

}) unless $Have_warned->{"Net::FTP"}++;
	sleep 3;
    } elsif ($mod eq "MD5"){
	$CPAN::Frontend->myprint(qq{
  CPAN: MD5 security checks disabled because MD5 not installed.
  Please consider installing the MD5 module.

});
	sleep 2;
    } else {
	delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
    }
    return 0;
}

#-> sub CPAN::instance ;
sub instance {
    my($mgr,$class,$id) = @_;
    CPAN::Index->reload;
    $id ||= "";
    # unsafe meta access, ok?
    return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
    $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
}

#-> sub CPAN::new ;
sub new {
    bless {}, shift;
}

#-> sub CPAN::cleanup ;
sub cleanup {
  # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
  local $SIG{__DIE__} = '';
  my($message) = @_;
  my $i = 0;
  my $ineval = 0;
  if (
      0 &&           # disabled, try reload cpan with it
      $] > 5.004_60  # thereabouts
     ) {
    $ineval = $^S;
  } else {
    my($subroutine);
    while ((undef,undef,undef,$subroutine) = caller(++$i)) {
      $ineval = 1, last if
	  $subroutine eq '(eval)';
    }
  }
  return if $ineval && !$End;
  return unless defined $META->{LOCK}; # unsafe meta access, ok
  return unless -f $META->{LOCK}; # unsafe meta access, ok
  unlink $META->{LOCK}; # unsafe meta access, ok
  # require Carp;
  # Carp::cluck("DEBUGGING");
  $CPAN::Frontend->mywarn("Lockfile removed.\n");
}

package CPAN::CacheMgr;

#-> sub CPAN::CacheMgr::as_string ;
sub as_string {
    eval { require Data::Dumper };
    if ($@) {
	return shift->SUPER::as_string;
    } else {
	return Data::Dumper::Dumper(shift);
    }
}

#-> sub CPAN::CacheMgr::cachesize ;
sub cachesize {
    shift->{DU};
}

#-> sub CPAN::CacheMgr::tidyup ;
sub tidyup {
  my($self) = @_;
  return unless -d $self->{ID};
  while ($self->{DU} > $self->{'MAX'} ) {
    my($toremove) = shift @{$self->{FIFO}};
    $CPAN::Frontend->myprint(sprintf(
				     "Deleting from cache".
				     ": $toremove (%.1f>%.1f MB)\n",
				     $self->{DU}, $self->{'MAX'})
			    );
    return if $CPAN::Signal;
    $self->force_clean_cache($toremove);
    return if $CPAN::Signal;
  }
}

#-> sub CPAN::CacheMgr::dir ;
sub dir {
    shift->{ID};
}

#-> sub CPAN::CacheMgr::entries ;
sub entries {
    my($self,$dir) = @_;
    return unless defined $dir;
    $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
    $dir ||= $self->{ID};
    my($cwd) = CPAN::anycwd();
    chdir $dir or Carp::croak("Can't chdir to $dir: $!");
    my $dh = DirHandle->new(File::Spec->curdir)
        or Carp::croak("Couldn't opendir $dir: $!");
    my(@entries);
    for ($dh->read) {
	next if $_ eq "." || $_ eq "..";
	if (-f $_) {
	    push @entries, MM->catfile($dir,$_);
	} elsif (-d _) {
	    push @entries, MM->catdir($dir,$_);
	} else {
	    $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
	}
    }
    chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
    sort { -M $b <=> -M $a} @entries;
}

#-> sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
    my($self,$dir) = @_;
    return if exists $self->{SIZE}{$dir};
    return if $CPAN::Signal;
    my($Du) = 0;
    find(
	 sub {
	   $File::Find::prune++ if $CPAN::Signal;
	   return if -l $_;
	   if ($^O eq 'MacOS') {
	     require Mac::Files;
	     my $cat  = Mac::Files::FSpGetCatInfo($_);
	     $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
	   } else {
	     $Du += (-s _);
	   }
	 },
	 $dir
	);
    return if $CPAN::Signal;
    $self->{SIZE}{$dir} = $Du/1024/1024;
    push @{$self->{FIFO}}, $dir;
    $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
    $self->{DU} += $Du/1024/1024;
    $self->{DU};
}

#-> sub CPAN::CacheMgr::force_clean_cache ;
sub force_clean_cache {
    my($self,$dir) = @_;
    return unless -e $dir;
    $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
	if $CPAN::DEBUG;
    File::Path::rmtree($dir);
    $self->{DU} -= $self->{SIZE}{$dir};
    delete $self->{SIZE}{$dir};
}

#-> sub CPAN::CacheMgr::new ;
sub new {
    my $class = shift;