summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/App/Cpan.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/App/Cpan.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/App/Cpan.pm241
1 files changed, 195 insertions, 46 deletions
diff --git a/Master/tlpkg/tlperl/lib/App/Cpan.pm b/Master/tlpkg/tlperl/lib/App/Cpan.pm
index 94607d9b0f2..3ddcbe8ac55 100644
--- a/Master/tlpkg/tlperl/lib/App/Cpan.pm
+++ b/Master/tlpkg/tlperl/lib/App/Cpan.pm
@@ -6,7 +6,7 @@ use vars qw($VERSION);
use if $] < 5.008 => 'IO::Scalar';
-$VERSION = '1.63_01';
+$VERSION = '1.66';
=head1 NAME
@@ -34,7 +34,7 @@ App::Cpan - easily interact with CPAN from the command line
cpan
# without arguments, but some switches
- cpan [-ahpruvACDLOP]
+ cpan [-ahpruvACDLOPX]
=head1 DESCRIPTION
@@ -104,7 +104,7 @@ distribution.
Print a help message and exit. When you specify C<-h>, it ignores all
of the other options and arguments.
-=item -i
+=item -i module [ module ... ]
Install the specified modules. With no other switches, this switch
is implied.
@@ -164,7 +164,12 @@ session.
Recompiles dynamically loaded modules with CPAN::Shell->recompile.
-=item -t
+=item -s
+
+Drop in the CPAN.pm shell. This command does this automatically if you don't
+specify any arguments.
+
+=item -t module [ module ... ]
Run a `make test` on the specified modules.
@@ -192,6 +197,16 @@ UNIMPLEMENTED
Turn on cpan warnings. This checks various things, like directory permissions,
and tells you about problems you might have.
+=item -x module [ module ... ]
+
+Find close matches to the named modules that you think you might have
+mistyped. This requires the optional installation of Text::Levenshtein or
+Text::Levenshtein::Damerau.
+
+=item -X
+
+Dump all the namespaces to standard output.
+
=back
=head2 Examples
@@ -299,7 +314,7 @@ 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 );
-@META_OPTIONS = qw( h v V I g G M: C A D O l L a r p P j: J w T);
+@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';
@@ -312,6 +327,7 @@ $Default = 'default';
't' => 'test',
'u' => 'upgrade',
'T' => 'notest',
+ 's' => 'shell',
);
@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
@@ -332,6 +348,7 @@ sub GOOD_EXIT () { 0 }
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' ],
@@ -343,8 +360,8 @@ sub GOOD_EXIT () { 0 }
w => [ \&_turn_on_warnings, NO_ARGS, GOOD_EXIT, 'Turning on warnings' ],
# options that do their one thing
- g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ],
- G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
+ 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' ],
@@ -358,7 +375,9 @@ sub GOOD_EXIT () { 0 }
r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ],
u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
+ 's' => [ \&_shell, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
+ '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`' ],
@@ -510,7 +529,7 @@ sub run
last OPTION;
}
- $logger->info( "$description -- ignoring other arguments" )
+ $logger->info( "[$option] $description -- ignoring other arguments" )
if( @ARGV && ! $takes_args );
$return_value = $sub->( \ @ARGV, $options );
@@ -533,12 +552,12 @@ 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
@@ -547,7 +566,7 @@ sub _init_logger
unless( $log4perl_loaded )
{
- print "Loading internal null logger. Install Log::Log4perl for logging messages\n";
+ print STDERR "Loading internal null logger. Install Log::Log4perl for logging messages\n";
$logger = Local::Null::Logger->new;
return $logger;
}
@@ -608,6 +627,12 @@ sub _default
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 );
@@ -796,8 +821,7 @@ HERE
$CPAN::Frontend->myprint("\n");
}
- my $mirrors = CPAN::Mirrors->new( );
- $mirrors->parse_mirrored_by( File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY') );
+ my $mirrors = CPAN::Mirrors->new( _mirror_file() );
my @continents = $mirrors->find_best_continents;
my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] );
@@ -918,9 +942,7 @@ sub _is_pingable_scheme {
$uri->scheme eq 'file'
}
-sub _find_good_mirrors {
- require CPAN::Mirrors;
-
+sub _mirror_file {
my $file = do {
my $file = 'MIRRORED.BY';
my $local_path = File::Spec->catfile(
@@ -933,7 +955,12 @@ sub _find_good_mirrors {
$local_path;
}
};
- my $mirrors = CPAN::Mirrors->new( $file );
+ }
+
+sub _find_good_mirrors {
+ require CPAN::Mirrors;
+
+ my $mirrors = CPAN::Mirrors->new( _mirror_file() );
my @mirrors = $mirrors->best_mirrors(
how_many => 5,
@@ -1006,7 +1033,7 @@ sub _load_local_lib # -I
my $rc = _safe_load_module("local::lib");
unless( $rc ) {
- $logger->die( "Could not load local::lib" );
+ $logger->logdie( "Could not load local::lib" );
}
local::lib->import;
@@ -1018,7 +1045,7 @@ sub _use_these_mirrors # -M
{
$logger->debug( "Setting per session mirrors" );
unless( $_[0] ) {
- $logger->die( "The -M switch requires a comma-separated list of mirrors" );
+ $logger->logdie( "The -M switch requires a comma-separated list of mirrors" );
}
$CPAN::Config->{urllist} = [ split /,/, $_[0] ];
@@ -1055,6 +1082,15 @@ sub _upgrade
return HEY_IT_WORKED;
}
+sub _shell
+ {
+ $logger->info( "Dropping into shell" );
+
+ CPAN::shell();
+
+ return HEY_IT_WORKED;
+ }
+
sub _load_config # -j
{
my $file = shift || '';
@@ -1113,14 +1149,17 @@ sub _download
my %paths;
- foreach my $module ( @$args )
- {
- $logger->info( "Checking $module" );
- my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
+ foreach my $arg ( @$args ) {
+ $logger->info( "Checking $arg" );
+
+ my $module = _expand_module( $arg ) or next;
+ my $path = $module->cpan_file;
$logger->debug( "Inst file would be $path\n" );
- $paths{$module} = _get_file( _make_path( $path ) );
+ $paths{$arg} = _get_file( _make_path( $path ) );
+
+ $logger->info( "Downloaded [$arg] to [$paths{$module}]" );
}
return \%paths;
@@ -1160,16 +1199,14 @@ sub _gitify
my $starting_dir = cwd();
- foreach my $module ( @$args )
+ foreach my $arg ( @$args )
{
- $logger->info( "Checking $module" );
- my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
-
- my $store_paths = _download( [ $module ] );
- $logger->debug( "gitify Store path is $store_paths->{$module}" );
- my $dirname = dirname( $store_paths->{$module} );
+ $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->{$module} );
+ my $ae = Archive::Extract->new( archive => $store_paths->{$arg} );
$ae->extract( to => $dirname );
chdir $ae->extract_path;
@@ -1197,7 +1234,8 @@ sub _show_Changes
{
$logger->info( "Checking $arg\n" );
- my $module = eval { CPAN::Shell->expand( "Module", $arg ) };
+ my $module = _expand_module( $arg ) or next;
+
my $out = _get_cpanpm_output();
next unless eval { $module->inst_file };
@@ -1244,7 +1282,8 @@ sub _show_Author
foreach my $arg ( @$args )
{
- my $module = CPAN::Shell->expand( "Module", $arg );
+ my $module = _expand_module( $arg ) or next;
+
unless( $module )
{
$logger->info( "Didn't find a $arg module, so no author!" );
@@ -1268,7 +1307,7 @@ sub _show_Details
foreach my $arg ( @$args )
{
- my $module = CPAN::Shell->expand( "Module", $arg );
+ my $module = _expand_module( $arg ) or next;
my $author = CPAN::Shell->expand( "Author", $module->userid );
next unless $module->userid;
@@ -1290,16 +1329,26 @@ sub _show_Details
return HEY_IT_WORKED;
}
+BEGIN {
+my $modules;
+sub _get_all_namespaces
+ {
+ return $modules if $modules;
+ $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
+ }
+}
+
sub _show_out_of_date
{
- my @modules = CPAN::Shell->expand( "Module", "/./" );
+ my $modules = _get_all_namespaces();
printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
print "-" x 73, "\n";
- foreach my $module ( @modules )
+ foreach my $module ( @$modules )
{
- next unless $module->inst_file;
+ next unless $module = _expand_module($module);
+ next unless $module->inst_file;
next if $module->uptodate;
printf "%-40s %.4f %.4f\n",
$module->id,
@@ -1316,10 +1365,9 @@ sub _show_author_mods
my %hash = map { lc $_, 1 } @$args;
- my @modules = CPAN::Shell->expand( "Module", "/./" );
+ my $modules = _get_all_namespaces();
- foreach my $module ( @modules )
- {
+ foreach my $module ( @$modules ) {
next unless exists $hash{ lc $module->userid };
print $module->id, "\n";
}
@@ -1439,6 +1487,109 @@ sub _path_to_module
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 ) ],
+ [ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 ) ],
+
+ [ qw( Text::Levenshtein distance 7 ) ],
+ [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 ) ],
+
+ ];
+
+# 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;
+sub _guess_at_module_name
+ {
+ my( $target, $threshold ) = @_;
+
+ unless( defined $distance ) {
+ foreach my $try ( @$guessers ) {
+ my $can_guess = eval "require $try->[0]; 1" or next;
+
+ no strict 'refs';
+ $distance = \&{ join "::", @$try[0,1] };
+ $threshold ||= $try->[2];
+ }
+ }
+
+ unless( $distance ) {
+ my $modules = join ", ", map { $_->[0] } @$guessers;
+ substr $modules, rindex( $modules, ',' ), 1, ', and';
+
+ $logger->info( "I can suggest names if you install one of $modules" );
+ 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
@@ -1471,8 +1622,6 @@ report them to the user.
* Check then exit
-* no test option
-
=head1 BUGS
* none noted
@@ -1508,7 +1657,7 @@ brian d foy, C<< <bdfoy@cpan.org> >>
=head1 COPYRIGHT
-Copyright (c) 2001-2014, brian d foy, All Rights Reserved.
+Copyright (c) 2001-2015, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.