CPAN
view release on metacpan or search on metacpan
lib/App/Cpan.pm view on Meta::CPAN
%CPAN_METHODS = ( # map switches to method names in CPAN::Shell
$Default => 'install',
'c' => 'clean',
'f' => 'force',
'i' => 'install',
'm' => 'make',
't' => 'test',
'u' => 'upgrade',
'T' => 'notest',
's' => 'shell',
);
@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
@option_order = ( @META_OPTIONS, @CPAN_OPTIONS );
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# map switches to the subroutines in this script, along with other information.
# use this stuff instead of hard-coded indices and values
sub NO_ARGS () { 0 }
sub ARGS () { 1 }
sub GOOD_EXIT () { 0 }
%Method_table = (
# key => [ sub ref, takes args?, exit value, description ]
# options that do their thing first, then exit
h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ],
v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ],
V => [ \&_print_details, NO_ARGS, GOOD_EXIT, 'Printing detailed version' ],
X => [ \&_list_all_namespaces, NO_ARGS, GOOD_EXIT, 'Listing all namespaces' ],
# options that affect other options
j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ],
J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ],
F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ],
I => [ \&_load_local_lib, NO_ARGS, GOOD_EXIT, 'Loading local::lib' ],
M => [ \&_use_these_mirrors, ARGS, GOOD_EXIT, 'Setting per session mirrors' ],
P => [ \&_find_good_mirrors, NO_ARGS, GOOD_EXIT, 'Finding good mirrors' ],
w => [ \&_turn_on_warnings, NO_ARGS, GOOD_EXIT, 'Turning on warnings' ],
# options that do their one thing
g => [ \&_download, ARGS, GOOD_EXIT, 'Download the latest distro' ],
G => [ \&_gitify, ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ],
A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ],
D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ],
O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ],
l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ],
L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ],
a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ],
p => [ \&_ping_mirrors, NO_ARGS, GOOD_EXIT, 'Pinging mirrors' ],
r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ],
u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
's' => [ \&_shell, NO_ARGS, GOOD_EXIT, 'Drop into the CPAN.pm shell' ],
'x' => [ \&_guess_namespace, ARGS, GOOD_EXIT, 'Guessing namespaces' ],
c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ],
f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ],
i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ],
'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ],
t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ],
T => [ \&_default, ARGS, GOOD_EXIT, 'Installing with notest' ],
);
%Method_table_index = (
code => 0,
takes_args => 1,
exit_value => 2,
description => 3,
);
}
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# finally, do some argument processing
sub _stupid_interface_hack_for_non_rtfmers
{
no warnings 'uninitialized';
shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
}
sub _process_options
{
my %options;
push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || '';
# if no arguments, just drop into the shell
if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
elsif (Getopt::Std::getopts(
join( '', @option_order ), \%options ))
{
\%options;
}
else { exit 1 }
}
sub _process_setup_options
{
my( $class, $options ) = @_;
if( $options->{j} )
{
$Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
delete $options->{j};
}
elsif ( ! $options->{h} ) { # h "ignores all of the other options and arguments"
# this is what CPAN.pm would do otherwise
local $CPAN::Be_Silent = 1;
CPAN::HandleConfig->load(
# be_silent => 1, deprecated
write_file => 0,
);
}
lib/App/Cpan.pm view on Meta::CPAN
unless( $log4perl_loaded )
{
print STDOUT "Loading internal logger. Log::Log4perl recommended for better logging\n";
$logger = Local::Null::Logger->new;
return $logger;
}
Log::Log4perl::init( \ <<"HERE" );
log4perl.rootLogger=$LEVEL, A1
log4perl.appender.A1=Log::Log4perl::Appender::Screen
log4perl.appender.A1.layout=PatternLayout
log4perl.appender.A1.layout.ConversionPattern=%m%n
HERE
$logger = Log::Log4perl->get_logger( 'App::Cpan' );
}
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _default
{
my( $args, $options ) = @_;
my $switch = '';
# choose the option that we're going to use
# we'll deal with 'f' (force) later, so skip it
foreach my $option ( @CPAN_OPTIONS )
{
next if ( $option eq 'f' or $option eq 'T' );
next unless $options->{$option};
$switch = $option;
last;
}
# 1. with no switches, but arguments, use the default switch (install)
# 2. with no switches and no args, start the shell
# 3. With a switch but no args, die! These switches need arguments.
if( not $switch and @$args ) { $switch = $Default; }
elsif( not $switch and not @$args ) { return CPAN::shell() }
elsif( $switch and not @$args )
{ die "Nothing to $CPAN_METHODS{$switch}!\n"; }
# Get and check the method from CPAN::Shell
my $method = $CPAN_METHODS{$switch};
die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method );
# call the CPAN::Shell method, with force or notest if specified
my $action = do {
if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } }
elsif( $options->{T} ) { sub { CPAN::Shell->notest( $method, @_ ) } }
else { sub { CPAN::Shell->$method( @_ ) } }
};
# How do I handle exit codes for multiple arguments?
my @errors = ();
$options->{x} or _disable_guessers();
foreach my $arg ( @$args )
{
# check the argument and perhaps capture typos
my $module = _expand_module( $arg ) or do {
$logger->error( "Skipping $arg because I couldn't find a matching namespace." );
next;
};
_clear_cpanpm_output();
$action->( $arg );
my $error = _cpanpm_output_indicates_failure();
push @errors, $error if $error;
}
return do {
if( @errors ) { $errors[0] }
else { HEY_IT_WORKED }
};
}
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
=for comment
CPAN.pm sends all the good stuff either to STDOUT, or to a temp
file if $CPAN::Be_Silent is set. I have to intercept that output
so I can find out what happened.
=cut
BEGIN {
my $scalar = '';
sub _hook_into_CPANpm_report
{
no warnings 'redefine';
*CPAN::Shell::myprint = sub {
my($self,$what) = @_;
$scalar .= $what if defined $what;
$self->print_ornamented($what,
$CPAN::Config->{colorize_print}||'bold blue on_white',
);
};
*CPAN::Shell::mywarn = sub {
my($self,$what) = @_;
$scalar .= $what if defined $what;
$self->print_ornamented($what,
$CPAN::Config->{colorize_warn}||'bold red on_white'
);
};
}
sub _clear_cpanpm_output { $scalar = '' }
lib/App/Cpan.pm view on Meta::CPAN
return $version;
}
sub _eval_version
{
my( $line, $sigil, $var ) = @_;
# split package line to hide from PAUSE
my $eval = qq{
package
ExtUtils::MakeMaker::_version;
local $sigil$var;
\$$var=undef; do {
$line
}; \$$var
};
my $version = do {
local $^W = 0;
no strict;
eval( $eval );
};
return $version;
}
sub _path_to_module
{
my( $inc, $path ) = @_;
return if length $path < length $inc;
my $module_path = substr( $path, length $inc );
$module_path =~ s/\.pm\z//;
# XXX: this is cheating and doesn't handle everything right
my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
shift @dirs;
my $module_name = join "::", @dirs;
return $module_name;
}
sub _expand_module
{
my( $module ) = @_;
my $expanded = CPAN::Shell->expandany( $module );
return $expanded if $expanded;
$expanded = CPAN::Shell->expand( "Module", $module );
unless( defined $expanded ) {
$logger->error( "Could not expand [$module]. Check the module name." );
my $threshold = (
grep { int }
sort { length $a <=> length $b }
length($module)/4, 4
)[0];
my $guesses = _guess_at_module_name( $module, $threshold );
if( defined $guesses and @$guesses ) {
$logger->info( "Perhaps you meant one of these:" );
foreach my $guess ( @$guesses ) {
$logger->info( "\t$guess" );
}
}
return;
}
return $expanded;
}
my $guessers = [
[ qw( Text::Levenshtein::XS distance 7 1 ) ],
[ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 1 ) ],
[ qw( Text::Levenshtein distance 7 1 ) ],
[ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 1 ) ],
];
sub _disable_guessers
{
$_->[-1] = 0 for @$guessers;
}
# for -x
sub _guess_namespace
{
my $args = shift;
foreach my $arg ( @$args )
{
$logger->debug( "Checking $arg" );
my $guesses = _guess_at_module_name( $arg );
foreach my $guess ( @$guesses ) {
print $guess, "\n";
}
}
return HEY_IT_WORKED;
}
sub _list_all_namespaces {
my $modules = _get_all_namespaces();
foreach my $module ( @$modules ) {
print $module, "\n";
}
}
BEGIN {
my $distance;
my $_threshold;
my $can_guess;
my $shown_help = 0;
sub _guess_at_module_name
{
my( $target, $threshold ) = @_;
unless( defined $distance ) {
foreach my $try ( @$guessers ) {
$can_guess = eval "require $try->[0]; 1" or next;
$try->[-1] or next; # disabled
no strict 'refs';
$distance = \&{ join "::", @$try[0,1] };
$threshold ||= $try->[2];
}
}
$_threshold ||= $threshold;
unless( $distance ) {
unless( $shown_help ) {
my $modules = join ", ", map { $_->[0] } @$guessers;
substr $modules, rindex( $modules, ',' ), 1, ', and';
# Should this be colorized?
if( $can_guess ) {
$logger->info( "I can suggest names if you provide the -x option on invocation." );
}
else {
$logger->info( "I can suggest names if you install one of $modules" );
$logger->info( "and you provide the -x option on invocation." );
}
$shown_help++;
}
return;
}
my $modules = _get_all_namespaces();
$logger->info( "Checking " . @$modules . " namespaces for close match suggestions" );
my %guesses;
foreach my $guess ( @$modules ) {
my $distance = $distance->( $target, $guess );
next if $distance > $_threshold;
$guesses{$guess} = $distance;
}
my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses;
return [ grep { defined } @guesses[0..9] ];
}
}
1;
=back
=head1 EXIT VALUES
The script exits with zero if it thinks that everything worked, or a
positive number if it thinks that something failed. Note, however, that
in some cases it has to divine a failure by the output of things it does
not control. For now, the exit codes are vague:
1 An unknown error
2 The was an external problem
4 There was an internal problem with the script
8 A module failed to install
=head1 TO DO
* There is initial support for Log4perl if it is available, but I
haven't gone through everything to make the NullLogger work out
correctly if Log4perl is not installed.
* When I capture CPAN.pm output, I need to check for errors and
report them to the user.
* Warnings switch
* Check then exit
=head1 BUGS
* none noted
=head1 SEE ALSO
L<CPAN>, L<App::cpanminus>
=head1 SOURCE AVAILABILITY
This code is in Github in the CPAN.pm repository:
https://github.com/andk/cpanpm
The source used to be tracked separately in another GitHub repo,
but the canonical source is now in the above repo.
=head1 CREDITS
Japheth Cleaver added the bits to allow a forced install (C<-f>).
Jim Brandt suggested and provided the initial implementation for the
up-to-date and Changes features.
Adam Kennedy pointed out that C<exit()> causes problems on Windows
( run in 0.779 second using v1.01-cache-2.11-cpan-5b529ec07f3 )