# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN;
$CPAN::VERSION = '1.9203';
$CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/;
use CPAN::HandleConfig;
use CPAN::Version;
use CPAN::Debug;
use CPAN::Queue;
use CPAN::Tarzip;
use CPAN::DeferedCode;
use Carp ();
use Config ();
use Cwd ();
use DirHandle ();
use Exporter ();
use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
# 5.005_04 does not work without
# this
use File::Basename ();
use File::Copy ();
use File::Find;
use File::Path ();
use File::Spec ();
use FileHandle ();
use Fcntl qw(:flock);
use Safe ();
use Sys::Hostname qw(hostname);
use Text::ParseWords ();
use Text::Wrap ();
# we need to run chdir all over and we would get at wrong libraries
# there
BEGIN {
if (File::Spec->can("rel2abs")) {
for my $inc (@INC) {
$inc = File::Spec->rel2abs($inc) unless ref $inc;
}
}
}
no lib ".";
require Mac::BuildTools if $^O eq 'MacOS';
$ENV{PERL5_CPAN_IS_RUNNING}=$$;
$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
END { $CPAN::End++; &cleanup; }
$CPAN::Signal ||= 0;
$CPAN::Frontend ||= "CPAN::Shell";
unless (@CPAN::Defaultsites) {
@CPAN::Defaultsites = map {
CPAN::URL->new(TEXT => $_, FROM => "DEF")
}
"http://www.perl.org/CPAN/",
"ftp://ftp.perl.org/pub/CPAN/";
}
# $CPAN::iCwd (i for initial) is going to be initialized during find_perl
$CPAN::Perl ||= CPAN::find_perl();
$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
# our globals are getting a mess
use vars qw(
$AUTOLOAD
$Be_Silent
$CONFIG_DIRTY
$Defaultdocs
$Echo_readline
$Frontend
$GOTOSHELL
$HAS_USABLE
$Have_warned
$MAX_RECURSION
$META
$RUN_DEGRADED
$Signal
$SQLite
$Suppress_readline
$VERSION
$autoload_recursion
$term
@Defaultsites
@EXPORT
);
$MAX_RECURSION = 32;
@CPAN::ISA = qw(CPAN::Debug Exporter);
# note that these functions live in CPAN::Shell and get executed via
# AUTOLOAD when called directly
@EXPORT = qw(
autobundle
bundle
clean
cvs_import
expand
force
fforce
get
install
install_tested
is_tested
make
mkmyconfig
notest
perldoc
readme
recent
recompile
report
shell
smoke
test
upgrade
);
sub soft_chdir_with_alternatives ($);
{
$autoload_recursion ||= 0;
#-> sub CPAN::AUTOLOAD ;
sub AUTOLOAD {
$autoload_recursion++;
my($l) = $AUTOLOAD;
$l =~ s/.*:://;
if ($CPAN::Signal) {
warn "Refusing to autoload '$l' while signal pending";
$autoload_recursion--;
return;
}
if ($autoload_recursion > 1) {
my $fullcommand = join " ", map { "'$_'" } $l, @_;
warn "Refusing to autoload $fullcommand in recursion\n";
$autoload_recursion--;
return;
}
my(%export);
@export{@EXPORT} = '';
CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
if (exists $export{$l}) {
CPAN::Shell->$l(@_);
} else {
die(qq{Unknown CPAN command "$AUTOLOAD". }.
qq{Type ? for help.\n});
}
$autoload_recursion--;
}
}
#-> sub CPAN::shell ;
sub shell {
my($self) = @_;
$Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
my $oprompt = shift || CPAN::Prompt->new;
my $prompt = $oprompt;
my $commandline = shift || "";
$CPAN::CurrentCommandId ||= 1;
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;
}
$META->readhist($term,$histfile);
}}
for ($CPAN::Config->{term_ornaments}) { # alias
local $Term::ReadLine::termcap_nowarn = 1;
$term->ornaments($_) if defined;
}
# $term->OUT is autoflushed anyway
my $odef = select STDERR;
$| = 1;
select STDOUT;
$| = 1;
select $odef;
}
$META->checklock();
my @cwd = grep { defined $_ and length $_ }
CPAN::anycwd(),
File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
File::Spec->rootdir();
my $try_detect_readline;
$try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
unless ($CPAN::Config->{inhibit_startup_message}) {
my $rl_avail = $Suppress_readline ? "suppressed" :
($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
"available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
$CPAN::Frontend->myprint(
sprintf qq{
cpan shell -- CPAN exploration and modules installation (v%s)
ReadLine support %s
},
$CPAN::VERSION,
$rl_avail
)
}
my($continuation) = "";
my $last_term_ornaments;
SHELLCOMMAND: while () {
if ($Suppress_readline) {
if ($Echo_readline) {
$|=1;
}
print $prompt;
last SHELLCOMMAND unless defined ($_ = <> );
if ($Echo_readline) {
# backdoor: I could not find a way to record sessions
print $_;
}
chomp;
} else {
last SHELLCOMMAND unless
defined ($_ = $term->readline($prompt, $commandline));
}
$_ = "$continuation$_" if $continuation;
s/^\s+//;
next SHELLCOMMAND if /^$/;
s/^\s*\?\s*/help /;
if (/^(?:q(?:uit)?|bye|exit)$/i) {
last SHELLCOMMAND;
} elsif (s/\\$//s) {
chomp;
$continuation = $_;
$prompt = " > ";
} elsif (/^\!/) {
s/^\!//;
my($eval) = $_;
package CPAN::Eval;
use strict;
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);
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) };
if ($@) {
my $err = "$@";
if ($err =~ /\S/) {
require Carp;
require Dumpvalue;
my $dv = Dumpvalue->new();
Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
}
}
if ($command =~ /^(
# classic commands
make
|test
|install
|clean
# pragmas for classic commands
|ff?orce
|notest
# compounds
|report
|smoke
|upgrade
)$/x) {
# only commands that tell us something about failed distros
CPAN::Shell->failed($CPAN::CurrentCommandId,1);
}
soft_chdir_with_alternatives(\@cwd);
$CPAN::Frontend->myprint("\n");
$continuation = "";
$CPAN::CurrentCommandId++;
$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");
$GOTOSHELL = 1;
}
}
if ($term and $term->can("ornaments")) {
for ($CPAN::Config->{term_ornaments}) { # alias
if (defined $_) {
if (not defined $last_term_ornaments
or $_ != $last_term_ornaments
) {
local $Term::ReadLine::termcap_nowarn = 1;
$term->ornaments($_);
$last_term_ornaments = $_;
}
} else {
undef $last_term_ornaments;
}
}
}
for my $class (qw(Module Distribution)) {
# again unsafe meta access?
for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
CPAN->debug("BUG: $class '$dm' was in command state, resetting");
delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
}
}
if ($GOTOSHELL) {
$GOTOSHELL = 0; # not too often
$META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
@_ = ($oprompt,"");
goto &shell;
}
}
soft_chdir_with_alternatives(\@cwd);
}
sub soft_chdir_with_alternatives ($) {
my($cwd) = @_;
unless (@$cwd) {
my $root = File::Spec->rootdir();
$CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
Trying '$root' as temporary haven.
});
push @$cwd, $root;
}
while () {
if (chdir $cwd->[0]) {
return;
} else {
if (@$cwd>1) {
$CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
Trying to chdir to "$cwd->[1]" instead.
});
shift @$cwd;
} else {
$CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
}
}
}
}
sub _flock {
my($fh,$mode) = @_;
if ($Config::Config{d_flock}) {
return flock $fh, $mode;
} elsif (!$Have_warned->{"d_flock"}++) {
$CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
$CPAN::Frontend->mysleep(5);
return 1;
} else {
return 1;
}
}
sub _yaml_module () {
my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
if (
$yaml_module ne "YAML"
&&
!$CPAN::META->has_inst($yaml_module)
) {
# $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
$yaml_module = "YAML";
}
if ($yaml_module eq "YAML"
&&
$CPAN::META->has_inst($yaml_module)
&&
$YAML::VERSION < 0.60
&&
!$Have_warned->{"YAML"}++
) {
$CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
"I'll continue but problems are *very* likely to happen.\n"
);
$CPAN::Frontend->mysleep(5);
}
return $yaml_module;
}
# CPAN::_yaml_loadfile
sub _yaml_loadfile {
my($self,$local_file) = @_;
return +[] unless -s $local_file;
my $yaml_module = _yaml_module;
if ($CPAN::META->has_inst($yaml_module)) {
# temporarly enable yaml code deserialisation
no strict 'refs';
# 5.6.2 could not do the local() with the reference
local $YAML::LoadCode;
local $YAML::Syck::LoadCode;
${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
my $code;
if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
my @yaml;
eval { @yaml = $code->($local_file); };
if ($@) {
# this shall not be done by the frontend
die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
}
return \@yaml;
} elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
local *FH;
open FH, $local_file or die "Could not open '$local_file': $!";
local $/;
my $ystream = <FH>;
my @yaml;
eval { @yaml = $code->($ystream); };
if ($@) {
# this shall not be done by the frontend
die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
}
return \@yaml;
}
} else {
# this shall not be done by the frontend
die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
}
return +[];
}
# CPAN::_yaml_dumpfile
sub _yaml_dumpfile {
my($self,$local_file,@what) = @_;
my $yaml_module = _yaml_module;
if ($CPAN::META->has_inst($yaml_module)) {
my $code;
if (UNIVERSAL::isa($local_file, "FileHandle")) {
$code = UNIVERSAL::can($yaml_module, "Dump");
eval { print $local_file $code->(@what) };
} elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
eval { $code->($local_file,@what); };
} elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
local *FH;
open FH, ">$local_file" or die "Could not open '$local_file': $!";
print FH $code->(@what);
}
if ($@) {
die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
}
} else {
if (UNIVERSAL::isa($local_file, "FileHandle")) {
# I think this case does not justify a warning at all
} else {
die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
}
}
}
sub _init_sqlite () {
unless ($CPAN::META->has_inst("CPAN::SQLite")) {
$CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
unless $Have_warned->{"CPAN::SQLite"}++;
return;
}
require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
$CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
}
{
my $negative_cache = {};
sub _sqlite_running {
if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
# need to cache the result, otherwise too slow
return $negative_cache->{fact};
} else {
$negative_cache = {}; # reset
}
my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
return $ret if $ret; # fast anyway
$negative_cache->{time} = time;
return $negative_cache->{fact} = $ret;
}
}
package CPAN::CacheMgr;
use strict;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use File::Find;
package CPAN::FTP;
use strict;
use Fcntl qw(:flock);
use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
@CPAN::FTP::ISA = qw(CPAN::Debug);
package CPAN::LWP::UserAgent;
use strict;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
# we delay requiring LWP::UserAgent and setting up inheritance until we need it
package CPAN::Complete;
use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
# Q: where is the "How do I add a new command" HOWTO?
# A: svn diff -r 1048:1049 where andk added the report command
@CPAN::Complete::COMMANDS = sort qw(
? ! a b d h i m o q r u
autobundle
bye
clean
cvs_import
dump
exit
failed
force
fforce
hosts
install
install_tested
is_tested
look
ls
make
mkmyconfig
notest
perldoc
quit
readme
recent
recompile
reload
report
reports
scripts
smoke
test
upgrade
);
package CPAN::Index;
use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
@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;
use strict;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);
package CPAN::Author;
use strict;
@CPAN::Author::ISA = qw(CPAN::InfoObj);
package CPAN::Distribution;
use strict;
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
package CPAN::Bundle;
use strict;
@CPAN::Bundle::ISA = qw(CPAN::Module);
package CPAN::Module;
use strict;
@CPAN::Module::ISA = qw(CPAN::InfoObj);
package CPAN::Exception::RecursiveDependency;
use strict;
use overload '""' => "as_string";
# a module sees its distribution (no version)
# a distribution sees its prereqs (which are module names) (usually with versions)
# a bundle sees its module names and/or its distributions (no version)
sub new {
my($class) = shift;
my($deps) = shift;
my (@deps,%seen,$loop_starts_with);
DCHAIN: for my $dep (@$deps) {
push @deps, {name => $dep, display_as => $dep};
if ($seen{$dep}++) {
$loop_starts_with = $dep;
last DCHAIN;
}
}
my $in_loop = 0;
for my $i (0..$#deps) {
my $x = $deps[$i]{name};
$in_loop ||= $x eq $loop_starts_with;
my $xo = CPAN::Shell->expandany($x) or next;
if ($xo->isa("CPAN::Module")) {
my $have = $xo->inst_version || "N/A";
my($want,$d,$want_type);
if ($i>0 and $d = $deps[$i-1]{name}) {
my $do = CPAN::Shell->expandany($d);
$want = $do->{prereq_pm}{requires}{$x};
if (defined $want) {
$want_type = "requires: ";
} else {
$want = $do->{prereq_pm}{build_requires}{$x};
if (defined $want) {
$want_type = "build_requires: ";
} else {
$want_type = "unknown status";
$want = "???";
}
}
} else {
$want = $xo->cpan_version;
$want_type = "want: ";
}
$deps[$i]{have} = $have;
$deps[$i]{want_type} = $want_type;
$deps[$i]{want} = $want;
$deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
} elsif ($xo->isa("CPAN::Distribution")) {
$deps[$i]{display_as} = $xo->pretty_id;
if ($in_loop) {
$xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
} else {
$xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
}
$xo->store_persistent_state; # otherwise I will not reach
# all involved parties for
# the next session
}
}
bless { deps => \@deps }, $class;
}
sub as_string {
my($self) = shift;
my $ret = "\nRecursive dependency detected:\n ";
$ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
$ret .= ".\nCannot resolve.\n";
$ret;
}
package CPAN::Exception::yaml_not_installed;
use strict;
use overload '""' => "as_string";
sub new {
my($class,$module,$file,$during) = @_;
bless { module => $module, file => $file, during => $during }, $class;
}
sub as_string {
my($self) = shift;
"'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
}
package CPAN::Exception::yaml_process_error;
use strict;
use overload '""' => "as_string";
sub new {
my($class,$module,$file,$during,$error) = @_;
bless { module => $module,
file => $file,
during => $during,
error => $error }, $class;
}
sub as_string {
my($self) = shift;
if ($self->{during}) {
if ($self->{file}) {
if ($self->{module}) {
if ($self->{error}) {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"with '$self->{module}' the following error was encountered:\n".
" $self->{error}\n";
} else {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"with '$self->{module}' some unknown error was encountered\n";
}
} else {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"some unknown error was encountered\n";
}
} else {
return "Alert: While trying to '$self->{during}' some YAML file\n".
"some unknown error was encountered\n";
}
} else {
return "Alert: unknown error encountered\n";
}
}
package CPAN::Prompt; use overload '""' => "as_string";
use vars qw($prompt);
$prompt = "cpan> ";
$CPAN::CurrentCommandId ||= 0;
sub new {
bless {}, shift;
}
sub as_string {
my $word = "cpan";
unless ($CPAN::META->{LOCK}) {
$word = "nolock_cpan";
}
if ($CPAN::Config->{commandnumber_in_prompt}) {
sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
} else {
"$word> ";
}
}
package CPAN::URL; use overload '""' => "as_string", fallback => 1;
# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
# planned are things like age or quality
sub new {
my($class,%args) = @_;
bless {
%args
}, $class;
}
sub as_string {
my($self) = @_;
$self->text;
}
sub text {
my($self,$set) = @_;
if (defined $set) {
$self->{TEXT} = $set;
}
$self->{TEXT};
}
package CPAN::Distrostatus;
use overload '""' => "as_string",
fallback => 1;
sub new {
my($class,$arg) = @_;
bless {
TEXT => $arg,
FAILED => substr($arg,0,2) eq "NO",
COMMANDID => $CPAN::CurrentCommandId,
TIME => time,
}, $class;
}
sub commandid { shift->{COMMANDID} }
sub failed { shift->{FAILED} }
sub text {
my($self,$set) = @_;
if (defined $set) {
$self->{TEXT} = $set;
}
$self->{TEXT};
}
sub as_string {
my($self) = @_;
$self->text;
}
package CPAN::Shell;
use strict;
use vars qw(
$ADVANCED_QUERY
$AUTOLOAD
$COLOR_REGISTERED
$Help
$autoload_recursion
$reload
@ISA
);
@CPAN::Shell::ISA = qw(CPAN::Debug);
$COLOR_REGISTERED ||= 0;
$Help = {
'?' => \"help",
'!' => "eval the rest of the line as perl",
a => "whois author",
autobundle => "wtite inventory into a bundle file",
b => "info about bundle",
bye => \"quit",
clean => "clean up a distribution's build directory",
# cvs_import
d => "info about a distribution",
# dump
exit => \"quit",
failed => "list all failed actions within current session",
fforce => "redo a command from scratch",
force => "redo a command",
h => \"help",
help => "overview over commands; 'help ...' explains specific commands",
hosts => "statistics about recently used hosts",
i => "info about authors/bundles/distributions/modules",
install => "install a distribution",
install_tested => "install all distributions tested OK",
is_tested => "list all distributions tested OK",
look => "open a subshell in a distribution's directory",
ls => "list distributions according to a glob",
m => "info about a module",
make => "make/build a distribution",
mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
notest => "run a (usually install) command but leave out the test phase",
o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
perldoc => "try to get a manpage for a module",
q => \"quit",
quit => "leave the cpan shell",
r => "review over upgradeable modules",
readme => "display the README of a distro woth a pager",
recent => "show recent uploads to the CPAN",
# recompile
reload => "'reload cpan' or 'reload index'",
report => "test a distribution and send a test report to cpantesters",
reports => "info about reported tests from cpantesters",
# scripts
# smoke
test => "test a distribution",
u => "display uninstalled modules",
upgrade => "combine 'r' command with immediate installation",
};
{
$autoload_recursion ||= 0;
#-> sub CPAN::Shell::AUTOLOAD ;
sub AUTOLOAD {
$autoload_recursion++;
my($l) = $AUTOLOAD;
my $class = shift(@_);
# warn "autoload[$l] class[$class]";
$l =~ s/.*:://;
if ($CPAN::Signal) {
warn "Refusing to autoload '$l' while signal pending";
$autoload_recursion--;
return;
}
if ($autoload_recursion > 1) {
my $fullcommand = join " ", map { "'$_'" } $l, @_;
warn "Refusing to autoload $fullcommand in recursion\n";
$autoload_recursion--;
return;
}
if ($l =~ /^w/) {
# XXX needs to be reconsidered
if ($CPAN::META->has_inst('CPAN::WAIT')) {
CPAN::WAIT->$l(@_);
} 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 shell command '$l'. }.
qq{Type ? for help.
});
}
$autoload_recursion--;
}
}
package CPAN;
use strict;
$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
# from here on only subs.
################################################################################
sub _perl_fingerprint {
my($self,$other_fingerprint) = @_;
my $dll = eval {OS2::DLLname()};
my $mtime_dll = 0;
if (defined $dll) {
$mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
}
my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
my $this_fingerprint = {
'$^X' => $^X,
sitearchexp => $Config::Config{sitearchexp},
'mtime_$^X' => $mtime_perl,
'mtime_dll' => $mtime_dll,
};
if ($other_fingerprint) {
if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
$other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
}
# mandatory keys since 1.88_57
for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
}
return 1;
} else {
return $this_fingerprint;
}
}
sub suggest_myconfig () {
SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
$CPAN::Frontend->myprint("You don't seem to have a user ".
"configuration (MyConfig.pm) yet.\n");
my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
"user configuration now? (Y/n)",
"yes");
if($new =~ m{^y}i) {
CPAN::Shell->mkmyconfig();
return &checklock;
} else {
$CPAN::Frontend->mydie("OK, giving up.");
}
}
}
#-> sub CPAN::all_objects ;
sub all_objects {
my($mgr,$class) = @_;
CPAN::HandleConfig->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
}
# 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 '$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 ($RUN_DEGRADED) {
$CPAN::Frontend->mywarn("Running in degraded mode (experimental)\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->mywarn(qq{Other job is running.\n});
my($ans) =
CPAN::Shell::colorable_makemaker_prompt
(qq{Shall I try to run in degraded }.
qq{mode? (Y/n)},"y");
if ($ans =~ /^y/i) {
$CPAN::Frontend->mywarn("Running in degraded mode (experimental).
Please report if something unexpected happens\n");
$RUN_DEGRADED = 1;
for ($CPAN::Config) {
# XXX
# $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
$_->{commandnumber_in_prompt} = 0; # visibility
$_->{histfile} = ""; # who should win otherwise?
$_->{cache_metadata} = 0; # better would be a lock?
$_->{use_sqlite} = 0; # better would be a write lock!
}
} else {
$CPAN::Frontend->mydie("
You may want to kill the other job and delete the lockfile. On UNIX try:
kill $otherpid
rm $lockfile
");
}
} elsif (-w $lockfile) {
my($ans) =
CPAN::Shell::colorable_makemaker_prompt
(qq{Other job not responding. Shall I overwrite }.
qq{the lockfile '$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: Found invalid lockfile ".
"'$lockfile', please remove. 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 $mess = qq{
Your configuration suggests "$dotcpan" as your
CPAN.pm working directory. I could not create this directory due
to this error: $firsterror\n};
$mess .= qq{
As "$dotcpan" is a symlink to "$symlinkcpan",
I tried to create that, but I failed with this error: $seconderror
} if $seconderror;
$mess .= qq{
Please make sure the directory exists and is writable.
};
$CPAN::Frontend->mywarn($mess);
return suggest_myconfig;
}
} # $@ after eval mkpath $dotcpan
if (0) { # to test what happens when a race condition occurs
for (reverse 1..10) {
print $_, "\n";
sleep 1;
}
}
# locking
if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
my $fh;
unless ($fh = FileHandle->new("+>>$lockfile")) {
if ($! =~ /Permission/) {
$CPAN::Frontend->mywarn(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 a CPAN/MyConfig.pm or a CPAN/Config.pm in your
\@INC path;
});
return suggest_myconfig;
}
}
my $sleep = 1;
while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
if ($sleep>10) {
$CPAN::Frontend->mydie("Giving up\n");
}
$CPAN::Frontend->mysleep($sleep++);
$CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
}
seek $fh, 0, 0;
truncate $fh, 0;
$fh->print($$, "\n");
$fh->print(hostname(), "\n");
$self->{LOCK} = $lockfile;
$self->{LOCKFH} = $fh;
}
$SIG{TERM} = sub {
my $sig = shift;
&cleanup;
$CPAN::Frontend->mydie("Got SIG$sig, leaving");
};
$SIG{INT} = sub {
# no blocks!!!
my $sig = shift;
&cleanup if $Signal;
die "Got yet another signal" if $Signal > 1;
$CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
$CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\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::fastcwd ;
sub fastcwd {Cwd::fastcwd();}
#-> sub CPAN::backtickcwd ;
sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
#-> sub CPAN::find_perl ;
sub find_perl {
my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
my $pwd = $CPAN::iCwd = CPAN::anycwd();
my $candidate = File::Spec->catfile($pwd,$^X);
$perl ||= $candidate if MM->maybe_command($candidate);
unless ($perl) {
my ($component,$perl_name);
DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
PATH_COMPONENT: foreach $component (File::Spec->path(),
$Config::Config{'binexp'}) {
next unless defined($component) && $component;
my($abs) = File::Spec->catfile($component,$perl_name);
if (MM->maybe_command($abs)) {
$perl = $abs;
last DIST_PERLNAME;
}
}
}
}
return $perl;
}
#-> sub CPAN::exists ;
sub exists {
my($mgr,$class,$id) = @_;
CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
CPAN::Index->reload;
### Carp::croak "exists called without class argument" unless $class;
$id ||= "";
$id =~ s/:+/::/g if $class eq "CPAN::Module";
my $exists;
if (CPAN::_sqlite_running) {
$exists = (exists $META->{readonly}{$class}{$id} or
$CPAN::SQLite->set($class, $id));
} else {
$exists = exists $META->{readonly}{$class}{$id};
}
$exists ||= 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},
],
'File::HomeDir' => [
sub {require File::HomeDir;
unless (File::HomeDir::->VERSION >= 0.52) {
for ("Will not use File::HomeDir, need 0.52\n") {
$CPAN::Frontend->mywarn($_);
die $_;
}
}
},
],
'Archive::Tar' => [
sub {require Archive::Tar;
unless (Archive::Tar::->VERSION >= 1.00) {
for ("Will not use Archive::Tar, need 1.00\n") {
$CPAN::Frontend->mywarn($_);
die $_;
}
}
},
],
};
if ($usable->{$mod}) {
for my $c (0..$#{$usable->{$mod}}) {
my $code = $usable->{$mod}[$c];
my $ret = eval { &$code() };
$ret = "" unless defined $ret;
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;
my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
keys %{$CPAN::Config->{dontload_hash}||{}},
@{$CPAN::Config->{dontload_list}||[]};
if (defined $message && $message eq "no" # afair only used by Nox
||
$dont{$mod}
) {
$CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
return 0;
}
my $file = $mod;
my $obj;
$file =~ s|::|/|g;
$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
my $mtime = (stat $INC{$file})[9];
# privileged files loaded by has_inst; Note: we use $mtime
# as a proxy for a checksum.
$CPAN::Shell::reload->{$file} = $mtime;
my $v = eval "\$$mod\::VERSION";
$v = $v ? " (v$v)" : "";
CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\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"}++;
$CPAN::Frontend->mysleep(3);
} elsif ($mod eq "Digest::SHA") {
if ($Have_warned->{"Digest::SHA"}++) {
$CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
qq{because Digest::SHA not installed.\n});
} else {
$CPAN::Frontend->mywarn(qq{
CPAN: checksum security checks disabled because Digest::SHA not installed.
Please consider installing the Digest::SHA module.
});
$CPAN::Frontend->mysleep(2);
}
} elsif ($mod eq "Module::Signature") {
# NOT prefs_lookup, we are not a distro
my $check_sigs = $CPAN::Config->{check_sigs};
if (not $check_sigs) {
# they do not want us:-(
} elsif (not $Have_warned->{"Module::Signature"}++) {
# No point in complaining unless the user can
# reasonably install and use it.
if (eval { require Crypt::OpenPGP; 1 } ||
(
defined $CPAN::Config->{'gpg'}
&&
$CPAN::Config->{'gpg'} =~ /\S/
)
) {
$CPAN::Frontend->mywarn(qq{
CPAN: Module::Signature security checks disabled because Module::Signature
not installed. Please consider installing the Module::Signature module.
You may also need to be able to connect over the Internet to the public
keyservers like pgp.mit.edu (port 11371).
});
$CPAN::Frontend->mysleep(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[$CPAN::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 && !$CPAN::End;
return unless defined $META->{LOCK};
return unless -f $META->{LOCK};
$META->savehist;
close $META->{LOCKFH};
unlink $META->{LOCK};
# require Carp;
# Carp::cluck("DEBUGGING");
if ( $CPAN::CONFIG_DIRTY ) {
$CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
}
$CPAN::Frontend->myprint("Lockfile removed.\n");
}
#-> sub CPAN::readhist
sub readhist {
my($self,$term,$histfile) = @_;
my($fh) = FileHandle->new;
open $fh, "<$histfile" or last;
local $/ = "\n";
while (<$fh>) {
chomp;
$term->AddHistory($_);
}
close $fh;
}
#-> 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 CPAN::is_tested
sub is_tested {
my($self,$what,$when) = @_;
unless ($what) {
Carp::cluck("DEBUG: empty what");
return;
}
$self->{is_tested}{$what} = $when;
}
#-> sub CPAN::is_installed
# unsets the is_tested flag: as soon as the thing is installed, it is
# not needed in set_perl5lib anymore
sub is_installed {
my($self,$what) = @_;
delete $self->{is_tested}{$what};
}
sub _list_sorted_descending_is_tested {
my($self) = @_;
sort
{ ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
keys %{$self->{is_tested}}
}
#-> sub CPAN::set_perl5lib
sub set_perl5lib {
my($self,$for) = @_;
unless ($for) {
(undef,undef,undef,$for) = caller(1);
$for =~ s/.*://;
}
$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");
my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
if (@dirs < 12) {
$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
} elsif (@dirs < 24) {
my @d = map {my $cp = $_;
$cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
$cp
} @dirs;
$CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
"%BUILDDIR%=$CPAN::Config->{build_dir} ".
"for '$for'\n"
);
} else {
my $cnt = keys %{$self->{is_tested}};
$CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
"$cnt build dirs to PERL5LIB; ".
"for '$for'\n"
);
}
$ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
}
package CPAN::CacheMgr;
use strict;
#-> 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 $CPAN::META->{LOCK};
return unless -d $self->{ID};
my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
for my $current (0..$#toremove) {
my $toremove = $toremove[$current];
$CPAN::Frontend->myprint(sprintf(
"DEL(%d/%d): %s \n",
$current+1,
scalar @toremove,
$toremove,
)
);
return if $CPAN::Signal;
$self->_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 $a <=> -M $b} @entries;
}
#-> sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
my($self,$dir,$fast) = @_;
return if exists $self->{SIZE}{$dir};
return if $CPAN::Signal;
my($Du) = 0;
if (-e $dir) {
if (-d $dir) {
unless (-x $dir) {
unless (chmod 0755, $dir) {
$CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
"permission to change the permission; cannot ".
"estimate disk usage of '$dir'\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
} elsif (-f $dir) {
# nothing to say, no matter what the permissions
}
} else {
$CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
return;
}
if ($fast) {
$Du = 0; # placeholder
} else {
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 {
if (-d _) {
unless (-x _) {
unless (chmod 0755, $_) {
$CPAN::Frontend->mywarn("I have neither the -x permission nor ".
"the permission to change the permission; ".
"can only partially estimate disk usage ".
"of '$_'\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
} else {
$Du += (-s _);
}
}
},
$dir
);
}
return if $CPAN::Signal;
$self->{SIZE}{$dir} = $Du/1024/1024;
unshift @{$self->{FIFO}}, $dir;
$self->debug("measured $dir is $Du") if $CPAN::DEBUG;
$self->{DU} += $Du/1024/1024;
$self->{DU};
}
#-> sub CPAN::CacheMgr::_clean_cache ;
sub _clean_cache {
my($self,$dir) = @_;
return unless -e $dir;
unless (File::Spec->canonpath(File::Basename::dirname($dir))
eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
"will not remove\n");
$CPAN::Frontend->mysleep(5);
return;
}
$self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
if $CPAN::DEBUG;
File::Path::rmtree($dir);
my $id_deleted = 0;
if ($dir !~ /\.yml$/ && -f "$dir.yml") {
my $yaml_module = CPAN::_yaml_module;
if ($CPAN::META->has_inst($yaml_module)) {
my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
if ($@) {
$CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
unlink "$dir.yml" or
$CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
return;
} elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
$CPAN::META->delete("CPAN::Distribution", $id);
# XXX we should restore the state NOW, otherise this
# distro does not exist until we read an index. BUG ALERT(?)
# $CPAN::Frontend->mywarn (" +++\n");
$id_deleted++;
}
}
unlink "$dir.yml"; # may fail
unless ($id_deleted) {
CPAN->debug("no distro found associated with '$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';
return unless $CPAN::META->{LOCK};
$CPAN::Frontend->myprint(
sprintf("Scanning cache %s for sizes\n",
$self->{ID}));
my $e;
my @entries = $self->entries($self->{ID});
my $i = 0;
my $painted = 0;
for $e (@entries) {
my $symbol = ".";
if ($self->{DU} > $self->{MAX}) {
$symbol = "-";
$self->disk_usage($e,1);
} else {
$self->disk_usage($e);
}
$i++;
while (($painted/76) < ($i/@entries)) {
$CPAN::Frontend->myprint($symbol);
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
$self->tidyup;
}
package CPAN::Shell;
use strict;
#-> sub CPAN::Shell::h ;
sub h {
my($class,$about) = @_;
if (defined $about) {
my $help;
if (exists $Help->{$about}) {
if (ref $Help->{$about}) { # aliases
$about = ${$Help->{$about}};
}
$help = $Help->{$about};
} else {
$help = "No help available";
}
$CPAN::Frontend->myprint("$about\: $help\n");
} else {
my $filler = " " x (80 - 28 - length($CPAN::VERSION));
$CPAN::Frontend->myprint(qq{
Display Information $filler (ver $CPAN::VERSION)
command argument description
a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
i WORD or /REGEXP/ about any of the above
ls AUTHOR or GLOB about files in the author's directory
(with WORD being a module, bundle or author name or a distribution
name of the form AUTHOR/DISTRIBUTION)
Download, Test, Make, Install...
get download clean make clean
make make (implies get) look open subshell in dist directory
test make test (implies make) readme display these README files
install make install (implies test) perldoc display POD documentation
Upgrade
r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
Pragmas
force CMD try hard to do command fforce CMD try harder
notest CMD skip testing
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 recent latest CPAN uploads});
}
}
*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::globls ;
sub globls {
my($self,$s,$pragmas) = @_;
# ls is really very different, but we had it once as an ordinary
# command in the Shell (upto rev. 321) and we could not handle
# force well then
my(@accept,@preexpand);
if ($s =~ /[\*\?\/]/) {
if ($CPAN::META->has_inst("Text::Glob")) {
if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
my $rau = Text::Glob::glob_to_regex(uc $au);
CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
if $CPAN::DEBUG;
push @preexpand, map { $_->id . "/" . $pathglob }
CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
} else {
my $rau = Text::Glob::glob_to_regex(uc $s);
push @preexpand, map { $_->id }
CPAN::Shell->expand_by_method('CPAN::Author',
['id'],
"/$rau/");
}
} else {
$CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
}
} else {
push @preexpand, uc $s;
}
for (@preexpand) {
unless (/^[A-Z0-9\-]+(\/|$)/i) {
$CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
next;
}
push @accept, $_;
}
my $silent = @accept>1;
my $last_alpha = "";
my @results;
for my $a (@accept) {
my($author,$pathglob);
if ($a =~ m|(.*?)/(.*)|) {
my $a2 = $1;
$pathglob = $2;
$author = CPAN::Shell->expand_by_method('CPAN::Author',
['id'],
$a2)
or $CPAN::Frontend->mydie("No author found for $a2\n");
} else {
$author = CPAN::Shell->expand_by_method('CPAN::Author',
['id'],
$a)
or $CPAN::Frontend->mydie("No author found for $a\n");
}
if ($silent) {
my $alpha = substr $author->id, 0, 1;
my $ad;
if ($alpha eq $last_alpha) {
$ad = "";
} else {
$ad = "[$alpha]";
$last_alpha = $alpha;
}
$CPAN::Frontend->myprint($ad);
}
for my $pragma (@$pragmas) {
if ($author->can($pragma)) {
$author->$pragma();
}
}
push @results, $author->ls($pathglob,$silent); # silent if
# more than one
# author
for my $pragma (@$pragmas) {
my $unpragma = "un$pragma";
if ($author->can($unpragma)) {
$author->$unpragma();
}
}
}
@results;
}
#-> 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 =~ /^\./;
next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
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) = @_;
@args = '/./' unless @args;
my(@result);
for my $type (qw/Bundle Distribution Module/) {
push @result, $self->expand($type,@args);
}
# Authors are always uppercase.
push @result, $self->expand("Author", map { uc $_ } @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::HandleConfig::edit are closely related. 'o
# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
# probably have been called 'set' and 'o debug' maybe 'set debug' or
# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
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') {
my($cfilter) = $o_what[0] =~ m|^/(.*)/$|;
if (!@o_what or $cfilter) { # print all things, "o conf"
$cfilter ||= "";
my $qrfilter = eval 'qr/$cfilter/';
my($k,$v);
$CPAN::Frontend->myprint("\$CPAN::Config options from ");
my @from;
if (exists $INC{'CPAN/Config.pm'}) {
push @from, $INC{'CPAN/Config.pm'};
}
if (exists $INC{'CPAN/MyConfig.pm'}) {
push @from, $INC{'CPAN/MyConfig.pm'};
}
$CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
$CPAN::Frontend->myprint(":\n");
for $k (sort keys %CPAN::HandleConfig::can) {
next unless $k =~ /$qrfilter/;
$v = $CPAN::HandleConfig::can{$k};
$CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
}
$CPAN::Frontend->myprint("\n");
for $k (sort keys %CPAN::HandleConfig::keys) {
next unless $k =~ /$qrfilter/;
CPAN::HandleConfig->prettyprint($k);
}
$CPAN::Frontend->myprint("\n");
} else {
if (CPAN::HandleConfig->edit(@o_what)) {
} else {
$CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
qq{items\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 ($CPAN::DEBUG):\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
});
}
}
# CPAN::Shell::paintdots_onreload
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(".");
if ($subr =~ /\bshell\b/i) {
# warn "debug[$_[0]]";
# It would be nice if we could detect that a
# subroutine has actually changed, but for now we
# practically always set the GOTOSHELL global
$CPAN::GOTOSHELL=1;
}
return;
}
warn @_;
};
}
#-> sub CPAN::Shell::hosts ;
sub hosts {
my($self) = @_;
my $fullstats = CPAN::FTP->_ftp_statistics();
my $history = $fullstats->{history} || [];
my %S; # statistics
while (my $last = pop @$history) {
my $attempts = $last->{attempts} or next;
my $start;
if (@$attempts) {
$start = $attempts->[-1]{start};
if ($#$attempts > 0) {
for my $i (0..$#$attempts-1) {
my $url = $attempts->[$i]{url} or next;
$S{no}{$url}++;
}
}
} else {
$start = $last->{start};
}
next unless $last->{thesiteurl}; # C-C? bad filenames?
$S{start} = $start;
$S{end} ||= $last->{end};
my $dltime = $last->{end} - $start;
my $dlsize = $last->{filesize} || 0;
my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
my $s = $S{ok}{$url} ||= {};
$s->{n}++;
$s->{dlsize} ||= 0;
$s->{dlsize} += $dlsize/1024;
$s->{dltime} ||= 0;
$s->{dltime} += $dltime;
}
my $res;
for my $url (keys %{$S{ok}}) {
next if $S{ok}{$url}{dltime} == 0; # div by zero
push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
$S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
$url,
];
}
for my $url (keys %{$S{no}}) {
push @{$res->{no}}, [$S{no}{$url},
$url,
];
}
my $R = ""; # report
if ($S{start} && $S{end}) {
$R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
$R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
}
if ($res->{ok} && @{$res->{ok}}) {
$R .= sprintf "\nSuccessful downloads:
N kB secs kB/s url\n";
my $i = 20;
for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
$R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
last if --$i<=0;
}
}
if ($res->{no} && @{$res->{no}}) {
$R .= sprintf "\nUnsuccessful downloads:\n";
my $i = 20;
for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
$R .= sprintf "%4d %s\n", @$_;
last if --$i<=0;
}
}
$CPAN::Frontend->myprint($R);
}
#-> 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) {
my $redef = 0;
chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
my $failed;
my @relo = (
"CPAN.pm",
"CPAN/Debug.pm",
"CPAN/FirstTime.pm",
"CPAN/HandleConfig.pm",
"CPAN/Kwalify.pm",
"CPAN/Queue.pm",
"CPAN/Reporter/Config.pm",
"CPAN/Reporter/History.pm",
"CPAN/Reporter.pm",
"CPAN/SQLite.pm",
"CPAN/Tarzip.pm",
"CPAN/Version.pm",
);
MFILE: for my $f (@relo) {
next unless exists $INC{$f};
my $p = $f;
$p =~ s/\.pm$//;
$p =~ s|/|::|g;
$CPAN::Frontend->myprint("($p");
local($SIG{__WARN__}) = paintdots_onreload(\$redef);
$self->_reload_this($f) or $failed++;
my $v = eval "$p\::->VERSION";
$CPAN::Frontend->myprint("v$v)");
}
$CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
if ($failed) {
my $errors = $failed == 1 ? "error" : "errors";
$CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
"this session.\n");
}
} elsif ($command =~ /^index$/i) {
CPAN::Index->force_reload;
} else {
$CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
index re-reads the index files\n});
}
}
# reload means only load again what we have loaded before
#-> sub CPAN::Shell::_reload_this ;
sub _reload_this {
my($self,$f,$args) = @_;
CPAN->debug("f[$f]") if $CPAN::DEBUG;
return 1 unless $INC{$f}; # we never loaded this, so we do not
# reload but say OK
my $pwd = CPAN::anycwd();
CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
my($file);
for my $inc (@INC) {
$file = File::Spec->catfile($inc,split /\//, $f);
last if -f $file;
$file = "";
}
CPAN->debug("file[$file]") if $CPAN::DEBUG;
my @inc = @INC;
unless ($file && -f $file) {
# this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
$file = $INC{$f};
unless (CPAN->has_inst("File::Basename")) {
@inc = File::Basename::dirname($file);
} else {
# do we ever need this?
@inc = substr($file,0,-length($f)-1); # bring in back to me!
}
}
CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
unless (-f $file) {
$CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
return;
}
my $mtime = (stat $file)[9];
if ($reload->{$f}) {
} elsif ($^T < $mtime) {
# since we started the file has changed, force it to be reloaded
$reload->{$f} = -1;
} else {
$reload->{$f} = $mtime;
}
my $must_reload = $mtime != $reload->{$f};
$args ||= {};
$must_reload ||= $args->{reloforce}; # o conf defaults needs this
if ($must_reload) {
my $fh = FileHandle->new($file) or
$CPAN::Frontend->mydie("Could not open $file: $!");
local($/);
local $^W = 1;
my $content = <$fh>;
CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
if $CPAN::DEBUG;
delete $INC{$f};
local @INC = @inc;
eval "require '$f'";
if ($@) {
warn $@;
return;
}
$reload->{$f} = $mtime;
} else {
$CPAN::Frontend->myprint("__unchanged__");
}
return 1;
}
#-> sub CPAN::Shell::mkmyconfig ;
sub mkmyconfig {
my($self, $cpanpm, %args) = @_;
require CPAN::FirstTime;
my $home = CPAN::HandleConfig::home;
$cpanpm = $INC{'CPAN/MyConfig.pm'} ||
File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
CPAN::HandleConfig::require_myconfig_or_config;
$CPAN::Config ||= {};
$CPAN::Config = {
%$CPAN::Config,
build_dir => undef,
cpan_home => undef,
keep_source_where => undef,
histfile => undef,
};
CPAN::FirstTime::init($cpanpm, %args);
}
#-> 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::scripts ;
sub scripts {
my($self, $arg) = @_;
$CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
unless ($CPAN::META->has_inst($req)) {
$CPAN::Frontend->mywarn(" $req not available\n");
}
}
my $p = HTML::LinkExtor->new();
my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
unless (-f $indexfile) {
$CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
}
$p->parse_file($indexfile);
my @hrefs;
my $qrarg;
if ($arg =~ s|^/(.+)/$|$1|) {
$qrarg = eval 'qr/$arg/'; # hide construct from 5.004
}
for my $l ($p->links) {
my $tag = shift @$l;
next unless $tag eq "a";
my %att = @$l;
my $href = $att{href};
next unless $href =~ s|^\.\./authors/id/./../||;
if ($arg) {
if ($qrarg) {
if ($href =~ $qrarg) {
push @hrefs, $href;
}
} else {
if ($href =~ /\Q$arg\E/) {
push @hrefs, $href;
}
}
} else {
push @hrefs, $href;
}
}
# now filter for the latest version if there is more than one of a name
my %stems;
for (sort @hrefs) {
my $href = $_;
s/-v?\d.*//;
my $stem = $_;
$stems{$stem} ||= [];
push @{$stems{$stem}}, $href;
}
for (sort keys %stems) {
my $highest;
if (@{$stems{$_}} > 1) {
$highest = List::Util::reduce {
Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
} @{$stems{$_}};
} else {
$highest = $stems{$_}[0];
}
$CPAN::Frontend->myprint("$highest\n");
}
}
#-> sub CPAN::Shell::report ;
sub report {
my($self,@args) = @_;
unless ($CPAN::META->has_inst("CPAN::Reporter")) {
$CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
}
local $CPAN::Config->{test_report} = 1;
$self->force("test",@args); # force is there so that the test be
# re-run (as documented)
}
# compare with is_tested
#-> sub CPAN::Shell::install_tested
sub install_tested {
my($self,@some) = @_;
$CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
return if @some;
CPAN::Index->reload;
for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
my $yaml = "$b.yml";
unless (-f $yaml) {
$CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
next;
}
my $yaml_content = CPAN->_yaml_loadfile($yaml);
my $id = $yaml_content->[0]{distribution}{ID};
unless ($id) {
$CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
next;
}
my $do = CPAN::Shell->expandany($id);
unless ($do) {
$CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
next;
}
unless ($do->{build_dir}) {
$CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
next;
}
unless ($do->{build_dir} eq $b) {
$CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
next;
}
push @some, $do;
}
$CPAN::Frontend->mywarn("No tested distributions found.\n"),
return unless @some;
@some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
$CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
return unless @some;
# @some = grep { not $_->uptodate } @some;
# $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
# return unless @some;
CPAN->debug("some[@some]");
for my $d (@some) {
my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
$CPAN::Frontend->myprint("install_tested: Running for $id\n");
$CPAN::Frontend->mysleep(1);
$self->install($d);
}
}
#-> sub CPAN::Shell::upgrade ;
sub upgrade {
my($self,@args) = @_;
$self->install($self->r(@args));
}
#-> 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);
$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);
}
MODULE: for $module (@expand) {
my $file = $module->cpan_file;
next MODULE unless defined $file; # ??
$file =~ s!^./../!!;
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++;
push @version_undefs, $module->as_glimpse;
} elsif (CPAN::Version->vcmp($have,0)==0) {
$version_zeroes++;
push @version_zeroes, $module->as_glimpse;
}
next MODULE unless CPAN::Version->vgt($latest, $have);
# to be pedantic we should probably say:
# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
# to catch the case where CPAN has a version 0 and we have a version undef
} elsif ($what eq "u") {
next MODULE;
}
} else {
if ($what eq "a") {
next MODULE;
} elsif ($what eq "r") {
next MODULE;
} elsif ($what eq "u") {
$have = "-";
}
}
return if $CPAN::Signal; # this is sometimes lengthy
$seen{$file} ||= 0;
if ($what eq "a") {
push @result, sprintf "%s %s\n", $module->id, $have;
} elsif ($what eq "r") {
push @result, $module->id;
next MODULE if $seen{$file}++;
} elsif ($what eq "u") {
push @result, $module->id;
next MODULE if $seen{$file}++;
next MODULE if $file =~ /^Contact/;
}
unless ($headerdone++) {
$CPAN::Frontend->myprint("\n");
$CPAN::Frontend->myprint(sprintf(
$sprintf,
"",
"Package namespace",
"",
"installed",
"latest",
"in CPAN file"
));
}
my $color_on = "";
my $color_off = "";
if (
$COLOR_REGISTERED
&&
$CPAN::META->has_inst("Term::ANSIColor")
&&
$module->description
) {
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
}
$CPAN::Frontend->myprint(sprintf $sprintf,
$color_on,
$module->id,
$color_off,
$have,
$latest,
$file);
$need{$module->id}++;
}
unless (%need) {
if ($what eq "u") {
$CPAN::Frontend->myprint("No modules found for @args\n");
} elsif ($what eq "r") {
$CPAN::Frontend->myprint("All modules are up to date for @args\n");
}
}
if ($what eq "r") {
if ($version_zeroes) {
my $s_has = $version_zeroes > 1 ? "s have" : " has";
$CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
qq{a version number of 0\n});
if ($CPAN::Config->{show_zero_versions}) {
local $" = "\t";
$CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
$CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
qq{to hide them)\n});
} else {
$CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
qq{to show them)\n});
}
}
if ($version_undefs) {
my $s_has = $version_undefs > 1 ? "s have" : " has";
$CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
qq{parseable version number\n});
if ($CPAN::Config->{show_unparsable_versions}) {
local $" = "\t";
$CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
$CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
qq{to hide them)\n});
} else {
$CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
qq{to show them)\n});
}
}
}
@result;
}
#-> sub CPAN::Shell::r ;
sub r {
shift->_u_r_common("r",@_);
}
#-> sub CPAN::Shell::u ;
sub u {
shift->_u_r_common("u",@_);
}
#-> sub CPAN::Shell::failed ;
sub failed {
my($self,$only_id,$silent) = @_;
my @failed;
DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
my $failed = "";
NAY: for my $nosayer ( # order matters!
"unwrapped",
"writemakefile",
"signature_verify",
"make",
"make_test",
"install",
"make_clean",
) {
next unless exists $d->{$nosayer};
next unless defined $d->{$nosayer};
next unless (
UNIVERSAL::can($d->{$nosayer},"failed") ?
$d->{$nosayer}->failed :
$d->{$nosayer} =~ /^NO/
);
next NAY if $only_id && $only_id != (
UNIVERSAL::can($d->{$nosayer},"commandid")
?
$d->{$nosayer}->commandid
:
$CPAN::CurrentCommandId
);
$failed = $nosayer;
last;
}
next DIST unless $failed;
my $id = $d->id;
$id =~ s|^./../||;
#$print .= sprintf(
# " %-45s: %s %s\n",
push @failed,
(
UNIVERSAL::can($d->{$failed},"failed") ?
[
$d->{$failed}->commandid,
$id,
$failed,
$d->{$failed}->text,
$d->{$failed}{TIME}||0,
] :
[
1,
$id,
$failed,
$d->{$failed},
0,
]
);
}
my $scope;
if ($only_id) {
$scope = "this command";
} elsif ($CPAN::Index::HAVE_REANIMATED) {
$scope = "this or a previous session";
# it might be nice to have a section for previous session and
# a second for this
} else {
$scope = "this session";
}
if (@failed) {
my $print;
my $debug = 0;
if ($debug) {
$print = join "",
map { sprintf "%5d %-45s: %s %s\n", @$_ }
sort { $a->[0] <=> $b->[0] } @failed;
} else {
$print = join "",
map { sprintf " %-45s: %s %s\n", @$_[1..3] }
sort {
$a->[0] <=> $b->[0]
||
$a->[4] <=> $b->[4]
} @failed;
}
$CPAN::Frontend->myprint("Failed during $scope:\n$print");
} elsif (!$only_id || !$silent) {
$CPAN::Frontend->myprint("Nothing failed in $scope\n");
}
}
# XXX intentionally undocumented because completely bogus, unportable,
# useless, etc.
#-> sub CPAN::Shell::status ;
sub status {
my($self) = @_;
require Devel::Size;
my $ps = FileHandle->new;
open $ps, "/proc/$$/status";
my $vm = 0;
while (<$ps>) {
next unless /VmSize:\s+(\d+)/;
$vm = $1;
last;
}
$CPAN::Frontend->mywarn(sprintf(
"%-27s %6d\n%-27s %6d\n",
"vm",
$vm,
"CPAN::META",
Devel::Size::total_size($CPAN::META)/1024,
));
for my $k (sort keys %$CPAN::META) {
next unless substr($k,0,4) eq "read";
warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
for my $k2 (sort keys %{$CPAN::META->{$k}}) {
warn sprintf " %-25s %6d (keys: %6d)\n",
$k2,
Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
scalar keys %{$CPAN::META->{$k}{$k2}};
}
}
}
# compare with install_tested
#-> sub CPAN::Shell::is_tested
sub is_tested {
my($self) = @_;
CPAN::Index->reload;
for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
my $time;
if ($CPAN::META->{is_tested}{$b}) {
$time = scalar(localtime $CPAN::META->{is_tested}{$b});
} else {
$time = scalar localtime;
$time =~ s/\S/?/g;
}
$CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
}
}
#-> sub CPAN::Shell::autobundle ;
sub autobundle {
my($self) = shift;
CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
my(@bundle) = $self->_u_r_common("a",@_);
my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
File::Path::mkpath($todir);
unless (-d $todir) {
$CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
return;
}
my($y,$m,$d) = (localtime)[5,4,3];
$y+=1900;
$m++;
my($c) = 0;
my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
my($to) = File::Spec->catfile($todir,"$me.pm");
while (-f $to) {
$me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
$to = File::Spec->catfile($todir,"$me.pm");
}
my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
$fh->print(
"package Bundle::$me;\n\n",
"\$VERSION = '0.01';\n\n",
"1;\n\n",
"__END__\n\n",
"=head1 NAME\n\n",
"Bundle::$me - Snapshot of installation on ",
$Config::Config{'myhostname'},
" on ",
scalar(localtime),
"\n\n=head1 SYNOPSIS\n\n",
"perl -MCPAN -e 'install Bundle::$me'\n\n",
"=head1 CONTENTS\n\n",
join("\n", @bundle),
"\n\n=head1 CONFIGURATION\n\n",
Config->myconfig,
"\n\n=head1 AUTHOR\n\n",
"This Bundle has been generated automatically ",
"by the autobundle routine in CPAN.pm.\n",
);
$fh->close;
$CPAN::Frontend->myprint("\nWrote bundle file
$to\n\n");
}
#-> sub CPAN::Shell::expandany ;
sub expandany {
my($self,$s) = @_;
CPAN->debug("s[$s]") if $CPAN::DEBUG;
if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
$s = CPAN::Distribution->normalize($s);
return $CPAN::META->instance('CPAN::Distribution',$s);
# Distributions spring into existence, not expand
} elsif ($s =~ m|^Bundle::|) {
$self->local_bundles; # scanning so late for bundles seems
# both attractive and crumpy: always
# current state but easy to forget
# somewhere
return $self->expand('Bundle',$s);
} else {
return $self->expand('Module',$s)
if $CPAN::META->exists('CPAN::Module',$s);
}
return;
}
#-> sub CPAN::Shell::expand ;
sub expand {
my $self = shift;
my($type,@args) = @_;
CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
my $class = "CPAN::$type";
my $methods = ['id'];
for my $meth (qw(name)) {
next unless $class->can($meth);
push @$methods, $meth;
}
$self->expand_by_method($class,$methods,@args);
}
#-> sub CPAN::Shell::expand_by_method ;
sub expand_by_method {
my $self = shift;
my($class,$methods,@args) = @_;
my($arg,@m);
for $arg (@args) {
my($regex,$command);
if ($arg =~ m|^/(.*)/$|) {
$regex = $1;
} elsif ($arg =~ m/=/) {
$command = 1;
}
my $obj;
CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
$class,
defined $regex ? $regex : "UNDEFINED",
defined $command ? $command : "UNDEFINED",
) if $CPAN::DEBUG;
if (defined $regex) {
if (CPAN::_sqlite_running) {
$CPAN::SQLite->search($class, $regex);
}
for $obj (
$CPAN::META->all_objects($class)
) {
unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
# BUG, we got an empty object somewhere
require Data::Dumper;
CPAN->debug(sprintf(
"Bug in CPAN: Empty id on obj[%s][%s]",
$obj,
Data::Dumper::Dumper($obj)
)) if $CPAN::DEBUG;
next;
}
for my $method (@$methods) {
my $match = eval {$obj->$method() =~ /$regex/i};
if ($@) {
my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
$err ||= $@; # if we were too restrictive above
$CPAN::Frontend->mydie("$err\n");
} elsif ($match) {
push @m, $obj;
last;
}
}
}
} elsif ($command) {
die "equal sign in command disabled (immature interface), ".
"you can set
! \$CPAN::Shell::ADVANCED_QUERY=1
to enable it. But please note, this is HIGHLY EXPERIMENTAL code
that may go away anytime.\n"
unless $ADVANCED_QUERY;
my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
my($matchcrit) = $criterion =~ m/^~(.+)/;
for my $self (
sort
{$a->id cmp $b->id}
$CPAN::META->all_objects($class)
) {
my $lhs = $self->$method() or next; # () for 5.00503
if ($matchcrit) {
push @m, $self if $lhs =~ m/$matchcrit/;
} else {
push @m, $self if $lhs eq $criterion;
}
}
} else {
my($xarg) = $arg;
if ( $class eq 'CPAN::Bundle' ) {
$xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
} elsif ($class eq "CPAN::Distribution") {
$xarg = CPAN::Distribution->normalize($arg);
} else {
$xarg =~ s/:+/::/g;
}
if ($CPAN::META->exists($class,$xarg)) {
$obj = $CPAN::META->instance($class,$xarg);
} elsif ($CPAN::META->exists($class,$arg)) {
$obj = $CPAN::META->instance($class,$arg);
} else {
next;
}
push @m, $obj;
}
}
@m = sort {$a->id cmp $b->id} @m;
if ( $CPAN::DEBUG ) {
my $wantarray = wantarray;
my $join_m = join ",", map {$_->id} @m;
$self->debug("wantarray[$wantarray]join_m[$join_m]");
}
return wantarray ? @m : $m[0];
}
#-> sub CPAN::Shell::format_result ;
sub format_result {
my($self) = shift;
my($type,@args) = @_;
@args = '/./' unless @args;
my(@result) = $self->expand($type,@args);
my $result = @result == 1 ?
$result[0]->as_string :
@result == 0 ?
"No objects of type $type found for argument @args\n" :
join("",
(map {$_->as_glimpse} @result),
scalar @result, " items found\n",
);
$result;
}
#-> sub CPAN::Shell::report_fh ;
{
my $installation_report_fh;
my $previously_noticed = 0;
sub report_fh {
return $installation_report_fh if $installation_report_fh;
if ($CPAN::META->has_inst("File::Temp")) {
$installation_report_fh
= File::Temp->new(
dir => File::Spec->tmpdir,
template => 'cpan_install_XXXX',
suffix => '.txt',
unlink => 0,
);
}
unless ( $installation_report_fh ) {
warn("Couldn't open installation report file; " .
"no report file will be generated."
) unless $previously_noticed++;
}
}
}
# The only reason for this method is currently to have a reliable
# debugging utility that reveals which output is going through which
# channel. No, I don't like the colors ;-)
# to turn colordebugging on, write
# cpan> o conf colorize_output 1
#-> sub CPAN::Shell::print_ornamented ;
{
my $print_ornamented_have_warned = 0;
sub colorize_output {
my $colorize_output = $CPAN::Config->{colorize_output};
if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
unless ($print_ornamented_have_warned++) {
# no myprint/mywarn within myprint/mywarn!
warn "Colorize_output is set to true but Term::ANSIColor is not
installed. To activate colorized output, please install Term::ANSIColor.\n\n";
}
$colorize_output = 0;
}
return $colorize_output;
}
}
#-> sub CPAN::Shell::print_ornamented ;
sub print_ornamented {
my($self,$what,$ornament) = @_;
return unless defined $what;
local $| = 1; # Flush immediately
if ( $CPAN::Be_Silent ) {
print {report_fh()} $what;
return;
}
my $swhat = "$what"; # stringify if it is an object
if ($CPAN::Config->{term_is_latin}) {
# note: deprecated, need to switch to $LANG and $LC_*
# courtesy jhi:
$swhat
=~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
}
if ($self->colorize_output) {
if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
# if you want to have this configurable, please file a bugreport
$ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
}
my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
if ($@) {
print "Term::ANSIColor rejects color[$ornament]: $@\n
Please choose a different color (Hint: try 'o conf init /color/')\n";
}
# GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
# $trailer construct. We want the newline be the last thing if
# there is a newline at the end ensuring that the next line is
# empty for other players
my $trailer = "";
$trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
print $color_on,
$swhat,
Term::ANSIColor::color("reset"),
$trailer;
} else {
print $swhat;
}
}
#-> sub CPAN::Shell::myprint ;
# where is myprint/mywarn/Frontend/etc. documented? Where to use what?
# I think, we send everything to STDOUT and use print for normal/good
# news and warn for news that need more attention. Yes, this is our
# working contract for now.
sub myprint {
my($self,$what) = @_;
$self->print_ornamented($what,
$CPAN::Config->{colorize_print}||'bold blue on_white',
);
}
sub optprint {
my($self,$category,$what) = @_;
my $vname = $category . "_verbosity";
CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
if (!$CPAN::Config->{$vname}
|| $CPAN::Config->{$vname} =~ /^v/
) {
$CPAN::Frontend->myprint($what);
}
}
#-> sub CPAN::Shell::myexit ;
sub myexit {
my($self,$what) = @_;
$self->myprint($what);
exit;
}
#-> sub CPAN::Shell::mywarn ;
sub mywarn {
my($self,$what) = @_;
$self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
}
# only to be used for shell commands
#-> sub CPAN::Shell::mydie ;
sub mydie {
my($self,$what) = @_;
$self->mywarn($what);
# If it is the shell, we want the following die to be silent,
# but if it is not the shell, we would need a 'die $what'. We need
# to take care that only shell commands use mydie. Is this
# possible?
die "\n";
}
# sub CPAN::Shell::colorable_makemaker_prompt ;
sub colorable_makemaker_prompt {
my($foo,$bar) = @_;
if (CPAN::Shell->colorize_output) {
my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
print $color_on;
}
my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
if (CPAN::Shell->colorize_output) {
print Term::ANSIColor::color('reset');
}
return $ans;
}
# use this only for unrecoverable errors!
#-> sub CPAN::Shell::unrecoverable_error ;
sub unrecoverable_error {
my($self,$what) = @_;
my @lines = split /\n/, $what;
my $longest = 0;
for my $l (@lines) {
$longest = length $l if length $l > $longest;
}
$longest = 62 if $longest > 62;
for my $l (@lines) {
if ($l =~ /^\s*$/) {
$l = "\n";
next;
}
$l = "==> $l";
if (length $l < 66) {
$l = pack "A66 A*", $l, "<==";
}
$l .= "\n";
}
unshift @lines, "\n";
$self->mydie(join "", @lines);
}
#-> sub CPAN::Shell::mysleep ;
sub mysleep {
my($self, $sleep) = @_;
if (CPAN->has_inst("Time::HiRes")) {
Time::HiRes::sleep($sleep);
} else {
sleep($sleep < 1 ? 1 : int($sleep + 0.5));
}
}
#-> sub CPAN::Shell::setup_output ;
sub setup_output {
return if -t STDOUT;
my $odef = select STDERR;
$| = 1;
select STDOUT;
$| = 1;
select $odef;
}
#-> sub CPAN::Shell::rematein ;
# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
sub rematein {
my $self = shift;
my($meth,@some) = @_;
my @pragma;
while($meth =~ /^(ff?orce|notest)$/) {
push @pragma, $meth;
$meth = shift @some or
$CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
"cannot continue");
}
setup_output();
CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
# Here is the place to set "test_count" on all involved parties to
# 0. We then can pass this counter on to the involved
# distributions and those can refuse to test if test_count > X. In
# the first stab at it we could use a 1 for "X".
# But when do I reset the distributions to start with 0 again?
# Jost suggested to have a random or cycling interaction ID that
# we pass through. But the ID is something that is just left lying
# around in addition to the counter, so I'd prefer to set the
# counter to 0 now, and repeat at the end of the loop. But what
# about dependencies? They appear later and are not reset, they
# enter the queue but not its copy. How do they get a sensible
# test_count?
# With configure_requires, "get" is vulnerable in recursion.
my $needs_recursion_protection = "get|make|test|install";
# construct the queue
my($s,@s,@qcopy);
STHING: foreach $s (@some) {
my $obj;
if (ref $s) {
CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
$obj = $s;
} elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
} elsif ($s =~ m|^/|) { # looks like a regexp
if (substr($s,-1,1) eq ".") {
$obj = CPAN::Shell->expandany($s);
} else {
$CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
"not supported.\nRejecting argument '$s'\n");
$CPAN::Frontend->mysleep(2);
next;
}
} elsif ($meth eq "ls") {
$self->globls($s,\@pragma);
next STHING;
} else {
CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
$obj = CPAN::Shell->expandany($s);
}
if (0) {
} elsif (ref $obj) {
if ($meth =~ /^($needs_recursion_protection)$/) {
# it would be silly to check for recursion for look or dump
# (we are in CPAN::Shell::rematein)
CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
eval { $obj->color_cmd_tmps(0,1); };
if ($@) {
if (ref $@
and $@->isa("CPAN::Exception::RecursiveDependency")) {
$CPAN::Frontend->mywarn($@);
} else {
if (0) {
require Carp;
Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
}
die;
}
}
}
CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
push @qcopy, $obj;
} elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
$obj = $CPAN::META->instance('CPAN::Author',uc($s));
if ($meth =~ /^(dump|ls|reports)$/) {
$obj->$meth();
} else {
$CPAN::Frontend->mywarn(
join "",
"Don't be silly, you can't $meth ",
$obj->fullname,
" ;-)\n"
);
$CPAN::Frontend->mysleep(2);
}
} elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
CPAN::InfoObj->dump($s);
} else {
$CPAN::Frontend
->mywarn(qq{Warning: Cannot $meth $s, }.
qq{don't know what it is.
Try the command
i /$s/
to find objects with matching identifiers.
});
$CPAN::Frontend->mysleep(2);
}
}
# queuerunner (please be warned: when I started to change the
# queue to hold objects instead of names, I made one or two
# mistakes and never found which. I reverted back instead)
while (my $q = CPAN::Queue->first) {
my $obj;
my $s = $q->as_string;
my $reqtype = $q->reqtype || "";
$obj = CPAN::Shell->expandany($s);
unless ($obj) {
# don't know how this can happen, maybe we should panic,
# but maybe we get a solution from the first user who hits
# this unfortunate exception?
$CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
"to an object. Skipping.\n");
$CPAN::Frontend->mysleep(5);
CPAN::Queue->delete_first($s);
next;
}
$obj->{reqtype} ||= "";
{
# force debugging because CPAN::SQLite somehow delivers us
# an empty object;
# local $CPAN::DEBUG = 1024; # Shell; probably fixed now
CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
"q-reqtype[$reqtype]") if $CPAN::DEBUG;
}
if ($obj->{reqtype}) {
if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
$obj->{reqtype} = $reqtype;
if (
exists $obj->{install}
&&
(
UNIVERSAL::can($obj->{install},"failed") ?
$obj->{install}->failed :
$obj->{install} =~ /^NO/
)
) {
delete $obj->{install};
$CPAN::Frontend->mywarn
("Promoting $obj->{ID} from 'build_requires' to 'requires'");
}
}
} else {
$obj->{reqtype} = $reqtype;
}
for my $pragma (@pragma) {
if ($pragma
&&
$obj->can($pragma)) {
$obj->$pragma($meth);
}
}
if (UNIVERSAL::can($obj, 'called_for')) {
$obj->called_for($s);
}
CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
push @qcopy, $obj;
if ($meth =~ /^(report)$/) { # they came here with a pragma?
$self->$meth($obj);
} elsif (! UNIVERSAL::can($obj,$meth)) {
# Must never happen
my $serialized = "";
if (0) {
} elsif ($CPAN::META->has_inst("YAML::Syck")) {
$serialized = YAML::Syck::Dump($obj);
} elsif ($CPAN::META->has_inst("YAML")) {
$serialized = YAML::Dump($obj);
} elsif ($CPAN::META->has_inst("Data::Dumper")) {
$serialized = Data::Dumper::Dumper($obj);
} else {
require overload;
$serialized = overload::StrVal($obj);
}
CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
$CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
} elsif ($obj->$meth()) {
CPAN::Queue->delete($s);
CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
} else {
CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
}
$obj->undelay;
for my $pragma (@pragma) {
my $unpragma = "un$pragma";
if ($obj->can($unpragma)) {
$obj->$unpragma();
}
}
CPAN::Queue->delete_first($s);
}
if ($meth =~ /^($needs_recursion_protection)$/) {
for my $obj (@qcopy) {
$obj->color_cmd_tmps(0,0);
}
}
}
#-> sub CPAN::Shell::recent ;
sub recent {
my($self) = @_;
if ($CPAN::META->has_inst("XML::LibXML")) {
my $url = $CPAN::Defaultrecent;
$CPAN::Frontend->myprint("Going to fetch '$url'\n");
unless ($CPAN::META->has_usable("LWP")) {
$CPAN::Frontend->mydie("LWP not installed; cannot continue");
}
CPAN::LWP::UserAgent->config;
my $Ua;
eval { $Ua = CPAN::LWP::UserAgent->new; };
if ($@) {
$CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
}
my $resp = $Ua->get($url);
unless ($resp->is_success) {
$CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
}
$CPAN::Frontend->myprint("DONE\n\n");
my $xml = XML::LibXML->new->parse_string($resp->content);
if (0) {
my $s = $xml->serialize(2);
$s =~ s/\n\s*\n/\n/g;
$CPAN::Frontend->myprint($s);
return;
}
my @distros;
if ($url =~ /winnipeg/) {
my $pubdate = $xml->findvalue("/rss/channel/pubDate");
$CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
for my $eitem ($xml->findnodes("/rss/channel/item")) {
my $distro = $eitem->findvalue("enclosure/\@url");
$distro =~ s|.*?/authors/id/./../||;
my $size = $eitem->findvalue("enclosure/\@length");
my $desc = $eitem->findvalue("description");
|