diff --git a/lib/App/Cpan.pm b/lib/App/Cpan.pm
index 6358e82a..43d8826e 100644
--- a/lib/App/Cpan.pm
+++ b/lib/App/Cpan.pm
@@ -14,27 +14,27 @@ App::Cpan - easily interact with CPAN from the command line
=head1 SYNOPSIS
- # with arguments and no switches, installs specified modules
- cpan module_name [ module_name ... ]
+ # with arguments and no switches, installs specified modules
+ cpan module_name [ module_name ... ]
- # with switches, installs modules with extra behavior
- cpan [-cfFimtTw] module_name [ module_name ... ]
+ # with switches, installs modules with extra behavior
+ cpan [-cfFimtTw] module_name [ module_name ... ]
- # use local::lib
- cpan -I module_name [ module_name ... ]
+ # use local::lib
+ cpan -I module_name [ module_name ... ]
- # one time mirror override for faster mirrors
- cpan -p ...
+ # one time mirror override for faster mirrors
+ cpan -p ...
- # with just the dot, install from the distribution in the
- # current directory
- cpan .
+ # with just the dot, install from the distribution in the
+ # current directory
+ cpan .
- # without arguments, starts CPAN.pm shell
- cpan
+ # without arguments, starts CPAN.pm shell
+ cpan
- # without arguments, but some switches
- cpan [-ahpruvACDLOPX]
+ # without arguments, but some switches
+ cpan [-ahpruvACDLOPX]
=head1 DESCRIPTION
@@ -75,7 +75,7 @@ Force the specified action, when it normally would have failed. Use this
to install a module even if its tests fail. When you use this option,
-i is not optional for installing a module when you need to force it:
- % cpan -f -i Module::Foo
+ % cpan -f -i Module::Foo
=item -F
@@ -213,29 +213,29 @@ Dump all the namespaces to standard output.
=head2 Examples
- # print a help message
- cpan -h
+ # print a help message
+ cpan -h
- # print the version numbers
- cpan -v
+ # print the version numbers
+ cpan -v
- # create an autobundle
- cpan -a
+ # create an autobundle
+ cpan -a
- # recompile modules
- cpan -r
+ # recompile modules
+ cpan -r
- # upgrade all installed modules
- cpan -u
+ # upgrade all installed modules
+ cpan -u
- # install modules ( sole -i is optional )
- cpan -i Netscape::Booksmarks Business::ISBN
+ # install modules ( sole -i is optional )
+ cpan -i Netscape::Booksmarks Business::ISBN
- # force install modules ( must use -i )
- cpan -fi CGI::Minimal URI
+ # force install modules ( must use -i )
+ cpan -fi CGI::Minimal URI
- # install modules but without testing them
- cpan -Ti CGI::Minimal URI
+ # install modules but without testing them
+ cpan -Ti CGI::Minimal URI
=head2 Environment variables
@@ -314,23 +314,23 @@ use constant A_MODULE_FAILED_TO_INSTALL => 8;
# set up the order of options that we layer over CPAN::Shell
BEGIN { # most of this should be in methods
use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order
- %Method_table %Method_table_index );
+ %Method_table %Method_table_index );
@META_OPTIONS = qw( h v V I g G M: C A D O l L a r p P j: J w x X );
$Default = 'default';
%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',
- );
+ $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 );
@@ -346,54 +346,54 @@ 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' ],
- );
+ # 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,
- );
+ code => 0,
+ takes_args => 1,
+ exit_value => 2,
+ description => 3,
+ );
}
@@ -401,87 +401,87 @@ sub GOOD_EXIT () { 0 }
# 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 )
- }
+ {
+ 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 }
+ {
+ 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,
- );
- }
-
- $class->_turn_off_testing if $options->{T};
-
- foreach my $o ( qw(F I w P M) )
- {
- next unless exists $options->{$o};
- $Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} );
- delete $options->{$o};
- }
-
- if( $options->{o} )
- {
- my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o};
- foreach my $pair ( @pairs )
- {
- my( $setting, $value ) = @$pair;
- $CPAN::Config->{$setting} = $value;
- # $logger->debug( "Setting [$setting] to [$value]" );
- }
- delete $options->{o};
- }
-
- my $option_count = grep { $options->{$_} } @option_order;
- no warnings 'uninitialized';
-
- # don't count options that imply installation
- foreach my $opt ( qw(f T) ) { # don't count force or notest
- $option_count -= $options->{$opt};
- }
-
- # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
- # if there are no options, set -i (this line fixes RT ticket 16915)
- $options->{i}++ unless $option_count;
- }
+ {
+ 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,
+ );
+ }
+
+ $class->_turn_off_testing if $options->{T};
+
+ foreach my $o ( qw(F I w P M) )
+ {
+ next unless exists $options->{$o};
+ $Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} );
+ delete $options->{$o};
+ }
+
+ if( $options->{o} )
+ {
+ my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o};
+ foreach my $pair ( @pairs )
+ {
+ my( $setting, $value ) = @$pair;
+ $CPAN::Config->{$setting} = $value;
+ # $logger->debug( "Setting [$setting] to [$value]" );
+ }
+ delete $options->{o};
+ }
+
+ my $option_count = grep { $options->{$_} } @option_order;
+ no warnings 'uninitialized';
+
+ # don't count options that imply installation
+ foreach my $opt ( qw(f T) ) { # don't count force or notest
+ $option_count -= $options->{$opt};
+ }
+
+ # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # if there are no options, set -i (this line fixes RT ticket 16915)
+ $options->{i}++ unless $option_count;
+ }
sub _setup_environment {
# should we override or set defaults? If this were a true interactive
# session, we'd be in the CPAN shell.
# https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
- $ENV{NONINTERACTIVE_TESTING} = 1 unless defined $ENV{NONINTERACTIVE_TESTING};
- $ENV{PERL_MM_USE_DEFAULT} = 1 unless defined $ENV{PERL_MM_USE_DEFAULT};
- }
+ $ENV{NONINTERACTIVE_TESTING} = 1 unless defined $ENV{NONINTERACTIVE_TESTING};
+ $ENV{PERL_MM_USE_DEFAULT} = 1 unless defined $ENV{PERL_MM_USE_DEFAULT};
+ }
=item run( ARGS )
@@ -495,51 +495,51 @@ failure. See the section on EXIT CODES for details on the values.
my $logger;
sub run
- {
- my( $class, @args ) = @_;
- local @ARGV = @args;
- my $return_value = HEY_IT_WORKED; # assume that things will work
+ {
+ my( $class, @args ) = @_;
+ local @ARGV = @args;
+ my $return_value = HEY_IT_WORKED; # assume that things will work
- $logger = $class->_init_logger;
- $logger->debug( "Using logger from @{[ref $logger]}" );
+ $logger = $class->_init_logger;
+ $logger->debug( "Using logger from @{[ref $logger]}" );
- $class->_hook_into_CPANpm_report;
- $logger->debug( "Hooked into output" );
+ $class->_hook_into_CPANpm_report;
+ $logger->debug( "Hooked into output" );
- $class->_stupid_interface_hack_for_non_rtfmers;
- $logger->debug( "Patched cargo culting" );
+ $class->_stupid_interface_hack_for_non_rtfmers;
+ $logger->debug( "Patched cargo culting" );
- my $options = $class->_process_options;
- $logger->debug( "Options are @{[Dumper($options)]}" );
+ my $options = $class->_process_options;
+ $logger->debug( "Options are @{[Dumper($options)]}" );
- $class->_process_setup_options( $options );
+ $class->_process_setup_options( $options );
- $class->_setup_environment( $options );
+ $class->_setup_environment( $options );
- OPTION: foreach my $option ( @option_order )
- {
- next unless $options->{$option};
+ OPTION: foreach my $option ( @option_order )
+ {
+ next unless $options->{$option};
- my( $sub, $takes_args, $description ) =
- map { $Method_table{$option}[ $Method_table_index{$_} ] }
- qw( code takes_args description );
+ my( $sub, $takes_args, $description ) =
+ map { $Method_table{$option}[ $Method_table_index{$_} ] }
+ qw( code takes_args description );
- unless( ref $sub eq ref sub {} )
- {
- $return_value = THE_PROGRAMMERS_AN_IDIOT;
- last OPTION;
- }
+ unless( ref $sub eq ref sub {} )
+ {
+ $return_value = THE_PROGRAMMERS_AN_IDIOT;
+ last OPTION;
+ }
- $logger->info( "[$option] $description -- ignoring other arguments" )
- if( @ARGV && ! $takes_args );
+ $logger->info( "[$option] $description -- ignoring other arguments" )
+ if( @ARGV && ! $takes_args );
- $return_value = $sub->( \ @ARGV, $options );
+ $return_value = $sub->( \ @ARGV, $options );
- last;
- }
+ last;
+ }
- return $return_value;
- }
+ return $return_value;
+ }
my $LEVEL;
{
@@ -550,16 +550,16 @@ my @LOGLEVELS = qw(TRACE DEBUG INFO WARN ERROR FATAL);
$LEVEL = uc($ENV{CPANSCRIPT_LOGLEVEL} || 'INFO');
my %LL = map { $LOGLEVELS[$_] => $_ } 0..$#LOGLEVELS;
unless (defined $LL{$LEVEL}){
- warn "Unsupported loglevel '$LEVEL', setting to INFO";
- $LEVEL = 'INFO';
+ warn "Unsupported loglevel '$LEVEL', setting to INFO";
+ $LEVEL = 'INFO';
}
sub new { bless \ my $x, $_[0] }
sub AUTOLOAD {
- my $autoload = our $AUTOLOAD;
- $autoload =~ s/.*://;
- return if $LL{uc $autoload} < $LL{$LEVEL};
- $CPAN::Frontend->mywarn(">($autoload): $_\n")
- for split /[\r\n]+/, $_[1];
+ my $autoload = our $AUTOLOAD;
+ $autoload =~ s/.*://;
+ return if $LL{uc $autoload} < $LL{$LEVEL};
+ $CPAN::Frontend->mywarn(">($autoload): $_\n")
+ for split /[\r\n]+/, $_[1];
}
sub DESTROY { 1 }
}
@@ -567,100 +567,100 @@ sub DESTROY { 1 }
# load a module without searching the default entry for the current
# directory
sub _safe_load_module {
- my $name = shift;
+ my $name = shift;
- local @INC = @INC;
- pop @INC if $INC[-1] eq '.';
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
- eval "require $name; 1";
+ eval "require $name; 1";
}
sub _init_logger
- {
- my $log4perl_loaded = _safe_load_module("Log::Log4perl");
+ {
+ my $log4perl_loaded = _safe_load_module("Log::Log4perl");
- unless( $log4perl_loaded )
- {
- print STDOUT "Loading internal logger. Log::Log4perl recommended for better logging\n";
- $logger = Local::Null::Logger->new;
- return $logger;
- }
+ 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" );
+ 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' );
- }
+ $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 }
- };
-
- }
+ {
+ 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 }
+ };
+
+ }
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
@@ -676,26 +676,26 @@ 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'
- );
- };
-
- }
+ {
+ 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 = '' }
@@ -705,203 +705,203 @@ sub _get_cpanpm_output { $scalar }
# filter out the informational noise, I have a better chance to
# catch the error signal
my @skip_lines = (
- qr/^\QWarning \(usually harmless\)/,
- qr/\bwill not store persistent state\b/,
- qr(//hint//),
- qr/^\s+reports\s+/,
- qr/^Try the command/,
- qr/^\s+$/,
- qr/^to find objects/,
- qr/^\s*Database was generated on/,
- qr/^Going to read/,
- qr|^\s+i\s+/|, # the i /Foo::Whatever/ line when it doesn't know
- );
+ qr/^\QWarning \(usually harmless\)/,
+ qr/\bwill not store persistent state\b/,
+ qr(//hint//),
+ qr/^\s+reports\s+/,
+ qr/^Try the command/,
+ qr/^\s+$/,
+ qr/^to find objects/,
+ qr/^\s*Database was generated on/,
+ qr/^Going to read/,
+ qr|^\s+i\s+/|, # the i /Foo::Whatever/ line when it doesn't know
+ );
sub _get_cpanpm_last_line
- {
- my $fh;
-
- if( $] < 5.008 ) {
- $fh = IO::Scalar->new( \ $scalar );
- }
- else {
- eval q{ open $fh, '<', \\ $scalar; };
- }
-
- my @lines = <$fh>;
-
- # This is a bit ugly. Once we examine a line, we have to
- # examine the line before it and go through all of the same
- # regexes. I could do something fancy, but this works.
- REGEXES: {
- foreach my $regex ( @skip_lines )
- {
- if( $lines[-1] =~ m/$regex/ )
- {
- pop @lines;
- redo REGEXES; # we have to go through all of them for every line!
- }
- }
- }
-
- $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
-
- $lines[-1];
- }
+ {
+ my $fh;
+
+ if( $] < 5.008 ) {
+ $fh = IO::Scalar->new( \ $scalar );
+ }
+ else {
+ eval q{ open $fh, '<', \\ $scalar; };
+ }
+
+ my @lines = <$fh>;
+
+ # This is a bit ugly. Once we examine a line, we have to
+ # examine the line before it and go through all of the same
+ # regexes. I could do something fancy, but this works.
+ REGEXES: {
+ foreach my $regex ( @skip_lines )
+ {
+ if( $lines[-1] =~ m/$regex/ )
+ {
+ pop @lines;
+ redo REGEXES; # we have to go through all of them for every line!
+ }
+ }
+ }
+
+ $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
+
+ $lines[-1];
+ }
}
BEGIN {
my $epic_fail_words = join '|',
- qw( Error stop(?:ping)? problems force not unsupported
- fail(?:ed)? Cannot\s+install );
+ qw( Error stop(?:ping)? problems force not unsupported
+ fail(?:ed)? Cannot\s+install );
sub _cpanpm_output_indicates_failure
- {
- my $last_line = _get_cpanpm_last_line();
+ {
+ my $last_line = _get_cpanpm_last_line();
- my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
- return A_MODULE_FAILED_TO_INSTALL if $last_line =~ /\b(?:Cannot\s+install)\b/i;
+ my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
+ return A_MODULE_FAILED_TO_INSTALL if $last_line =~ /\b(?:Cannot\s+install)\b/i;
- $result || ();
- }
+ $result || ();
+ }
}
sub _cpanpm_output_indicates_success
- {
- my $last_line = _get_cpanpm_last_line();
+ {
+ my $last_line = _get_cpanpm_last_line();
- my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
- $result || ();
- }
+ my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
+ $result || ();
+ }
sub _cpanpm_output_is_vague
- {
- return FALSE if
- _cpanpm_output_indicates_failure() ||
- _cpanpm_output_indicates_success();
+ {
+ return FALSE if
+ _cpanpm_output_indicates_failure() ||
+ _cpanpm_output_indicates_success();
- return TRUE;
- }
+ return TRUE;
+ }
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _turn_on_warnings {
- carp "Warnings are implemented yet";
- return HEY_IT_WORKED;
- }
+ carp "Warnings are implemented yet";
+ return HEY_IT_WORKED;
+ }
sub _turn_off_testing {
- $logger->debug( 'Trusting test report history' );
- $CPAN::Config->{trust_test_report_history} = 1;
- return HEY_IT_WORKED;
- }
+ $logger->debug( 'Trusting test report history' );
+ $CPAN::Config->{trust_test_report_history} = 1;
+ return HEY_IT_WORKED;
+ }
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _print_help
- {
- $logger->info( "Use perldoc to read the documentation" );
- my $HAVE_PERLDOC = eval { require Pod::Perldoc; 1; };
- if ($HAVE_PERLDOC) {
- system qq{"$^X" -e "require Pod::Perldoc; Pod::Perldoc->run()" $0};
- exit;
- } else {
- warn "Please install Pod::Perldoc, maybe try 'cpan -i Pod::Perldoc'\n";
- return HEY_IT_WORKED;
- }
- }
+ {
+ $logger->info( "Use perldoc to read the documentation" );
+ my $HAVE_PERLDOC = eval { require Pod::Perldoc; 1; };
+ if ($HAVE_PERLDOC) {
+ system qq{"$^X" -e "require Pod::Perldoc; Pod::Perldoc->run()" $0};
+ exit;
+ } else {
+ warn "Please install Pod::Perldoc, maybe try 'cpan -i Pod::Perldoc'\n";
+ return HEY_IT_WORKED;
+ }
+ }
sub _print_version # -v
- {
- $logger->info(
- "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
+ {
+ $logger->info(
+ "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _print_details # -V
- {
- _print_version();
+ {
+ _print_version();
- _check_install_dirs();
+ _check_install_dirs();
- $logger->info( '-' x 50 . "\nChecking configured mirrors..." );
- foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) {
- _print_ping_report( $mirror );
- }
+ $logger->info( '-' x 50 . "\nChecking configured mirrors..." );
+ foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) {
+ _print_ping_report( $mirror );
+ }
- $logger->info( '-' x 50 . "\nChecking for faster mirrors..." );
+ $logger->info( '-' x 50 . "\nChecking for faster mirrors..." );
- {
- require CPAN::Mirrors;
+ {
+ require CPAN::Mirrors;
- if ( $CPAN::Config->{connect_to_internet_ok} ) {
- $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
- eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) }
- or $CPAN::Frontend->mywarn(<<'HERE');
+ if ( $CPAN::Config->{connect_to_internet_ok} ) {
+ $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
+ eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) }
+ or $CPAN::Frontend->mywarn(<<'HERE');
We failed to get a copy of the mirror list from the Internet.
You will need to provide CPAN mirror URLs yourself.
HERE
- $CPAN::Frontend->myprint("\n");
- }
+ $CPAN::Frontend->myprint("\n");
+ }
- my $mirrors = CPAN::Mirrors->new( _mirror_file() );
- my @continents = $mirrors->find_best_continents;
+ my $mirrors = CPAN::Mirrors->new( _mirror_file() );
+ my @continents = $mirrors->find_best_continents;
- my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] );
- my @timings = $mirrors->get_mirrors_timings( \@mirrors );
+ my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] );
+ my @timings = $mirrors->get_mirrors_timings( \@mirrors );
- foreach my $timing ( @timings ) {
- $logger->info( sprintf "%s (%0.2f ms)",
- $timing->hostname, $timing->rtt );
- }
- }
+ foreach my $timing ( @timings ) {
+ $logger->info( sprintf "%s (%0.2f ms)",
+ $timing->hostname, $timing->rtt );
+ }
+ }
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _check_install_dirs
- {
- my $makepl_arg = $CPAN::Config->{makepl_arg};
- my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg};
-
- my @custom_dirs;
- # PERL_MM_OPT
- push @custom_dirs,
- $makepl_arg =~ m/INSTALL_BASE\s*=\s*(\S+)/g,
- $mbuildpl_arg =~ m/--install_base\s*=\s*(\S+)/g;
-
- if( @custom_dirs ) {
- foreach my $dir ( @custom_dirs ) {
- _print_inc_dir_report( $dir );
- }
- }
-
- # XXX: also need to check makepl_args, etc
-
- my @checks = (
- [ 'core', [ grep $_, @Config{qw(installprivlib installarchlib)} ] ],
- [ 'vendor', [ grep $_, @Config{qw(installvendorlib installvendorarch)} ] ],
- [ 'site', [ grep $_, @Config{qw(installsitelib installsitearch)} ] ],
- [ 'PERL5LIB', _split_paths( $ENV{PERL5LIB} ) ],
- [ 'PERLLIB', _split_paths( $ENV{PERLLIB} ) ],
- );
-
- $logger->info( '-' x 50 . "\nChecking install dirs..." );
- foreach my $tuple ( @checks ) {
- my( $label ) = $tuple->[0];
-
- $logger->info( "Checking $label" );
- $logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] };
- foreach my $dir ( @{ $tuple->[1] } ) {
- _print_inc_dir_report( $dir );
- }
- }
-
- }
+ {
+ my $makepl_arg = $CPAN::Config->{makepl_arg};
+ my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg};
+
+ my @custom_dirs;
+ # PERL_MM_OPT
+ push @custom_dirs,
+ $makepl_arg =~ m/INSTALL_BASE\s*=\s*(\S+)/g,
+ $mbuildpl_arg =~ m/--install_base\s*=\s*(\S+)/g;
+
+ if( @custom_dirs ) {
+ foreach my $dir ( @custom_dirs ) {
+ _print_inc_dir_report( $dir );
+ }
+ }
+
+ # XXX: also need to check makepl_args, etc
+
+ my @checks = (
+ [ 'core', [ grep $_, @Config{qw(installprivlib installarchlib)} ] ],
+ [ 'vendor', [ grep $_, @Config{qw(installvendorlib installvendorarch)} ] ],
+ [ 'site', [ grep $_, @Config{qw(installsitelib installsitearch)} ] ],
+ [ 'PERL5LIB', _split_paths( $ENV{PERL5LIB} ) ],
+ [ 'PERLLIB', _split_paths( $ENV{PERLLIB} ) ],
+ );
+
+ $logger->info( '-' x 50 . "\nChecking install dirs..." );
+ foreach my $tuple ( @checks ) {
+ my( $label ) = $tuple->[0];
+
+ $logger->info( "Checking $label" );
+ $logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] };
+ foreach my $dir ( @{ $tuple->[1] } ) {
+ _print_inc_dir_report( $dir );
+ }
+ }
+
+ }
sub _split_paths
- {
- [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
- }
+ {
+ [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
+ }
=pod
@@ -911,676 +911,676 @@ Stolen from File::Path::Expand
=cut
sub _expand_filename
- {
- my( $path ) = @_;
- no warnings 'uninitialized';
- $logger->debug( "Expanding path $path\n" );
- $path =~ s{\A~([^/]+)?}{
- _home_of( $1 || $> ) || "~$1"
- }e;
- return $path;
- }
+ {
+ my( $path ) = @_;
+ no warnings 'uninitialized';
+ $logger->debug( "Expanding path $path\n" );
+ $path =~ s{\A~([^/]+)?}{
+ _home_of( $1 || $> ) || "~$1"
+ }e;
+ return $path;
+ }
sub _home_of
- {
- require User::pwent;
- my( $user ) = @_;
- my $ent = User::pwent::getpw($user) or return;
- return $ent->dir;
- }
+ {
+ require User::pwent;
+ my( $user ) = @_;
+ my $ent = User::pwent::getpw($user) or return;
+ return $ent->dir;
+ }
sub _get_default_inc
- {
- require Config;
+ {
+ require Config;
- [ @Config::Config{ _vars() }, '.' ];
- }
+ [ @Config::Config{ _vars() }, '.' ];
+ }
sub _vars {
- qw(
- installarchlib
- installprivlib
- installsitearch
- installsitelib
- );
- }
+ qw(
+ installarchlib
+ installprivlib
+ installsitearch
+ installsitelib
+ );
+ }
sub _ping_mirrors {
- my $urls = $CPAN::Config->{urllist};
- require URI;
+ my $urls = $CPAN::Config->{urllist};
+ require URI;
- foreach my $url ( @$urls ) {
- my( $obj ) = URI->new( $url );
- next unless _is_pingable_scheme( $obj );
- my $host = $obj->host;
- _print_ping_report( $obj );
- }
+ foreach my $url ( @$urls ) {
+ my( $obj ) = URI->new( $url );
+ next unless _is_pingable_scheme( $obj );
+ my $host = $obj->host;
+ _print_ping_report( $obj );
+ }
- }
+ }
sub _is_pingable_scheme {
- my( $uri ) = @_;
+ my( $uri ) = @_;
- $uri->scheme eq 'file'
- }
+ $uri->scheme eq 'file'
+ }
sub _mirror_file {
- my $file = do {
- my $file = 'MIRRORED.BY';
- my $local_path = File::Spec->catfile(
- $CPAN::Config->{keep_source_where}, $file );
-
- if( -e $local_path ) { $local_path }
- else {
- require CPAN::FTP;
- CPAN::FTP->localize( $file, $local_path, 3, 1 );
- $local_path;
- }
- };
- }
+ my $file = do {
+ my $file = 'MIRRORED.BY';
+ my $local_path = File::Spec->catfile(
+ $CPAN::Config->{keep_source_where}, $file );
+
+ if( -e $local_path ) { $local_path }
+ else {
+ require CPAN::FTP;
+ CPAN::FTP->localize( $file, $local_path, 3, 1 );
+ $local_path;
+ }
+ };
+ }
sub _find_good_mirrors {
- require CPAN::Mirrors;
+ require CPAN::Mirrors;
- my $mirrors = CPAN::Mirrors->new( _mirror_file() );
+ my $mirrors = CPAN::Mirrors->new( _mirror_file() );
- my @mirrors = $mirrors->best_mirrors(
- how_many => 5,
- verbose => 1,
- );
+ my @mirrors = $mirrors->best_mirrors(
+ how_many => 5,
+ verbose => 1,
+ );
- foreach my $mirror ( @mirrors ) {
- next unless eval { $mirror->can( 'http' ) };
- _print_ping_report( $mirror->http );
- }
+ foreach my $mirror ( @mirrors ) {
+ next unless eval { $mirror->can( 'http' ) };
+ _print_ping_report( $mirror->http );
+ }
- $CPAN::Config->{urllist} = [
- map { $_->http } @mirrors
- ];
- }
+ $CPAN::Config->{urllist} = [
+ map { $_->http } @mirrors
+ ];
+ }
sub _print_inc_dir_report
- {
- my( $dir ) = shift;
+ {
+ my( $dir ) = shift;
- my $writeable = -w $dir ? '+' : '!!! (not writeable)';
- $logger->info( "\t$writeable $dir" );
- return -w $dir;
- }
+ my $writeable = -w $dir ? '+' : '!!! (not writeable)';
+ $logger->info( "\t$writeable $dir" );
+ return -w $dir;
+ }
sub _print_ping_report
- {
- my( $mirror ) = @_;
+ {
+ my( $mirror ) = @_;
- my $rtt = eval { _get_ping_report( $mirror ) };
- my $result = $rtt ? sprintf "+ (%4d ms)", $rtt * 1000 : '!';
+ my $rtt = eval { _get_ping_report( $mirror ) };
+ my $result = $rtt ? sprintf "+ (%4d ms)", $rtt * 1000 : '!';
- $logger->info(
- sprintf "\t%s %s", $result, $mirror
- );
- }
+ $logger->info(
+ sprintf "\t%s %s", $result, $mirror
+ );
+ }
sub _get_ping_report
- {
- require URI;
- my( $mirror ) = @_;
- my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX
- require Net::Ping;
+ {
+ require URI;
+ my( $mirror ) = @_;
+ my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX
+ require Net::Ping;
- my $ping = Net::Ping->new( 'tcp', 1 );
+ my $ping = Net::Ping->new( 'tcp', 1 );
- if( $url->scheme eq 'file' ) {
- return -e $url->file;
- }
+ if( $url->scheme eq 'file' ) {
+ return -e $url->file;
+ }
- my( $port ) = $url->port;
+ my( $port ) = $url->port;
- return unless $port;
+ return unless $port;
- if ( $ping->can('port_number') ) {
- $ping->port_number($port);
- }
- else {
- $ping->{'port_num'} = $port;
- }
+ if ( $ping->can('port_number') ) {
+ $ping->port_number($port);
+ }
+ else {
+ $ping->{'port_num'} = $port;
+ }
- $ping->hires(1) if $ping->can( 'hires' );
- my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) };
- $alive ? $rtt : undef;
- }
+ $ping->hires(1) if $ping->can( 'hires' );
+ my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) };
+ $alive ? $rtt : undef;
+ }
sub _load_local_lib # -I
- {
- $logger->debug( "Loading local::lib" );
+ {
+ $logger->debug( "Loading local::lib" );
- my $rc = _safe_load_module("local::lib");
- unless( $rc ) {
- $logger->logdie( "Could not load local::lib" );
- }
+ my $rc = _safe_load_module("local::lib");
+ unless( $rc ) {
+ $logger->logdie( "Could not load local::lib" );
+ }
- local::lib->import;
+ local::lib->import;
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _use_these_mirrors # -M
- {
- $logger->debug( "Setting per session mirrors" );
- unless( $_[0] ) {
- $logger->logdie( "The -M switch requires a comma-separated list of mirrors" );
- }
+ {
+ $logger->debug( "Setting per session mirrors" );
+ unless( $_[0] ) {
+ $logger->logdie( "The -M switch requires a comma-separated list of mirrors" );
+ }
- $CPAN::Config->{urllist} = [ split /,/, $_[0] ];
+ $CPAN::Config->{urllist} = [ split /,/, $_[0] ];
- $logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" );
+ $logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" );
- }
+ }
sub _create_autobundle
- {
- $logger->info(
- "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
+ {
+ $logger->info(
+ "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
- CPAN::Shell->autobundle;
+ CPAN::Shell->autobundle;
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _recompile
- {
- $logger->info( "Recompiling dynamically-loaded extensions" );
+ {
+ $logger->info( "Recompiling dynamically-loaded extensions" );
- CPAN::Shell->recompile;
+ CPAN::Shell->recompile;
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _upgrade
- {
- $logger->info( "Upgrading all modules" );
+ {
+ $logger->info( "Upgrading all modules" );
- CPAN::Shell->upgrade();
+ CPAN::Shell->upgrade();
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _shell
- {
- $logger->info( "Dropping into shell" );
+ {
+ $logger->info( "Dropping into shell" );
- CPAN::shell();
+ CPAN::shell();
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _load_config # -j
- {
- my $argument = shift;
+ {
+ my $argument = shift;
- my $file = file_name_is_absolute( $argument ) ? $argument : rel2abs( $argument );
- croak( "cpan config file [$file] for -j does not exist!\n" ) unless -e $file;
+ my $file = file_name_is_absolute( $argument ) ? $argument : rel2abs( $argument );
+ croak( "cpan config file [$file] for -j does not exist!\n" ) unless -e $file;
- # should I clear out any existing config here?
- $CPAN::Config = {};
- delete $INC{'CPAN/Config.pm'};
+ # should I clear out any existing config here?
+ $CPAN::Config = {};
+ delete $INC{'CPAN/Config.pm'};
- my $rc = eval "require '$file'";
+ my $rc = eval "require '$file'";
- # CPAN::HandleConfig::require_myconfig_or_config looks for this
- $INC{'CPAN/MyConfig.pm'} = 'fake out!';
+ # CPAN::HandleConfig::require_myconfig_or_config looks for this
+ $INC{'CPAN/MyConfig.pm'} = 'fake out!';
- # CPAN::HandleConfig::load looks for this
- $CPAN::Config_loaded = 'fake out';
+ # CPAN::HandleConfig::load looks for this
+ $CPAN::Config_loaded = 'fake out';
- croak( "Could not load [$file]: $@\n") unless $rc;
+ croak( "Could not load [$file]: $@\n") unless $rc;
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _dump_config # -J
- {
- my $args = shift;
- require Data::Dumper;
+ {
+ my $args = shift;
+ require Data::Dumper;
- my $fh = $args->[0] || \*STDOUT;
+ my $fh = $args->[0] || \*STDOUT;
- local $Data::Dumper::Sortkeys = 1;
- my $dd = Data::Dumper->new(
- [$CPAN::Config],
- ['$CPAN::Config']
- );
+ local $Data::Dumper::Sortkeys = 1;
+ my $dd = Data::Dumper->new(
+ [$CPAN::Config],
+ ['$CPAN::Config']
+ );
- print $fh $dd->Dump, "\n1;\n__END__\n";
+ print $fh $dd->Dump, "\n1;\n__END__\n";
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _lock_lobotomy # -F
- {
- no warnings 'redefine';
+ {
+ no warnings 'redefine';
- *CPAN::_flock = sub { 1 };
- *CPAN::checklock = sub { 1 };
+ *CPAN::_flock = sub { 1 };
+ *CPAN::checklock = sub { 1 };
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _download
- {
- my $args = shift;
+ {
+ my $args = shift;
- local $CPAN::DEBUG = 1;
+ local $CPAN::DEBUG = 1;
- my %paths;
+ my %paths;
- foreach my $arg ( @$args ) {
- $logger->info( "Checking $arg" );
+ foreach my $arg ( @$args ) {
+ $logger->info( "Checking $arg" );
- my $module = _expand_module( $arg ) or next;
- my $path = $module->cpan_file;
+ my $module = _expand_module( $arg ) or next;
+ my $path = $module->cpan_file;
- $logger->debug( "Inst file would be $path\n" );
+ $logger->debug( "Inst file would be $path\n" );
- $paths{$module} = _get_file( _make_path( $path ) );
+ $paths{$module} = _get_file( _make_path( $path ) );
- $logger->info( "Downloaded [$arg] to [$paths{$arg}]" );
- }
+ $logger->info( "Downloaded [$arg] to [$paths{$arg}]" );
+ }
- return \%paths;
- }
+ return \%paths;
+ }
sub _make_path { join "/", qw(authors id), $_[0] }
sub _get_file
- {
- my $path = shift;
+ {
+ my $path = shift;
- my $loaded = _safe_load_module("LWP::Simple");
- croak "You need LWP::Simple to use features that fetch files from CPAN\n"
- unless $loaded;
+ my $loaded = _safe_load_module("LWP::Simple");
+ croak "You need LWP::Simple to use features that fetch files from CPAN\n"
+ unless $loaded;
- my $file = substr $path, rindex( $path, '/' ) + 1;
- my $store_path = catfile( cwd(), $file );
- $logger->debug( "Store path is $store_path" );
+ my $file = substr $path, rindex( $path, '/' ) + 1;
+ my $store_path = catfile( cwd(), $file );
+ $logger->debug( "Store path is $store_path" );
- foreach my $site ( @{ $CPAN::Config->{urllist} } )
- {
- my $fetch_path = join "/", $site, $path;
- $logger->debug( "Trying $fetch_path" );
- my $status_code = LWP::Simple::getstore( $fetch_path, $store_path );
- last if( 200 <= $status_code and $status_code <= 300 );
- $logger->warn( "Could not get [$fetch_path]: Status code $status_code" );
- }
+ foreach my $site ( @{ $CPAN::Config->{urllist} } )
+ {
+ my $fetch_path = join "/", $site, $path;
+ $logger->debug( "Trying $fetch_path" );
+ my $status_code = LWP::Simple::getstore( $fetch_path, $store_path );
+ last if( 200 <= $status_code and $status_code <= 300 );
+ $logger->warn( "Could not get [$fetch_path]: Status code $status_code" );
+ }
- return $store_path;
- }
+ return $store_path;
+ }
sub _gitify
- {
- my $args = shift;
+ {
+ my $args = shift;
- my $loaded = _safe_load_module("Archive::Extract");
- croak "You need Archive::Extract to use features that gitify distributions\n"
- unless $loaded;
+ my $loaded = _safe_load_module("Archive::Extract");
+ croak "You need Archive::Extract to use features that gitify distributions\n"
+ unless $loaded;
- my $starting_dir = cwd();
+ my $starting_dir = cwd();
- foreach my $arg ( @$args )
- {
- $logger->info( "Checking $arg" );
- my $store_paths = _download( [ $arg ] );
- $logger->debug( "gitify Store path is $store_paths->{$arg}" );
- my $dirname = dirname( $store_paths->{$arg} );
+ foreach my $arg ( @$args )
+ {
+ $logger->info( "Checking $arg" );
+ my $store_paths = _download( [ $arg ] );
+ $logger->debug( "gitify Store path is $store_paths->{$arg}" );
+ my $dirname = dirname( $store_paths->{$arg} );
- my $ae = Archive::Extract->new( archive => $store_paths->{$arg} );
- $ae->extract( to => $dirname );
+ my $ae = Archive::Extract->new( archive => $store_paths->{$arg} );
+ $ae->extract( to => $dirname );
- chdir $ae->extract_path;
+ chdir $ae->extract_path;
- my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
- croak "Could not find $git" unless -e $git;
- croak "$git is not executable" unless -x $git;
+ my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
+ croak "Could not find $git" unless -e $git;
+ croak "$git is not executable" unless -x $git;
- # can we do this in Pure Perl?
- system( $git, 'init' );
- system( $git, qw( add . ) );
- system( $git, qw( commit -a -m ), 'initial import' );
- }
+ # can we do this in Pure Perl?
+ system( $git, 'init' );
+ system( $git, qw( add . ) );
+ system( $git, qw( commit -a -m ), 'initial import' );
+ }
- chdir $starting_dir;
+ chdir $starting_dir;
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _show_Changes
- {
- my $args = shift;
+ {
+ my $args = shift;
- foreach my $arg ( @$args )
- {
- $logger->info( "Checking $arg\n" );
+ foreach my $arg ( @$args )
+ {
+ $logger->info( "Checking $arg\n" );
- my $module = _expand_module( $arg ) or next;
+ my $module = _expand_module( $arg ) or next;
- my $out = _get_cpanpm_output();
+ my $out = _get_cpanpm_output();
- next unless eval { $module->inst_file };
- #next if $module->uptodate;
+ next unless eval { $module->inst_file };
+ #next if $module->uptodate;
- ( my $id = $module->id() ) =~ s/::/\-/;
+ ( my $id = $module->id() ) =~ s/::/\-/;
- my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
- $id . "-" . $module->cpan_version() . "/";
+ my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
+ $id . "-" . $module->cpan_version() . "/";
- #print "URL: $url\n";
- _get_changes_file($url);
- }
+ #print "URL: $url\n";
+ _get_changes_file($url);
+ }
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _get_changes_file
- {
- croak "Reading Changes files requires LWP::Simple and URI\n"
- unless _safe_load_module("LWP::Simple") && _safe_load_module("URI");
+ {
+ croak "Reading Changes files requires LWP::Simple and URI\n"
+ unless _safe_load_module("LWP::Simple") && _safe_load_module("URI");
- my $url = shift;
+ my $url = shift;
- my $content = LWP::Simple::get( $url );
- $logger->info( "Got $url ..." ) if defined $content;
- #print $content;
+ my $content = LWP::Simple::get( $url );
+ $logger->info( "Got $url ..." ) if defined $content;
+ #print $content;
- my( $change_link ) = $content =~ m|Changes|gi;
+ my( $change_link ) = $content =~ m|Changes|gi;
- my $changes_url = URI->new_abs( $change_link, $url );
- $logger->debug( "Change link is: $changes_url" );
+ my $changes_url = URI->new_abs( $change_link, $url );
+ $logger->debug( "Change link is: $changes_url" );
- my $changes = LWP::Simple::get( $changes_url );
+ my $changes = LWP::Simple::get( $changes_url );
- print $changes;
+ print $changes;
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _show_Author
- {
- my $args = shift;
+ {
+ my $args = shift;
- foreach my $arg ( @$args )
- {
- my $module = _expand_module( $arg ) or next;
+ foreach my $arg ( @$args )
+ {
+ my $module = _expand_module( $arg ) or next;
- unless( $module )
- {
- $logger->info( "Didn't find a $arg module, so no author!" );
- next;
- }
+ unless( $module )
+ {
+ $logger->info( "Didn't find a $arg module, so no author!" );
+ next;
+ }
- my $author = CPAN::Shell->expand( "Author", $module->userid );
+ my $author = CPAN::Shell->expand( "Author", $module->userid );
- next unless $module->userid;
+ next unless $module->userid;
- printf "%-25s %-8s %-25s %s\n",
- $arg, $module->userid, $author->email, $author->name;
- }
+ printf "%-25s %-8s %-25s %s\n",
+ $arg, $module->userid, $author->email, $author->name;
+ }
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _show_Details
- {
- my $args = shift;
+ {
+ my $args = shift;
- foreach my $arg ( @$args )
- {
- my $module = _expand_module( $arg ) or next;
- my $author = CPAN::Shell->expand( "Author", $module->userid );
+ foreach my $arg ( @$args )
+ {
+ my $module = _expand_module( $arg ) or next;
+ my $author = CPAN::Shell->expand( "Author", $module->userid );
- next unless $module->userid;
+ next unless $module->userid;
- print "$arg\n", "-" x 73, "\n\t";
- print join "\n\t",
- $module->description ? $module->description : "(no description)",
- $module->cpan_file ? $module->cpan_file : "(no cpanfile)",
- $module->inst_file ? $module->inst_file :"(no installation file)" ,
- 'Installed: ' . ($module->inst_version ? $module->inst_version : "not installed"),
- 'CPAN: ' . $module->cpan_version . ' ' .
- ($module->uptodate ? "" : "Not ") . "up to date",
- $author->fullname . " (" . $module->userid . ")",
- $author->email;
- print "\n\n";
+ print "$arg\n", "-" x 73, "\n\t";
+ print join "\n\t",
+ $module->description ? $module->description : "(no description)",
+ $module->cpan_file ? $module->cpan_file : "(no cpanfile)",
+ $module->inst_file ? $module->inst_file :"(no installation file)" ,
+ 'Installed: ' . ($module->inst_version ? $module->inst_version : "not installed"),
+ 'CPAN: ' . $module->cpan_version . ' ' .
+ ($module->uptodate ? "" : "Not ") . "up to date",
+ $author->fullname . " (" . $module->userid . ")",
+ $author->email;
+ print "\n\n";
- }
+ }
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
BEGIN {
my $modules;
sub _get_all_namespaces
- {
- return $modules if $modules;
- $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
- }
+ {
+ return $modules if $modules;
+ $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
+ }
}
sub _show_out_of_date
- {
- my $modules = _get_all_namespaces();
-
- printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
- print "-" x 73, "\n";
-
- foreach my $module ( @$modules )
- {
- next unless $module = _expand_module($module);
- next unless $module->inst_file;
- next if $module->uptodate;
- printf "%-40s %.4f %.4f\n",
- $module->id,
- $module->inst_version ? $module->inst_version : '',
- $module->cpan_version;
- }
-
- return HEY_IT_WORKED;
- }
+ {
+ my $modules = _get_all_namespaces();
+
+ printf "%-50s %8s %8s\n", "Module Name", "Local", "CPAN";
+ print "-" x 73, "\n";
+
+ foreach my $module ( @$modules )
+ {
+ next unless $module = _expand_module($module);
+ next unless $module->inst_file;
+ next if $module->uptodate;
+ printf "%-50s %-8s %-8s\n",
+ $module->id,
+ defined $module->inst_version ? $module->inst_version : 'undef',
+ $module->cpan_version;
+ }
+
+ return HEY_IT_WORKED;
+ }
sub _show_author_mods
- {
- my $args = shift;
+ {
+ my $args = shift;
- my %hash = map { lc $_, 1 } @$args;
+ my %hash = map { lc $_, 1 } @$args;
- my $modules = _get_all_namespaces();
+ my $modules = _get_all_namespaces();
- foreach my $module ( @$modules ) {
- next unless exists $hash{ lc $module->userid };
- print $module->id, "\n";
- }
+ foreach my $module ( @$modules ) {
+ next unless exists $hash{ lc $module->userid };
+ print $module->id, "\n";
+ }
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _list_all_mods # -l
- {
- require File::Find;
+ {
+ require File::Find;
- my $args = shift;
+ my $args = shift;
- my $fh = \*STDOUT;
+ my $fh = \*STDOUT;
- INC: foreach my $inc ( @INC )
- {
- my( $wanted, $reporter ) = _generator();
- File::Find::find( { wanted => $wanted }, $inc );
+ INC: foreach my $inc ( @INC )
+ {
+ my( $wanted, $reporter ) = _generator();
+ File::Find::find( { wanted => $wanted }, $inc );
- my $count = 0;
- FILE: foreach my $file ( @{ $reporter->() } )
- {
- my $version = _parse_version_safely( $file );
+ my $count = 0;
+ FILE: foreach my $file ( @{ $reporter->() } )
+ {
+ my $version = _parse_version_safely( $file );
- my $module_name = _path_to_module( $inc, $file );
- next FILE unless defined $module_name;
+ my $module_name = _path_to_module( $inc, $file );
+ next FILE unless defined $module_name;
- print $fh "$module_name\t$version\n";
+ print $fh "$module_name\t$version\n";
- #last if $count++ > 5;
- }
- }
+ #last if $count++ > 5;
+ }
+ }
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _generator
- {
- my @files = ();
+ {
+ my @files = ();
- sub { push @files,
- File::Spec->canonpath( $File::Find::name )
- if m/\A\w+\.pm\z/ },
- sub { \@files },
- }
+ sub { push @files,
+ File::Spec->canonpath( $File::Find::name )
+ if m/\A\w+\.pm\z/ },
+ sub { \@files },
+ }
sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
- {
- my( $file ) = @_;
+ {
+ my( $file ) = @_;
- local $/ = "\n";
- local $_; # don't mess with the $_ in the map calling this
+ local $/ = "\n";
+ local $_; # don't mess with the $_ in the map calling this
- return unless open FILE, "<$file";
+ return unless open FILE, "<$file";
- my $in_pod = 0;
- my $version;
- while( )
- {
- chomp;
- $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
- next if $in_pod || /^\s*#/;
+ my $in_pod = 0;
+ my $version;
+ while( )
+ {
+ chomp;
+ $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
+ next if $in_pod || /^\s*#/;
- next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
- my( $sigil, $var ) = ( $1, $2 );
+ next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
+ my( $sigil, $var ) = ( $1, $2 );
- $version = _eval_version( $_, $sigil, $var );
- last;
- }
- close FILE;
+ $version = _eval_version( $_, $sigil, $var );
+ last;
+ }
+ close FILE;
- return 'undef' unless defined $version;
+ return 'undef' unless defined $version;
- return $version;
- }
+ return $version;
+ }
sub _eval_version
- {
- my( $line, $sigil, $var ) = @_;
+ {
+ my( $line, $sigil, $var ) = @_;
# split package line to hide from PAUSE
- my $eval = qq{
- package
- ExtUtils::MakeMaker::_version;
+ my $eval = qq{
+ package
+ ExtUtils::MakeMaker::_version;
- local $sigil$var;
- \$$var=undef; do {
- $line
- }; \$$var
- };
+ local $sigil$var;
+ \$$var=undef; do {
+ $line
+ }; \$$var
+ };
- my $version = do {
- local $^W = 0;
- no strict;
- eval( $eval );
- };
+ my $version = do {
+ local $^W = 0;
+ no strict;
+ eval( $eval );
+ };
- return $version;
- }
+ return $version;
+ }
sub _path_to_module
- {
- my( $inc, $path ) = @_;
- return if length $path < length $inc;
+ {
+ my( $inc, $path ) = @_;
+ return if length $path < length $inc;
- my $module_path = substr( $path, length $inc );
- $module_path =~ s/\.pm\z//;
+ 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;
+ # 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;
+ my $module_name = join "::", @dirs;
- return $module_name;
- }
+ 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( $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::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 ) ],
+ [ qw( Text::Levenshtein distance 7 1 ) ],
+ [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 1 ) ],
- ];
+ ];
sub _disable_guessers
- {
- $_->[-1] = 0 for @$guessers;
- }
+ {
+ $_->[-1] = 0 for @$guessers;
+ }
# for -x
sub _guess_namespace
- {
- my $args = shift;
+ {
+ my $args = shift;
- foreach my $arg ( @$args )
- {
- $logger->debug( "Checking $arg" );
- my $guesses = _guess_at_module_name( $arg );
+ foreach my $arg ( @$args )
+ {
+ $logger->debug( "Checking $arg" );
+ my $guesses = _guess_at_module_name( $arg );
- foreach my $guess ( @$guesses ) {
- print $guess, "\n";
- }
- }
+ foreach my $guess ( @$guesses ) {
+ print $guess, "\n";
+ }
+ }
- return HEY_IT_WORKED;
- }
+ return HEY_IT_WORKED;
+ }
sub _list_all_namespaces {
- my $modules = _get_all_namespaces();
+ my $modules = _get_all_namespaces();
- foreach my $module ( @$modules ) {
- print $module, "\n";
- }
- }
+ foreach my $module ( @$modules ) {
+ print $module, "\n";
+ }
+ }
BEGIN {
my $distance;
@@ -1588,52 +1588,52 @@ 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] ];
- }
+ {
+ 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;
@@ -1647,13 +1647,13 @@ 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
+ 1 An unknown error
- 2 The was an external problem
+ 2 The was an external problem
- 4 There was an internal problem with the script
+ 4 There was an internal problem with the script
- 8 A module failed to install
+ 8 A module failed to install
=head1 TO DO
@@ -1680,7 +1680,7 @@ L, L
This code is in Github in the CPAN.pm repository:
- https://github.com/andk/cpanpm
+ 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.