/linkedfs/usr/lib/perl5/5.8.6/CPAN.pm
Perl | 7169 lines | 6676 code | 175 blank | 318 comment | 385 complexity | 5e757b07ad3ef5e5ad6a09dae26f9563 MD5 | raw file
Possible License(s): GPL-2.0, MIT, LGPL-3.0
Large files files are truncated, but you can click here to view the full file
- # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
- package CPAN;
- $VERSION = '1.76_01';
- $VERSION = eval $VERSION;
- # $Id: CPAN.pm,v 1.412 2003/07/31 14:53:04 k Exp $
- # only used during development:
- $Revision = "";
- # $Revision = "[".substr(q$Revision: 1.412 $, 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;
- use Sys::Hostname;
- no lib "."; # we need to run chdir all over and we would get at wrong
- # libraries there
- require Mac::BuildTools if $^O eq 'MacOS';
- 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';
- }
- if (my $histfile = $CPAN::Config->{'histfile'}) {{
- unless ($term->can("AddHistory")) {
- $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
- last;
- }
- my($fh) = FileHandle->new;
- open $fh, "<$histfile" or last;
- local $/ = "\n";
- while (<$fh>) {
- chomp;
- $term->AddHistory($_);
- }
- close $fh;
- }}
- # $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::Exception::RecursiveDependency;
- use overload '""' => "as_string";
- sub new {
- my($class) = shift;
- my($deps) = shift;
- my @deps;
- my %seen;
- for my $dep (@$deps) {
- push @deps, $dep;
- last if $seen{$dep}++;
- }
- bless { deps => \@deps }, $class;
- }
- sub as_string {
- my($self) = shift;
- "\nRecursive dependency detected:\n " .
- join("\n => ", @{$self->{deps}}) .
- ".\nCannot continue.\n";
- }
- 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.
- ################################################################################
- #-> 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 = File::Spec->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 $otherpid = <$fh>;
- my $otherhost = <$fh>;
- $fh->close;
- if (defined $otherpid && $otherpid) {
- chomp $otherpid;
- }
- if (defined $otherhost && $otherhost) {
- chomp $otherhost;
- }
- my $thishost = hostname();
- if (defined $otherhost && defined $thishost &&
- $otherhost ne '' && $thishost ne '' &&
- $otherhost ne $thishost) {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
- "reports other host $otherhost and other process $otherpid.\n".
- "Cannot proceed.\n"));
- }
- elsif (defined $otherpid && $otherpid) {
- return if $$ == $otherpid; # should never happen
- $CPAN::Frontend->mywarn(
- qq{
- There seems to be running another CPAN process (pid $otherpid). Contacting...
- });
- if (kill 0, $otherpid) {
- $CPAN::Frontend->mydie(qq{Other job is running.
- You may want to kill it and delete the lockfile, maybe. On UNIX try:
- kill $otherpid
- 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\n".
- "reports other process with ID ".
- "$otherpid. 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 = File::Spec->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");
- $fh->print(hostname(), "\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 <larry@wall.org>
- # Subject: Re: deprecating SIGDIE
- # To: perl5-porters@perl.org
- # 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 "Digest::MD5"){
- $CPAN::Frontend->myprint(qq{
- CPAN: MD5 security checks disabled because Digest::MD5 not installed.
- Please consider installing the Digest::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;
- 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};
- return unless -f $META->{LOCK};
- $META->savehist;
- unlink $META->{LOCK};
- # require Carp;
- # Carp::cluck("DEBUGGING");
- $CPAN::Frontend->mywarn("Lockfile removed.\n");
- }
- #-> sub CPAN::savehist
- sub savehist {
- my($self) = @_;
- my($histfile,$histsize);
- unless ($histfile = $CPAN::Config->{'histfile'}){
- $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
- return;
- }
- $histsize = $CPAN::Config->{'histsize'} || 100;
- if ($CPAN::term){
- unless ($CPAN::term->can("GetHistory")) {
- $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
- return;
- }
- } else {
- return;
- }
- my @h = $CPAN::term->GetHistory;
- splice @h, 0, @h-$histsize if @h>$histsize;
- my($fh) = FileHandle->new;
- open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
- local $\ = local $, = "\n";
- print $fh @h;
- close $fh;
- }
- sub is_tested {
- my($self,$what) = @_;
- $self->{is_tested}{$what} = 1;
- }
- sub is_installed {
- my($self,$what) = @_;
- delete $self->{is_tested}{$what};
- }
- sub set_perl5lib {
- my($self) = @_;
- $self->{is_tested} ||= {};
- return unless %{$self->{is_tested}};
- my $env = $ENV{PERL5LIB};
- $env = $ENV{PERLLIB} unless defined $env;
- my @env;
- push @env, $env if defined $env and length $env;
- my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
- $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
- $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
- }
- 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, File::Spec->catfile($dir,$_);
- } elsif (-d _) {
- push @entries, File::Spec->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;
- 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;
- }
- # This is a piece of repeated code that is abstracted here for
- # maintainability. RMB
- #
- sub _configpmtest {
- my($configpmdir, $configpmtest) = @_;
- if (-w $configpmtest) {
- return $configpmtest;
- } elsif (-w $configpmdir) {
- #_#_# following code dumped core on me with 5.003_11, a.k.
- my $configpm_bak = "$configpmtest.bak";
- unlink $configpm_bak if -f $configpm_bak;
- if( -f $configpmtest ) {
- if( rename $configpmtest, $configpm_bak ) {
- $CPAN::Frontend->mywarn(<<END)
- Old configuration file $configpmtest
- moved to $configpm_bak
- END
- }
- }
- my $fh = FileHandle->new;
- if ($fh->open(">$configpmtest")) {
- $fh->print("1;\n");
- return $configpmtest;
- } else {
- # Should never happen
- Carp::confess("Cannot open >$configpmtest");
- }
- } else { return }
- }
- #-> 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, File::Spec->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) = File::Spec->catdir($path_to_cpan,"CPAN");
- my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
- if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
- $configpm = _configpmtest($configpmdir,$configpmtest);
- }
- unless ($configpm) {
- $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
- File::Path::mkpath($configpmdir);
- $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
- $configpm = _configpmtest($configpmdir,$configpmtest);
- unless ($configpm) {
- 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\n");
- 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) {
- $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
- CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
- if ($dh = DirHandle->new($bdir)) { # may fail
- my($entry);
- for $entry ($dh->read) {
- next if $entry =~ /^\./;
- if (-d File::Spec->catdir($bdir,$entry)){
- push @bbase, "$bbase\::$entry";
- } else {
- next unless $entry =~ s/\.pm(?!\n)\Z//;
- $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
- }
- }
- }
- }
- }
- }
- #-> sub CPAN::Shell::b ;
- sub b {
- my($self,@which) = @_;
- CPAN->debug("which[@which]") if $CPAN::DEBUG;
- $self->local_bundles;
- $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
- }
- #-> sub CPAN::Shell::d ;
- sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
- #-> sub CPAN::Shell::m ;
- sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
- my $self = shift;
- $CPAN::Frontend->myprint($self->format_result('Module',@_));
- }
- #-> sub CPAN::Shell::i ;
- sub i {
- my($self) = shift;
- my(@args) = @_;
- my(@type,$type,@m);
- @type = qw/Author Bundle Distribution Module/;
- @args = '/./' unless @args;
- my(@result);
- for $type (@type) {
- push @result, $self->expand($type,@args);
- }
- my $result = @result == 1 ?
- $result[0]->as_string :
- @result == 0 ?
- "No objects found of any type for argument @args\n" :
- join("",
- (map {$_->as_glimpse} @result),
- scalar @result, " items found\n",
- );
- $CPAN::Frontend->myprint($result);
- }
- #-> sub CPAN::Shell::o ;
- # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
- # should have been called set and 'o debug' maybe 'set debug'
- sub o {
- my($self,$o_type,@o_what) = @_;
- $o_type ||= "";
- CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
- if ($o_type eq 'conf') {
- shift @o_what if @o_what && $o_what[0] eq 'help';
- if (!@o_what) { # print all things, "o conf"
- my($k,$v);
- $CPAN::Frontend->myprint("CPAN::Config options");
- if (exists $INC{'CPAN/Config.pm'}) {
- $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
- }
- if (exists $INC{'CPAN/MyConfig.pm'}) {
- $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
- }
- $CPAN::Frontend->myprint(":\n");
- for $k (sort keys %CPAN::Config::can) {
- $v = $CPAN::Config::can{$k};
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
- }
- $CPAN::Frontend->myprint("\n");
- for $k (sort keys %$CPAN::Config) {
- CPAN::Config->prettyprint($k);
- }
- $CPAN::Frontend->myprint("\n");
- } elsif (!CPAN::Config->edit(@o_what)) {
- $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
- qq{edit options\n\n});
- }
- } elsif ($o_type eq 'debug') {
- my(%valid);
- @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
- if (@o_what) {
- while (@o_what) {
- my($what) = shift @o_what;
- if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
- $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
- next;
- }
- if ( exists $CPAN::DEBUG{$what} ) {
- $CPAN::DEBUG |= $CPAN::DEBUG{$what};
- } elsif ($what =~ /^\d/) {
- $CPAN::DEBUG = $what;
- } elsif (lc $what eq 'all') {
- my($max) = 0;
- for (values %CPAN::DEBUG) {
- $max += $_;
- }
- $CPAN::DEBUG = $max;
- } else {
- my($known) = 0;
- for (keys %CPAN::DEBUG) {
- next unless lc($_) eq lc($what);
- $CPAN::DEBUG |= $CPAN::DEBUG{$_};
- $known = 1;
- }
- $CPAN::Frontend->myprint("unknown argument [$what]\n")
- unless $known;
- }
- }
- } else {
- my $raw = "Valid options for debug are ".
- join(", ",sort(keys %CPAN::DEBUG), 'all').
- qq{ or a number. Completion works on the options. }.
- qq{Case is ignored.};
- require Text::Wrap;
- $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
- $CPAN::Frontend->myprint("\n\n");
- }
- if ($CPAN::DEBUG) {
- $CPAN::Frontend->myprint("Options set for debugging:\n");
- my($k,$v);
- for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
- $v = $CPAN::DEBUG{$k};
- $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
- if $v & $CPAN::DEBUG;
- }
- } else {
- $CPAN::Frontend->myprint("Debugging turned off completely.\n");
- }
- } else {
- $CPAN::Frontend->myprint(qq{
- Known options:
- conf set or get configuration variables
- debug set or get debugging options
- });
- }
- }
- sub paintdots_onreload {
- my($ref) = shift;
- sub {
- if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
- my($subr) = $1;
- ++$$ref;
- local($|) = 1;
- # $CPAN::Frontend->myprint(".($subr)");
- $CPAN::Frontend->myprint(".");
- return;
- }
- warn @_;
- };
- }
- #-> sub CPAN::Shell::reload ;
- sub reload {
- my($self,$command,@arg) = @_;
- $command ||= "";
- $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
- if ($command =~ /cpan/i) {
- for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
- next unless $INC{$f};
- CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
- my $fh = FileHandle->new($INC{$f});
- local($/);
- my $redef = 0;
- local($SIG{__WARN__}) = paintdots_onreload(\$redef);
- eval <$fh>;
- warn $@ if $@;
- $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
- }
- } elsif ($command =~ /index/) {
- CPAN::Index->force_reload;
- } else {
- $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
- index re-reads the index files\n});
- }
- }
- #-> sub CPAN::Shell::_binary_extensions ;
- sub _binary_extensions {
- my($self) = shift @_;
- my(@result,$module,%seen,%need,$headerdone);
- for $module ($self->expand('Module','/./')) {
- my $file = $module->cpan_file;
- next if $file eq "N/A";
- next if $file =~ /^Contact Author/;
- my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
- next if $dist->isa_perl;
- next unless $module->xs_file;
- local($|) = 1;
- $CPAN::Frontend->myprint(".");
- push @result, $module;
- }
- # print join " | ", @result;
- $CPAN::Frontend->myprint("\n");
- return @result;
- }
- #-> sub CPAN::Shell::recompile ;
- sub recompile {
- my($self) = shift @_;
- my($module,@module,$cpan_file,%dist);
- @module = $self->_binary_extensions();
- for $module (@module){ # we force now and compile later, so we
- # don't do it twice
- $cpan_file = $module->cpan_file;
- my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->force;
- $dist{$cpan_file}++;
- }
- for $cpan_file (sort keys %dist) {
- $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
- my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->install;
- $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
- # stop a package from recompiling,
- # e.g. IO-1.12 when we have perl5.003_10
- }
- }
- #-> sub CPAN::Shell::_u_r_common ;
- sub _u_r_common {
- my($self) = shift @_;
- my($what) = shift @_;
- CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
- Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
- $what && $what =~ /^[aru]$/;
- my(@args) = @_;
- @args = '/./' unless @args;
- my(@result,$module,%seen,%need,$headerdone,
- $version_undefs,$version_zeroes);
- $version_undefs = $version_zeroes = 0;
- my $sprintf = "%s%-25s%s %9s %9s %s\n";
- my @expand = $self->expand('Module',@args);
- my $expand = scalar @expand;
- if (0) { # Looks like noise to me, was very useful for debugging
- # for metadata cache
- $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
- }
- for $module (@expand) {
- my $file = $module->cpan_file;
- next unless defined $file; # ??
- my($latest) = $module->cpan_version;
- my($inst_file) = $module->inst_file;
- my($have);
- return if $CPAN::Signal;
- if ($inst_file){
- if ($what eq "a") {
- $have = $module->inst_version;
- } elsif ($what eq "r") {
- $have = $module->inst_version;
- local($^W) = 0;
- if ($have eq "undef"){
- $version_undefs++;
- } elsif ($have == 0){
- $version_zeroes++;
- }
- next unless CPAN::Version->vgt($latest, $have);
- # to be pedantic w…
Large files files are truncated, but you can click here to view the full file