2073 lines
72 KiB
Perl
2073 lines
72 KiB
Perl
package CPAN::Shell;
|
|
use strict;
|
|
|
|
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
|
# vim: ts=4 sts=4 sw=4:
|
|
|
|
use vars qw(
|
|
$ADVANCED_QUERY
|
|
$AUTOLOAD
|
|
$COLOR_REGISTERED
|
|
$Help
|
|
$autoload_recursion
|
|
$reload
|
|
@ISA
|
|
@relo
|
|
$VERSION
|
|
);
|
|
@relo = (
|
|
"CPAN.pm",
|
|
"CPAN/Author.pm",
|
|
"CPAN/CacheMgr.pm",
|
|
"CPAN/Complete.pm",
|
|
"CPAN/Debug.pm",
|
|
"CPAN/DeferredCode.pm",
|
|
"CPAN/Distribution.pm",
|
|
"CPAN/Distroprefs.pm",
|
|
"CPAN/Distrostatus.pm",
|
|
"CPAN/Exception/RecursiveDependency.pm",
|
|
"CPAN/Exception/yaml_not_installed.pm",
|
|
"CPAN/FirstTime.pm",
|
|
"CPAN/FTP.pm",
|
|
"CPAN/FTP/netrc.pm",
|
|
"CPAN/HandleConfig.pm",
|
|
"CPAN/Index.pm",
|
|
"CPAN/InfoObj.pm",
|
|
"CPAN/Kwalify.pm",
|
|
"CPAN/LWP/UserAgent.pm",
|
|
"CPAN/Module.pm",
|
|
"CPAN/Prompt.pm",
|
|
"CPAN/Queue.pm",
|
|
"CPAN/Reporter/Config.pm",
|
|
"CPAN/Reporter/History.pm",
|
|
"CPAN/Reporter/PrereqCheck.pm",
|
|
"CPAN/Reporter.pm",
|
|
"CPAN/Shell.pm",
|
|
"CPAN/SQLite.pm",
|
|
"CPAN/Tarzip.pm",
|
|
"CPAN/Version.pm",
|
|
);
|
|
$VERSION = "5.5009";
|
|
# record the initial timestamp for reload.
|
|
$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
|
|
@CPAN::Shell::ISA = qw(CPAN::Debug);
|
|
use Cwd qw(chdir);
|
|
use Carp ();
|
|
$COLOR_REGISTERED ||= 0;
|
|
$Help = {
|
|
'?' => \"help",
|
|
'!' => "eval the rest of the line as perl",
|
|
a => "whois author",
|
|
autobundle => "write 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",
|
|
get => "download a distribution",
|
|
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 matching a fileglob",
|
|
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 upgradable modules",
|
|
readme => "display the README of a distro with 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 { ## no critic
|
|
$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--;
|
|
}
|
|
}
|
|
|
|
|
|
#-> 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 installed modules
|
|
r WORDs or /REGEXP/ or NONE report updates for some/matching/all
|
|
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 (up to 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();
|
|
}
|
|
}
|
|
CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG;
|
|
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;
|
|
my @m = @_;
|
|
for (@m) {
|
|
if (m|(?:\w+/)*\w+\.pm$|) { # same regexp in expandany
|
|
s/.pm$//;
|
|
s|/|::|g;
|
|
}
|
|
}
|
|
$CPAN::Frontend->myprint($self->format_result('Module',@m));
|
|
}
|
|
|
|
#-> 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);
|
|
($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
|
|
if (!@o_what or $cfilter) { # print all things, "o conf"
|
|
$cfilter ||= "";
|
|
my $qrfilter = eval 'qr/$cfilter/';
|
|
if ($@) {
|
|
$CPAN::Frontend->mydie("Cannot parse commandline: $@");
|
|
}
|
|
my($k,$v);
|
|
my $configpm = CPAN::HandleConfig->require_myconfig_or_config;
|
|
$CPAN::Frontend->myprint("\$CPAN::Config options from $configpm\:\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 (sort 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 (sort 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);
|
|
}
|
|
|
|
# here is where 'reload cpan' is done
|
|
#-> 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;
|
|
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 thingy 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];
|
|
$reload->{$f} ||= -1;
|
|
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: $!");
|
|
my $content;
|
|
{
|
|
local($/);
|
|
local $^W = 1;
|
|
$content = <$fh>;
|
|
}
|
|
CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
|
|
if $CPAN::DEBUG;
|
|
my $includefile;
|
|
if ($includefile = $INC{$f} and -e $includefile) {
|
|
$f = $includefile;
|
|
}
|
|
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) = @_;
|
|
if ( my $configpm = $INC{'CPAN/MyConfig.pm'} ) {
|
|
$CPAN::Frontend->myprint(
|
|
"CPAN::MyConfig already exists as $configpm.\n" .
|
|
"Running configuration again...\n"
|
|
);
|
|
require CPAN::FirstTime;
|
|
CPAN::FirstTime::init($configpm);
|
|
}
|
|
else {
|
|
# force some missing values to be filled in with defaults
|
|
delete $CPAN::Config->{$_}
|
|
for qw/build_dir cpan_home keep_source_where histfile/;
|
|
CPAN::HandleConfig->load( make_myconfig => 1 );
|
|
}
|
|
}
|
|
|
|
#-> 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 _guess_manpage {
|
|
my($self,$d,$contains,$dist) = @_;
|
|
$dist =~ s/-/::/g;
|
|
my $module;
|
|
if (exists $contains->{$dist}) {
|
|
$module = $dist;
|
|
} elsif (1 == keys %$contains) {
|
|
($module) = keys %$contains;
|
|
}
|
|
my $manpage;
|
|
if ($module) {
|
|
my $m = $self->expand("Module",$module);
|
|
$m->as_string; # called for side-effects, shame
|
|
$manpage = $m->{MANPAGE};
|
|
} else {
|
|
$manpage = "unknown";
|
|
}
|
|
return $manpage;
|
|
}
|
|
|
|
#-> sub CPAN::Shell::_specfile ;
|
|
sub _specfile {
|
|
die "CPAN::Shell::_specfile() has been moved to CPAN::Plugin::Specfile::post_test()";
|
|
}
|
|
|
|
#-> 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);
|
|
if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
|
|
# for metadata cache
|
|
my $expand = scalar @expand;
|
|
$CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
|
|
}
|
|
my @sexpand;
|
|
if ($] < 5.008) {
|
|
# hard to believe that the more complex sorting can lead to
|
|
# stack curruptions on older perl
|
|
@sexpand = sort {$a->id cmp $b->id} @expand;
|
|
} else {
|
|
@sexpand = map {
|
|
$_->[1]
|
|
} sort {
|
|
$b->[0] <=> $a->[0]
|
|
||
|
|
$a->[1]{ID} cmp $b->[1]{ID},
|
|
} map {
|
|
[$_->_is_representative_module,
|
|
$_
|
|
]
|
|
} @expand;
|
|
}
|
|
if ($CPAN::DEBUG) {
|
|
$CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
|
|
sleep 1;
|
|
}
|
|
MODULE: for $module (@sexpand) {
|
|
my $file = $module->cpan_file;
|
|
next MODULE unless defined $file; # ??
|
|
$file =~ s!^./../!!;
|
|
my($latest) = $module->cpan_version;
|
|
my($inst_file) = $module->inst_file;
|
|
CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
|
|
my($have);
|
|
return if $CPAN::Signal;
|
|
my($next_MODULE);
|
|
eval { # version.pm involved!
|
|
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 = "-";
|
|
}
|
|
}
|
|
};
|
|
next MODULE if $next_MODULE;
|
|
if ($@) {
|
|
$CPAN::Frontend->mywarn
|
|
(sprintf("Error while comparing cpan/installed versions of '%s':
|
|
INST_FILE: %s
|
|
INST_VERSION: %s %s
|
|
CPAN_VERSION: %s %s
|
|
",
|
|
$module->id,
|
|
$inst_file || "",
|
|
(defined $have ? $have : "[UNDEFINED]"),
|
|
(ref $have ? ref $have : ""),
|
|
$latest,
|
|
(ref $latest ? ref $latest : ""),
|
|
));
|
|
next MODULE;
|
|
}
|
|
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 (!@expand || $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{parsable 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 = $self->find_failed($only_id);
|
|
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");
|
|
}
|
|
}
|
|
|
|
sub find_failed {
|
|
my($self,$only_id) = @_;
|
|
my @failed;
|
|
DIST: for my $d (sort { $a->id cmp $b->id } $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|^./../||;
|
|
### XXX need to flag optional modules as '(optional)' if they are
|
|
# from recommends/suggests -- i.e. *show* failure, but make it clear
|
|
# it was failure of optional module -- xdg, 2012-04-01
|
|
$id = "(optional) $id" if ! $d->{mandatory};
|
|
#$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,
|
|
!! $d->{mandatory},
|
|
] :
|
|
[
|
|
1,
|
|
$id,
|
|
$failed,
|
|
$d->{$failed},
|
|
0,
|
|
!! $d->{mandatory},
|
|
]
|
|
);
|
|
}
|
|
return @failed;
|
|
}
|
|
|
|
sub mandatory_dist_failed {
|
|
my ($self) = @_;
|
|
return grep { $_->[5] } $self->find_failed($CPAN::CurrentCommandID);
|
|
}
|
|
|
|
# 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", # hide from perl-reversion
|
|
"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");
|
|
return $to;
|
|
}
|
|
|
|
#-> sub CPAN::Shell::expandany ;
|
|
sub expandany {
|
|
my($self,$s) = @_;
|
|
CPAN->debug("s[$s]") if $CPAN::DEBUG;
|
|
my $module_as_path = "";
|
|
if ($s =~ m|(?:\w+/)*\w+\.pm$|) { # same regexp in sub m
|
|
$module_as_path = $s;
|
|
$module_as_path =~ s/.pm$//;
|
|
$module_as_path =~ s|/|::|g;
|
|
}
|
|
if ($module_as_path) {
|
|
if ($module_as_path =~ m|^Bundle::|) {
|
|
$self->local_bundles;
|
|
return $self->expand('Bundle',$module_as_path);
|
|
} else {
|
|
return $self->expand('Module',$module_as_path)
|
|
if $CPAN::META->exists('CPAN::Module',$module_as_path);
|
|
}
|
|
} elsif ($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;
|
|
# FIXME: there seem to be some ='s in the author data, which trigger
|
|
# a failure here. This needs to be contemplated.
|
|
# } 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::Index->reload;
|
|
$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]");
|
|
my $count = scalar @m;
|
|
$self->debug("class[$class]wantarray[$wantarray]count m[$count]");
|
|
}
|
|
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_usable("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::colorize_output ;
|
|
{
|
|
my $print_ornamented_have_warned = 0;
|
|
sub colorize_output {
|
|
my $colorize_output = $CPAN::Config->{colorize_output};
|
|
if ($colorize_output && $^O eq 'MSWin32' && !$CPAN::META->has_inst("Win32::Console::ANSI")) {
|
|
unless ($print_ornamented_have_warned++) {
|
|
# no myprint/mywarn within myprint/mywarn!
|
|
warn "Colorize_output is set to true but Win32::Console::ANSI is not
|
|
installed. To activate colorized output, please install Win32::Console::ANSI.\n\n";
|
|
}
|
|
$colorize_output = 0;
|
|
}
|
|
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 ) {
|
|
# WARNING: variable Be_Silent is poisoned and must be eliminated.
|
|
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 bug report
|
|
$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 without 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',
|
|
);
|
|
}
|
|
|
|
my %already_printed;
|
|
#-> sub CPAN::Shell::mywarnonce ;
|
|
sub myprintonce {
|
|
my($self,$what) = @_;
|
|
$self->myprint($what) unless $already_printed{$what}++;
|
|
}
|
|
|
|
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');
|
|
}
|
|
|
|
my %already_warned;
|
|
#-> sub CPAN::Shell::mywarnonce ;
|
|
sub mywarnonce {
|
|
my($self,$what) = @_;
|
|
$self->mywarn($what) unless $already_warned{$what}++;
|
|
}
|
|
|
|
# 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,$ornament) = @_;
|
|
$ornament ||= "colorize_print";
|
|
if (CPAN::Shell->colorize_output) {
|
|
my $ornament = $CPAN::Config->{$ornament}||'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 {
|
|
return if $ENV{AUTOMATED_TESTING} || ! -t STDOUT;
|
|
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;
|
|
# this variable was global and disturbed programmers, so localize:
|
|
local $CPAN::Distrostatus::something_has_failed_at;
|
|
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 {
|
|
my @obj;
|
|
CLASS: for my $class (qw(Distribution Bundle Module)) {
|
|
if (@obj = $self->expand($class,$s)) {
|
|
last CLASS;
|
|
}
|
|
}
|
|
if (@obj) {
|
|
if (1==@obj) {
|
|
$obj = $obj[0];
|
|
} else {
|
|
$CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
|
|
"only supported when unambiguous.\nRejecting argument '$s'\n");
|
|
$CPAN::Frontend->mysleep(2);
|
|
next STHING;
|
|
}
|
|
}
|
|
}
|
|
} 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("Testing 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", optional => '');
|
|
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)
|
|
QITEM: while (my $q = CPAN::Queue->first) {
|
|
my $obj;
|
|
my $s = $q->as_string;
|
|
my $reqtype = $q->reqtype || "";
|
|
my $optional = $q->optional || "";
|
|
$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 QITEM;
|
|
}
|
|
$obj->{reqtype} ||= "";
|
|
my $type = ref $obj;
|
|
if ( $type eq 'CPAN::Distribution' || $type eq 'CPAN::Bundle' ) {
|
|
$obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
|
|
}
|
|
elsif ( $type eq 'CPAN::Module' ) {
|
|
$obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
|
|
if (my $d = $obj->distribution) {
|
|
$d->{mandatory} ||= ! $optional; # once mandatory, always mandatory
|
|
} elsif ($optional) {
|
|
# the queue object does not know who was recommending/suggesting us:(
|
|
# So we only vaguely write "optional".
|
|
$CPAN::Frontend->mywarn("Warning: optional module '$s' ".
|
|
"not known. Skipping.\n");
|
|
CPAN::Queue->delete_first($s);
|
|
next QITEM;
|
|
}
|
|
}
|
|
{
|
|
# 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) unless $obj->called_for;
|
|
}
|
|
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]");
|
|
} else {
|
|
my $upgraded_meth = $meth;
|
|
if ( $meth eq "make" and $obj->{reqtype} eq "b" ) {
|
|
# rt 86915
|
|
$upgraded_meth = "test";
|
|
}
|
|
if ($obj->$upgraded_meth()) {
|
|
CPAN::Queue->delete($s);
|
|
CPAN->debug("Succeeded and deleted from queue. pragma[@pragma]meth[$meth][s][$s]") if $CPAN::DEBUG;
|
|
} else {
|
|
CPAN->debug("Failed. pragma[@pragma]meth[$meth]s[$s]") if $CPAN::DEBUG;
|
|
}
|
|
}
|
|
|
|
$obj->undelay;
|
|
for my $pragma (@pragma) {
|
|
my $unpragma = "un$pragma";
|
|
if ($obj->can($unpragma)) {
|
|
$obj->$unpragma();
|
|
}
|
|
}
|
|
# if any failures occurred and the current object is mandatory, we
|
|
# still don't know if *it* failed or if it was another (optional)
|
|
# module, so we have to check that explicitly (and expensively)
|
|
if ( $CPAN::Config->{halt_on_failure}
|
|
&& $obj->{mandatory}
|
|
&& CPAN::Distrostatus::something_has_just_failed()
|
|
&& $self->mandatory_dist_failed()
|
|
) {
|
|
$CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
|
|
CPAN::Queue->nullify_queue;
|
|
last QITEM;
|
|
}
|
|
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("Fetching '$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");
|
|
$desc =~ s/.+? - //;
|
|
$CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
|
|
push @distros, $distro;
|
|
}
|
|
} elsif ($url =~ /search.*uploads.rdf/) {
|
|
# xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
|
|
# xmlns="http://purl.org/rss/1.0/"
|
|
# xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
|
|
# xmlns:dc="http://purl.org/dc/elements/1.1/"
|
|
# xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
|
|
# xmlns:admin="http://webns.net/mvcb/"
|
|
|
|
|
|
my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
|
|
$CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
|
|
my $finish_eitem = 0;
|
|
local $SIG{INT} = sub { $finish_eitem = 1 };
|
|
EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
|
|
my $distro = $eitem->findvalue("\@rdf:about");
|
|
$distro =~ s|.*~||; # remove up to the tilde before the name
|
|
$distro =~ s|/$||; # remove trailing slash
|
|
$distro =~ s|([^/]+)|\U$1\E|; # upcase the name
|
|
my $author = uc $1 or die "distro[$distro] without author, cannot continue";
|
|
my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
|
|
my $i = 0;
|
|
SUBDIRTEST: while () {
|
|
last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
|
|
if (my @ret = $self->globls("$distro*")) {
|
|
@ret = grep {$_->[2] !~ /meta/} @ret;
|
|
@ret = grep {length $_->[2]} @ret;
|
|
if (@ret) {
|
|
$distro = "$author/$ret[0][2]";
|
|
last SUBDIRTEST;
|
|
}
|
|
}
|
|
$distro =~ s|/|/*/|; # allow it to reside in a subdirectory
|
|
}
|
|
|
|
next EITEM if $distro =~ m|\*|; # did not find the thing
|
|
$CPAN::Frontend->myprint("____$desc\n");
|
|
push @distros, $distro;
|
|
last EITEM if $finish_eitem;
|
|
}
|
|
}
|
|
return \@distros;
|
|
} else {
|
|
# deprecated old version
|
|
$CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
|
|
}
|
|
}
|
|
|
|
#-> sub CPAN::Shell::smoke ;
|
|
sub smoke {
|
|
my($self) = @_;
|
|
my $distros = $self->recent;
|
|
DISTRO: for my $distro (@$distros) {
|
|
next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
|
|
$CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
|
|
{
|
|
my $skip = 0;
|
|
local $SIG{INT} = sub { $skip = 1 };
|
|
for (0..9) {
|
|
$CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
|
|
sleep 1;
|
|
if ($skip) {
|
|
$CPAN::Frontend->myprint(" skipped\n");
|
|
next DISTRO;
|
|
}
|
|
}
|
|
}
|
|
$CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
|
|
$self->test($distro);
|
|
}
|
|
}
|
|
|
|
{
|
|
# set up the dispatching methods
|
|
no strict "refs";
|
|
for my $command (qw(
|
|
clean
|
|
cvs_import
|
|
dump
|
|
force
|
|
fforce
|
|
get
|
|
install
|
|
look
|
|
ls
|
|
make
|
|
notest
|
|
perldoc
|
|
readme
|
|
reports
|
|
test
|
|
)) {
|
|
*$command = sub { shift->rematein($command, @_); };
|
|
}
|
|
}
|
|
|
|
1;
|