1package App::Cpan; 2 3use strict; 4use warnings; 5use vars qw($VERSION); 6 7use if $] < 5.008 => 'IO::Scalar'; 8 9$VERSION = '1.67'; 10 11=head1 NAME 12 13App::Cpan - easily interact with CPAN from the command line 14 15=head1 SYNOPSIS 16 17 # with arguments and no switches, installs specified modules 18 cpan module_name [ module_name ... ] 19 20 # with switches, installs modules with extra behavior 21 cpan [-cfFimtTw] module_name [ module_name ... ] 22 23 # use local::lib 24 cpan -I module_name [ module_name ... ] 25 26 # one time mirror override for faster mirrors 27 cpan -p ... 28 29 # with just the dot, install from the distribution in the 30 # current directory 31 cpan . 32 33 # without arguments, starts CPAN.pm shell 34 cpan 35 36 # without arguments, but some switches 37 cpan [-ahpruvACDLOPX] 38 39=head1 DESCRIPTION 40 41This script provides a command interface (not a shell) to CPAN. At the 42moment it uses CPAN.pm to do the work, but it is not a one-shot command 43runner for CPAN.pm. 44 45=head2 Options 46 47=over 4 48 49=item -a 50 51Creates a CPAN.pm autobundle with CPAN::Shell->autobundle. 52 53=item -A module [ module ... ] 54 55Shows the primary maintainers for the specified modules. 56 57=item -c module 58 59Runs a `make clean` in the specified module's directories. 60 61=item -C module [ module ... ] 62 63Show the F<Changes> files for the specified modules 64 65=item -D module [ module ... ] 66 67Show the module details. This prints one line for each out-of-date module 68(meaning, modules locally installed but have newer versions on CPAN). 69Each line has three columns: module name, local version, and CPAN 70version. 71 72=item -f 73 74Force the specified action, when it normally would have failed. Use this 75to install a module even if its tests fail. When you use this option, 76-i is not optional for installing a module when you need to force it: 77 78 % cpan -f -i Module::Foo 79 80=item -F 81 82Turn off CPAN.pm's attempts to lock anything. You should be careful with 83this since you might end up with multiple scripts trying to muck in the 84same directory. This isn't so much of a concern if you're loading a special 85config with C<-j>, and that config sets up its own work directories. 86 87=item -g module [ module ... ] 88 89Downloads to the current directory the latest distribution of the module. 90 91=item -G module [ module ... ] 92 93UNIMPLEMENTED 94 95Download to the current directory the latest distribution of the 96modules, unpack each distribution, and create a git repository for each 97distribution. 98 99If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch> 100distribution. 101 102=item -h 103 104Print a help message and exit. When you specify C<-h>, it ignores all 105of the other options and arguments. 106 107=item -i module [ module ... ] 108 109Install the specified modules. With no other switches, this switch 110is implied. 111 112=item -I 113 114Load C<local::lib> (think like C<-I> for loading lib paths). Too bad 115C<-l> was already taken. 116 117=item -j Config.pm 118 119Load the file that has the CPAN configuration data. This should have the 120same format as the standard F<CPAN/Config.pm> file, which defines 121C<$CPAN::Config> as an anonymous hash. 122 123=item -J 124 125Dump the configuration in the same format that CPAN.pm uses. This is useful 126for checking the configuration as well as using the dump as a starting point 127for a new, custom configuration. 128 129=item -l 130 131List all installed modules with their versions 132 133=item -L author [ author ... ] 134 135List the modules by the specified authors. 136 137=item -m 138 139Make the specified modules. 140 141=item -M mirror1,mirror2,... 142 143A comma-separated list of mirrors to use for just this run. The C<-P> 144option can find them for you automatically. 145 146=item -n 147 148Do a dry run, but don't actually install anything. (unimplemented) 149 150=item -O 151 152Show the out-of-date modules. 153 154=item -p 155 156Ping the configured mirrors and print a report 157 158=item -P 159 160Find the best mirrors you could be using and use them for the current 161session. 162 163=item -r 164 165Recompiles dynamically loaded modules with CPAN::Shell->recompile. 166 167=item -s 168 169Drop in the CPAN.pm shell. This command does this automatically if you don't 170specify any arguments. 171 172=item -t module [ module ... ] 173 174Run a `make test` on the specified modules. 175 176=item -T 177 178Do not test modules. Simply install them. 179 180=item -u 181 182Upgrade all installed modules. Blindly doing this can really break things, 183so keep a backup. 184 185=item -v 186 187Print the script version and CPAN.pm version then exit. 188 189=item -V 190 191Print detailed information about the cpan client. 192 193=item -w 194 195UNIMPLEMENTED 196 197Turn on cpan warnings. This checks various things, like directory permissions, 198and tells you about problems you might have. 199 200=item -x module [ module ... ] 201 202Find close matches to the named modules that you think you might have 203mistyped. This requires the optional installation of Text::Levenshtein or 204Text::Levenshtein::Damerau. 205 206=item -X 207 208Dump all the namespaces to standard output. 209 210=back 211 212=head2 Examples 213 214 # print a help message 215 cpan -h 216 217 # print the version numbers 218 cpan -v 219 220 # create an autobundle 221 cpan -a 222 223 # recompile modules 224 cpan -r 225 226 # upgrade all installed modules 227 cpan -u 228 229 # install modules ( sole -i is optional ) 230 cpan -i Netscape::Booksmarks Business::ISBN 231 232 # force install modules ( must use -i ) 233 cpan -fi CGI::Minimal URI 234 235 # install modules but without testing them 236 cpan -Ti CGI::Minimal URI 237 238=head2 Environment variables 239 240There are several components in CPAN.pm that use environment variables. 241The build tools, L<ExtUtils::MakeMaker> and L<Module::Build> use some, 242while others matter to the levels above them. Some of these are specified 243by the Perl Toolchain Gang: 244 245Lancaster Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md> 246 247Oslo Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/oslo-consensus.md> 248 249=over 4 250 251=item NONINTERACTIVE_TESTING 252 253Assume no one is paying attention and skips prompts for distributions 254that do that correctly. C<cpan(1)> sets this to C<1> unless it already 255has a value (even if that value is false). 256 257=item PERL_MM_USE_DEFAULT 258 259Use the default answer for a prompted questions. C<cpan(1)> sets this 260to C<1> unless it already has a value (even if that value is false). 261 262=item CPAN_OPTS 263 264As with C<PERL5OPTS>, a string of additional C<cpan(1)> options to 265add to those you specify on the command line. 266 267=item CPANSCRIPT_LOGLEVEL 268 269The log level to use, with either the embedded, minimal logger or 270L<Log::Log4perl> if it is installed. Possible values are the same as 271the C<Log::Log4perl> levels: C<TRACE>, C<DEBUG>, C<INFO>, C<WARN>, 272C<ERROR>, and C<FATAL>. The default is C<INFO>. 273 274=item GIT_COMMAND 275 276The path to the C<git> binary to use for the Git features. The default 277is C</usr/local/bin/git>. 278 279=back 280 281=head2 Methods 282 283=over 4 284 285=cut 286 287use autouse Carp => qw(carp croak cluck); 288use CPAN 1.80 (); # needs no test 289use Config; 290use autouse Cwd => qw(cwd); 291use autouse 'Data::Dumper' => qw(Dumper); 292use File::Spec::Functions; 293use File::Basename; 294use Getopt::Std; 295 296# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 297# Internal constants 298use constant TRUE => 1; 299use constant FALSE => 0; 300 301 302# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 303# The return values 304use constant HEY_IT_WORKED => 0; 305use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001 306use constant ITS_NOT_MY_FAULT => 2; 307use constant THE_PROGRAMMERS_AN_IDIOT => 4; 308use constant A_MODULE_FAILED_TO_INSTALL => 8; 309 310 311# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 312# set up the order of options that we layer over CPAN::Shell 313BEGIN { # most of this should be in methods 314use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order 315 %Method_table %Method_table_index ); 316 317@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 ); 318 319$Default = 'default'; 320 321%CPAN_METHODS = ( # map switches to method names in CPAN::Shell 322 $Default => 'install', 323 'c' => 'clean', 324 'f' => 'force', 325 'i' => 'install', 326 'm' => 'make', 327 't' => 'test', 328 'u' => 'upgrade', 329 'T' => 'notest', 330 's' => 'shell', 331 ); 332@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS; 333 334@option_order = ( @META_OPTIONS, @CPAN_OPTIONS ); 335 336 337# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 338# map switches to the subroutines in this script, along with other information. 339# use this stuff instead of hard-coded indices and values 340sub NO_ARGS () { 0 } 341sub ARGS () { 1 } 342sub GOOD_EXIT () { 0 } 343 344%Method_table = ( 345# key => [ sub ref, takes args?, exit value, description ] 346 347 # options that do their thing first, then exit 348 h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ], 349 v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ], 350 V => [ \&_print_details, NO_ARGS, GOOD_EXIT, 'Printing detailed version' ], 351 X => [ \&_list_all_namespaces, NO_ARGS, GOOD_EXIT, 'Listing all namespaces' ], 352 353 # options that affect other options 354 j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ], 355 J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ], 356 F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ], 357 I => [ \&_load_local_lib, NO_ARGS, GOOD_EXIT, 'Loading local::lib' ], 358 M => [ \&_use_these_mirrors, ARGS, GOOD_EXIT, 'Setting per session mirrors' ], 359 P => [ \&_find_good_mirrors, NO_ARGS, GOOD_EXIT, 'Finding good mirrors' ], 360 w => [ \&_turn_on_warnings, NO_ARGS, GOOD_EXIT, 'Turning on warnings' ], 361 362 # options that do their one thing 363 g => [ \&_download, ARGS, GOOD_EXIT, 'Download the latest distro' ], 364 G => [ \&_gitify, ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ], 365 366 C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ], 367 A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ], 368 D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ], 369 O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ], 370 l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ], 371 372 L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ], 373 a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ], 374 p => [ \&_ping_mirrors, NO_ARGS, GOOD_EXIT, 'Pinging mirrors' ], 375 376 r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ], 377 u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ], 378 's' => [ \&_shell, NO_ARGS, GOOD_EXIT, 'Running `make test`' ], 379 380 'x' => [ \&_guess_namespace, ARGS, GOOD_EXIT, 'Guessing namespaces' ], 381 c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ], 382 f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ], 383 i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ], 384 'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ], 385 t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ], 386 T => [ \&_default, ARGS, GOOD_EXIT, 'Installing with notest' ], 387 ); 388 389%Method_table_index = ( 390 code => 0, 391 takes_args => 1, 392 exit_value => 2, 393 description => 3, 394 ); 395} 396 397 398# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 399# finally, do some argument processing 400 401sub _stupid_interface_hack_for_non_rtfmers 402 { 403 no warnings 'uninitialized'; 404 shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 ) 405 } 406 407sub _process_options 408 { 409 my %options; 410 411 push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || ''; 412 413 # if no arguments, just drop into the shell 414 if( 0 == @ARGV ) { CPAN::shell(); exit 0 } 415 else 416 { 417 Getopt::Std::getopts( 418 join( '', @option_order ), \%options ); 419 \%options; 420 } 421 } 422 423sub _process_setup_options 424 { 425 my( $class, $options ) = @_; 426 427 if( $options->{j} ) 428 { 429 $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} ); 430 delete $options->{j}; 431 } 432 else 433 { 434 # this is what CPAN.pm would do otherwise 435 local $CPAN::Be_Silent = 1; 436 CPAN::HandleConfig->load( 437 # be_silent => 1, deprecated 438 write_file => 0, 439 ); 440 } 441 442 $class->_turn_off_testing if $options->{T}; 443 444 foreach my $o ( qw(F I w P M) ) 445 { 446 next unless exists $options->{$o}; 447 $Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} ); 448 delete $options->{$o}; 449 } 450 451 if( $options->{o} ) 452 { 453 my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o}; 454 foreach my $pair ( @pairs ) 455 { 456 my( $setting, $value ) = @$pair; 457 $CPAN::Config->{$setting} = $value; 458 # $logger->debug( "Setting [$setting] to [$value]" ); 459 } 460 delete $options->{o}; 461 } 462 463 my $option_count = grep { $options->{$_} } @option_order; 464 no warnings 'uninitialized'; 465 466 # don't count options that imply installation 467 foreach my $opt ( qw(f T) ) { # don't count force or notest 468 $option_count -= $options->{$opt}; 469 } 470 471 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 472 # if there are no options, set -i (this line fixes RT ticket 16915) 473 $options->{i}++ unless $option_count; 474 } 475 476sub _setup_environment { 477# should we override or set defaults? If this were a true interactive 478# session, we'd be in the CPAN shell. 479 480# https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md 481 $ENV{NONINTERACTIVE_TESTING} = 1 unless defined $ENV{NONINTERACTIVE_TESTING}; 482 $ENV{PERL_MM_USE_DEFAULT} = 1 unless defined $ENV{PERL_MM_USE_DEFAULT}; 483 } 484 485=item run() 486 487Just do it. 488 489The C<run> method returns 0 on success and a positive number on 490failure. See the section on EXIT CODES for details on the values. 491 492=cut 493 494my $logger; 495 496sub run 497 { 498 my $class = shift; 499 500 my $return_value = HEY_IT_WORKED; # assume that things will work 501 502 $logger = $class->_init_logger; 503 $logger->debug( "Using logger from @{[ref $logger]}" ); 504 505 $class->_hook_into_CPANpm_report; 506 $logger->debug( "Hooked into output" ); 507 508 $class->_stupid_interface_hack_for_non_rtfmers; 509 $logger->debug( "Patched cargo culting" ); 510 511 my $options = $class->_process_options; 512 $logger->debug( "Options are @{[Dumper($options)]}" ); 513 514 $class->_process_setup_options( $options ); 515 516 $class->_setup_environment( $options ); 517 518 OPTION: foreach my $option ( @option_order ) 519 { 520 next unless $options->{$option}; 521 522 my( $sub, $takes_args, $description ) = 523 map { $Method_table{$option}[ $Method_table_index{$_} ] } 524 qw( code takes_args description ); 525 526 unless( ref $sub eq ref sub {} ) 527 { 528 $return_value = THE_PROGRAMMERS_AN_IDIOT; 529 last OPTION; 530 } 531 532 $logger->info( "[$option] $description -- ignoring other arguments" ) 533 if( @ARGV && ! $takes_args ); 534 535 $return_value = $sub->( \ @ARGV, $options ); 536 537 last; 538 } 539 540 return $return_value; 541 } 542 543{ 544package 545 Local::Null::Logger; # hide from PAUSE 546 547sub new { bless \ my $x, $_[0] } 548sub AUTOLOAD { 549 my $autoload = our $AUTOLOAD; 550 $autoload =~ s/.*://; 551 return if $autoload =~ /^(debug|trace)$/; 552 $CPAN::Frontend->mywarn(">($autoload): $_\n") 553 for split /[\r\n]+/, $_[1]; 554} 555sub DESTROY { 1 } 556} 557 558# load a module without searching the default entry for the current 559# directory 560sub _safe_load_module { 561 my $name = shift; 562 563 local @INC = @INC; 564 pop @INC if $INC[-1] eq '.'; 565 566 eval "require $name; 1"; 567} 568 569sub _init_logger 570 { 571 my $log4perl_loaded = _safe_load_module("Log::Log4perl"); 572 573 unless( $log4perl_loaded ) 574 { 575 print STDOUT "Loading internal logger. Log::Log4perl recommended for better logging\n"; 576 $logger = Local::Null::Logger->new; 577 return $logger; 578 } 579 580 my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO'; 581 582 Log::Log4perl::init( \ <<"HERE" ); 583log4perl.rootLogger=$LEVEL, A1 584log4perl.appender.A1=Log::Log4perl::Appender::Screen 585log4perl.appender.A1.layout=PatternLayout 586log4perl.appender.A1.layout.ConversionPattern=%m%n 587HERE 588 589 $logger = Log::Log4perl->get_logger( 'App::Cpan' ); 590 } 591 592# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 593 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 594# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 595 596sub _default 597 { 598 my( $args, $options ) = @_; 599 600 my $switch = ''; 601 602 # choose the option that we're going to use 603 # we'll deal with 'f' (force) later, so skip it 604 foreach my $option ( @CPAN_OPTIONS ) 605 { 606 next if ( $option eq 'f' or $option eq 'T' ); 607 next unless $options->{$option}; 608 $switch = $option; 609 last; 610 } 611 612 # 1. with no switches, but arguments, use the default switch (install) 613 # 2. with no switches and no args, start the shell 614 # 3. With a switch but no args, die! These switches need arguments. 615 if( not $switch and @$args ) { $switch = $Default; } 616 elsif( not $switch and not @$args ) { return CPAN::shell() } 617 elsif( $switch and not @$args ) 618 { die "Nothing to $CPAN_METHODS{$switch}!\n"; } 619 620 # Get and check the method from CPAN::Shell 621 my $method = $CPAN_METHODS{$switch}; 622 die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method ); 623 624 # call the CPAN::Shell method, with force or notest if specified 625 my $action = do { 626 if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } } 627 elsif( $options->{T} ) { sub { CPAN::Shell->notest( $method, @_ ) } } 628 else { sub { CPAN::Shell->$method( @_ ) } } 629 }; 630 631 # How do I handle exit codes for multiple arguments? 632 my @errors = (); 633 634 $options->{x} or _disable_guessers(); 635 636 foreach my $arg ( @$args ) 637 { 638 # check the argument and perhaps capture typos 639 my $module = _expand_module( $arg ) or do { 640 $logger->error( "Skipping $arg because I couldn't find a matching namespace." ); 641 next; 642 }; 643 644 _clear_cpanpm_output(); 645 $action->( $arg ); 646 647 my $error = _cpanpm_output_indicates_failure(); 648 push @errors, $error if $error; 649 } 650 651 return do { 652 if( @errors ) { $errors[0] } 653 else { HEY_IT_WORKED } 654 }; 655 656 } 657 658# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 659 660=for comment 661 662CPAN.pm sends all the good stuff either to STDOUT, or to a temp 663file if $CPAN::Be_Silent is set. I have to intercept that output 664so I can find out what happened. 665 666=cut 667 668BEGIN { 669my $scalar = ''; 670 671sub _hook_into_CPANpm_report 672 { 673 no warnings 'redefine'; 674 675 *CPAN::Shell::myprint = sub { 676 my($self,$what) = @_; 677 $scalar .= $what; 678 $self->print_ornamented($what, 679 $CPAN::Config->{colorize_print}||'bold blue on_white', 680 ); 681 }; 682 683 *CPAN::Shell::mywarn = sub { 684 my($self,$what) = @_; 685 $scalar .= $what; 686 $self->print_ornamented($what, 687 $CPAN::Config->{colorize_warn}||'bold red on_white' 688 ); 689 }; 690 691 } 692 693sub _clear_cpanpm_output { $scalar = '' } 694 695sub _get_cpanpm_output { $scalar } 696 697# These are lines I don't care about in CPAN.pm output. If I can 698# filter out the informational noise, I have a better chance to 699# catch the error signal 700my @skip_lines = ( 701 qr/^\QWarning \(usually harmless\)/, 702 qr/\bwill not store persistent state\b/, 703 qr(//hint//), 704 qr/^\s+reports\s+/, 705 qr/^Try the command/, 706 qr/^\s+$/, 707 qr/^to find objects/, 708 qr/^\s*Database was generated on/, 709 qr/^Going to read/, 710 qr|^\s+i\s+/|, # the i /Foo::Whatever/ line when it doesn't know 711 ); 712 713sub _get_cpanpm_last_line 714 { 715 my $fh; 716 717 if( $] < 5.008 ) { 718 $fh = IO::Scalar->new( \ $scalar ); 719 } 720 else { 721 eval q{ open $fh, '<', \\ $scalar; }; 722 } 723 724 my @lines = <$fh>; 725 726 # This is a bit ugly. Once we examine a line, we have to 727 # examine the line before it and go through all of the same 728 # regexes. I could do something fancy, but this works. 729 REGEXES: { 730 foreach my $regex ( @skip_lines ) 731 { 732 if( $lines[-1] =~ m/$regex/ ) 733 { 734 pop @lines; 735 redo REGEXES; # we have to go through all of them for every line! 736 } 737 } 738 } 739 740 $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" ); 741 742 $lines[-1]; 743 } 744} 745 746BEGIN { 747my $epic_fail_words = join '|', 748 qw( Error stop(?:ping)? problems force not unsupported 749 fail(?:ed)? Cannot\s+install ); 750 751sub _cpanpm_output_indicates_failure 752 { 753 my $last_line = _get_cpanpm_last_line(); 754 755 my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i; 756 return A_MODULE_FAILED_TO_INSTALL if $last_line =~ /\b(?:Cannot\s+install)\b/i; 757 758 $result || (); 759 } 760} 761 762sub _cpanpm_output_indicates_success 763 { 764 my $last_line = _get_cpanpm_last_line(); 765 766 my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/; 767 $result || (); 768 } 769 770sub _cpanpm_output_is_vague 771 { 772 return FALSE if 773 _cpanpm_output_indicates_failure() || 774 _cpanpm_output_indicates_success(); 775 776 return TRUE; 777 } 778 779# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 780sub _turn_on_warnings { 781 carp "Warnings are implemented yet"; 782 return HEY_IT_WORKED; 783 } 784 785sub _turn_off_testing { 786 $logger->debug( 'Trusting test report history' ); 787 $CPAN::Config->{trust_test_report_history} = 1; 788 return HEY_IT_WORKED; 789 } 790 791# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 792sub _print_help 793 { 794 $logger->info( "Use perldoc to read the documentation" ); 795 exec "perldoc $0"; 796 } 797 798sub _print_version # -v 799 { 800 $logger->info( 801 "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION ); 802 803 return HEY_IT_WORKED; 804 } 805 806sub _print_details # -V 807 { 808 _print_version(); 809 810 _check_install_dirs(); 811 812 $logger->info( '-' x 50 . "\nChecking configured mirrors..." ); 813 foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) { 814 _print_ping_report( $mirror ); 815 } 816 817 $logger->info( '-' x 50 . "\nChecking for faster mirrors..." ); 818 819 { 820 require CPAN::Mirrors; 821 822 if ( $CPAN::Config->{connect_to_internet_ok} ) { 823 $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n}); 824 eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) } 825 or $CPAN::Frontend->mywarn(<<'HERE'); 826We failed to get a copy of the mirror list from the Internet. 827You will need to provide CPAN mirror URLs yourself. 828HERE 829 $CPAN::Frontend->myprint("\n"); 830 } 831 832 my $mirrors = CPAN::Mirrors->new( _mirror_file() ); 833 my @continents = $mirrors->find_best_continents; 834 835 my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] ); 836 my @timings = $mirrors->get_mirrors_timings( \@mirrors ); 837 838 foreach my $timing ( @timings ) { 839 $logger->info( sprintf "%s (%0.2f ms)", 840 $timing->hostname, $timing->rtt ); 841 } 842 } 843 844 return HEY_IT_WORKED; 845 } 846 847sub _check_install_dirs 848 { 849 my $makepl_arg = $CPAN::Config->{makepl_arg}; 850 my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg}; 851 852 my @custom_dirs; 853 # PERL_MM_OPT 854 push @custom_dirs, 855 $makepl_arg =~ m/INSTALL_BASE\s*=\s*(\S+)/g, 856 $mbuildpl_arg =~ m/--install_base\s*=\s*(\S+)/g; 857 858 if( @custom_dirs ) { 859 foreach my $dir ( @custom_dirs ) { 860 _print_inc_dir_report( $dir ); 861 } 862 } 863 864 # XXX: also need to check makepl_args, etc 865 866 my @checks = ( 867 [ 'core', [ grep $_, @Config{qw(installprivlib installarchlib)} ] ], 868 [ 'vendor', [ grep $_, @Config{qw(installvendorlib installvendorarch)} ] ], 869 [ 'site', [ grep $_, @Config{qw(installsitelib installsitearch)} ] ], 870 [ 'PERL5LIB', _split_paths( $ENV{PERL5LIB} ) ], 871 [ 'PERLLIB', _split_paths( $ENV{PERLLIB} ) ], 872 ); 873 874 $logger->info( '-' x 50 . "\nChecking install dirs..." ); 875 foreach my $tuple ( @checks ) { 876 my( $label ) = $tuple->[0]; 877 878 $logger->info( "Checking $label" ); 879 $logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] }; 880 foreach my $dir ( @{ $tuple->[1] } ) { 881 _print_inc_dir_report( $dir ); 882 } 883 } 884 885 } 886 887sub _split_paths 888 { 889 [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ]; 890 } 891 892 893=pod 894 895Stolen from File::Path::Expand 896 897=cut 898 899sub _expand_filename 900 { 901 my( $path ) = @_; 902 no warnings 'uninitialized'; 903 $logger->debug( "Expanding path $path\n" ); 904 $path =~ s{\A~([^/]+)?}{ 905 _home_of( $1 || $> ) || "~$1" 906 }e; 907 return $path; 908 } 909 910sub _home_of 911 { 912 require User::pwent; 913 my( $user ) = @_; 914 my $ent = User::pwent::getpw($user) or return; 915 return $ent->dir; 916 } 917 918sub _get_default_inc 919 { 920 require Config; 921 922 [ @Config::Config{ _vars() }, '.' ]; 923 } 924 925sub _vars { 926 qw( 927 installarchlib 928 installprivlib 929 installsitearch 930 installsitelib 931 ); 932 } 933 934sub _ping_mirrors { 935 my $urls = $CPAN::Config->{urllist}; 936 require URI; 937 938 foreach my $url ( @$urls ) { 939 my( $obj ) = URI->new( $url ); 940 next unless _is_pingable_scheme( $obj ); 941 my $host = $obj->host; 942 _print_ping_report( $obj ); 943 } 944 945 } 946 947sub _is_pingable_scheme { 948 my( $uri ) = @_; 949 950 $uri->scheme eq 'file' 951 } 952 953sub _mirror_file { 954 my $file = do { 955 my $file = 'MIRRORED.BY'; 956 my $local_path = File::Spec->catfile( 957 $CPAN::Config->{keep_source_where}, $file ); 958 959 if( -e $local_path ) { $local_path } 960 else { 961 require CPAN::FTP; 962 CPAN::FTP->localize( $file, $local_path, 3, 1 ); 963 $local_path; 964 } 965 }; 966 } 967 968sub _find_good_mirrors { 969 require CPAN::Mirrors; 970 971 my $mirrors = CPAN::Mirrors->new( _mirror_file() ); 972 973 my @mirrors = $mirrors->best_mirrors( 974 how_many => 5, 975 verbose => 1, 976 ); 977 978 foreach my $mirror ( @mirrors ) { 979 next unless eval { $mirror->can( 'http' ) }; 980 _print_ping_report( $mirror->http ); 981 } 982 983 $CPAN::Config->{urllist} = [ 984 map { $_->http } @mirrors 985 ]; 986 } 987 988sub _print_inc_dir_report 989 { 990 my( $dir ) = shift; 991 992 my $writeable = -w $dir ? '+' : '!!! (not writeable)'; 993 $logger->info( "\t$writeable $dir" ); 994 return -w $dir; 995 } 996 997sub _print_ping_report 998 { 999 my( $mirror ) = @_; 1000 1001 my $rtt = eval { _get_ping_report( $mirror ) }; 1002 my $result = $rtt ? sprintf "+ (%4d ms)", $rtt * 1000 : '!'; 1003 1004 $logger->info( 1005 sprintf "\t%s %s", $result, $mirror 1006 ); 1007 } 1008 1009sub _get_ping_report 1010 { 1011 require URI; 1012 my( $mirror ) = @_; 1013 my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX 1014 require Net::Ping; 1015 1016 my $ping = Net::Ping->new( 'tcp', 1 ); 1017 1018 if( $url->scheme eq 'file' ) { 1019 return -e $url->file; 1020 } 1021 1022 my( $port ) = $url->port; 1023 1024 return unless $port; 1025 1026 if ( $ping->can('port_number') ) { 1027 $ping->port_number($port); 1028 } 1029 else { 1030 $ping->{'port_num'} = $port; 1031 } 1032 1033 $ping->hires(1) if $ping->can( 'hires' ); 1034 my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) }; 1035 $alive ? $rtt : undef; 1036 } 1037 1038sub _load_local_lib # -I 1039 { 1040 $logger->debug( "Loading local::lib" ); 1041 1042 my $rc = _safe_load_module("local::lib"); 1043 unless( $rc ) { 1044 $logger->logdie( "Could not load local::lib" ); 1045 } 1046 1047 local::lib->import; 1048 1049 return HEY_IT_WORKED; 1050 } 1051 1052sub _use_these_mirrors # -M 1053 { 1054 $logger->debug( "Setting per session mirrors" ); 1055 unless( $_[0] ) { 1056 $logger->logdie( "The -M switch requires a comma-separated list of mirrors" ); 1057 } 1058 1059 $CPAN::Config->{urllist} = [ split /,/, $_[0] ]; 1060 1061 $logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" ); 1062 1063 } 1064 1065sub _create_autobundle 1066 { 1067 $logger->info( 1068 "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" ); 1069 1070 CPAN::Shell->autobundle; 1071 1072 return HEY_IT_WORKED; 1073 } 1074 1075sub _recompile 1076 { 1077 $logger->info( "Recompiling dynamically-loaded extensions" ); 1078 1079 CPAN::Shell->recompile; 1080 1081 return HEY_IT_WORKED; 1082 } 1083 1084sub _upgrade 1085 { 1086 $logger->info( "Upgrading all modules" ); 1087 1088 CPAN::Shell->upgrade(); 1089 1090 return HEY_IT_WORKED; 1091 } 1092 1093sub _shell 1094 { 1095 $logger->info( "Dropping into shell" ); 1096 1097 CPAN::shell(); 1098 1099 return HEY_IT_WORKED; 1100 } 1101 1102sub _load_config # -j 1103 { 1104 my $file = shift || ''; 1105 1106 # should I clear out any existing config here? 1107 $CPAN::Config = {}; 1108 delete $INC{'CPAN/Config.pm'}; 1109 croak( "Config file [$file] does not exist!\n" ) unless -e $file; 1110 1111 my $rc = eval "require '$file'"; 1112 1113 # CPAN::HandleConfig::require_myconfig_or_config looks for this 1114 $INC{'CPAN/MyConfig.pm'} = 'fake out!'; 1115 1116 # CPAN::HandleConfig::load looks for this 1117 $CPAN::Config_loaded = 'fake out'; 1118 1119 croak( "Could not load [$file]: $@\n") unless $rc; 1120 1121 return HEY_IT_WORKED; 1122 } 1123 1124sub _dump_config # -J 1125 { 1126 my $args = shift; 1127 require Data::Dumper; 1128 1129 my $fh = $args->[0] || \*STDOUT; 1130 1131 local $Data::Dumper::Sortkeys = 1; 1132 my $dd = Data::Dumper->new( 1133 [$CPAN::Config], 1134 ['$CPAN::Config'] 1135 ); 1136 1137 print $fh $dd->Dump, "\n1;\n__END__\n"; 1138 1139 return HEY_IT_WORKED; 1140 } 1141 1142sub _lock_lobotomy # -F 1143 { 1144 no warnings 'redefine'; 1145 1146 *CPAN::_flock = sub { 1 }; 1147 *CPAN::checklock = sub { 1 }; 1148 1149 return HEY_IT_WORKED; 1150 } 1151 1152sub _download 1153 { 1154 my $args = shift; 1155 1156 local $CPAN::DEBUG = 1; 1157 1158 my %paths; 1159 1160 foreach my $arg ( @$args ) { 1161 $logger->info( "Checking $arg" ); 1162 1163 my $module = _expand_module( $arg ) or next; 1164 my $path = $module->cpan_file; 1165 1166 $logger->debug( "Inst file would be $path\n" ); 1167 1168 $paths{$arg} = _get_file( _make_path( $path ) ); 1169 1170 $logger->info( "Downloaded [$arg] to [$paths{$module}]" ); 1171 } 1172 1173 return \%paths; 1174 } 1175 1176sub _make_path { join "/", qw(authors id), $_[0] } 1177 1178sub _get_file 1179 { 1180 my $path = shift; 1181 1182 my $loaded = _safe_load_module("LWP::Simple"); 1183 croak "You need LWP::Simple to use features that fetch files from CPAN\n" 1184 unless $loaded; 1185 1186 my $file = substr $path, rindex( $path, '/' ) + 1; 1187 my $store_path = catfile( cwd(), $file ); 1188 $logger->debug( "Store path is $store_path" ); 1189 1190 foreach my $site ( @{ $CPAN::Config->{urllist} } ) 1191 { 1192 my $fetch_path = join "/", $site, $path; 1193 $logger->debug( "Trying $fetch_path" ); 1194 last if LWP::Simple::getstore( $fetch_path, $store_path ); 1195 } 1196 1197 return $store_path; 1198 } 1199 1200sub _gitify 1201 { 1202 my $args = shift; 1203 1204 my $loaded = _safe_load_module("Archive::Extract"); 1205 croak "You need Archive::Extract to use features that gitify distributions\n" 1206 unless $loaded; 1207 1208 my $starting_dir = cwd(); 1209 1210 foreach my $arg ( @$args ) 1211 { 1212 $logger->info( "Checking $arg" ); 1213 my $store_paths = _download( [ $arg ] ); 1214 $logger->debug( "gitify Store path is $store_paths->{$arg}" ); 1215 my $dirname = dirname( $store_paths->{$arg} ); 1216 1217 my $ae = Archive::Extract->new( archive => $store_paths->{$arg} ); 1218 $ae->extract( to => $dirname ); 1219 1220 chdir $ae->extract_path; 1221 1222 my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git'; 1223 croak "Could not find $git" unless -e $git; 1224 croak "$git is not executable" unless -x $git; 1225 1226 # can we do this in Pure Perl? 1227 system( $git, 'init' ); 1228 system( $git, qw( add . ) ); 1229 system( $git, qw( commit -a -m ), 'initial import' ); 1230 } 1231 1232 chdir $starting_dir; 1233 1234 return HEY_IT_WORKED; 1235 } 1236 1237sub _show_Changes 1238 { 1239 my $args = shift; 1240 1241 foreach my $arg ( @$args ) 1242 { 1243 $logger->info( "Checking $arg\n" ); 1244 1245 my $module = _expand_module( $arg ) or next; 1246 1247 my $out = _get_cpanpm_output(); 1248 1249 next unless eval { $module->inst_file }; 1250 #next if $module->uptodate; 1251 1252 ( my $id = $module->id() ) =~ s/::/\-/; 1253 1254 my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" . 1255 $id . "-" . $module->cpan_version() . "/"; 1256 1257 #print "URL: $url\n"; 1258 _get_changes_file($url); 1259 } 1260 1261 return HEY_IT_WORKED; 1262 } 1263 1264sub _get_changes_file 1265 { 1266 croak "Reading Changes files requires LWP::Simple and URI\n" 1267 unless _safe_load_module("LWP::Simple") && _safe_load_module("URI"); 1268 1269 my $url = shift; 1270 1271 my $content = LWP::Simple::get( $url ); 1272 $logger->info( "Got $url ..." ) if defined $content; 1273 #print $content; 1274 1275 my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi; 1276 1277 my $changes_url = URI->new_abs( $change_link, $url ); 1278 $logger->debug( "Change link is: $changes_url" ); 1279 1280 my $changes = LWP::Simple::get( $changes_url ); 1281 1282 print $changes; 1283 1284 return HEY_IT_WORKED; 1285 } 1286 1287sub _show_Author 1288 { 1289 my $args = shift; 1290 1291 foreach my $arg ( @$args ) 1292 { 1293 my $module = _expand_module( $arg ) or next; 1294 1295 unless( $module ) 1296 { 1297 $logger->info( "Didn't find a $arg module, so no author!" ); 1298 next; 1299 } 1300 1301 my $author = CPAN::Shell->expand( "Author", $module->userid ); 1302 1303 next unless $module->userid; 1304 1305 printf "%-25s %-8s %-25s %s\n", 1306 $arg, $module->userid, $author->email, $author->name; 1307 } 1308 1309 return HEY_IT_WORKED; 1310 } 1311 1312sub _show_Details 1313 { 1314 my $args = shift; 1315 1316 foreach my $arg ( @$args ) 1317 { 1318 my $module = _expand_module( $arg ) or next; 1319 my $author = CPAN::Shell->expand( "Author", $module->userid ); 1320 1321 next unless $module->userid; 1322 1323 print "$arg\n", "-" x 73, "\n\t"; 1324 print join "\n\t", 1325 $module->description ? $module->description : "(no description)", 1326 $module->cpan_file ? $module->cpan_file : "(no cpanfile)", 1327 $module->inst_file ? $module->inst_file :"(no installation file)" , 1328 'Installed: ' . ($module->inst_version ? $module->inst_version : "not installed"), 1329 'CPAN: ' . $module->cpan_version . ' ' . 1330 ($module->uptodate ? "" : "Not ") . "up to date", 1331 $author->fullname . " (" . $module->userid . ")", 1332 $author->email; 1333 print "\n\n"; 1334 1335 } 1336 1337 return HEY_IT_WORKED; 1338 } 1339 1340BEGIN { 1341my $modules; 1342sub _get_all_namespaces 1343 { 1344 return $modules if $modules; 1345 $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ]; 1346 } 1347} 1348 1349sub _show_out_of_date 1350 { 1351 my $modules = _get_all_namespaces(); 1352 1353 printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN"; 1354 print "-" x 73, "\n"; 1355 1356 foreach my $module ( @$modules ) 1357 { 1358 next unless $module = _expand_module($module); 1359 next unless $module->inst_file; 1360 next if $module->uptodate; 1361 printf "%-40s %.4f %.4f\n", 1362 $module->id, 1363 $module->inst_version ? $module->inst_version : '', 1364 $module->cpan_version; 1365 } 1366 1367 return HEY_IT_WORKED; 1368 } 1369 1370sub _show_author_mods 1371 { 1372 my $args = shift; 1373 1374 my %hash = map { lc $_, 1 } @$args; 1375 1376 my $modules = _get_all_namespaces(); 1377 1378 foreach my $module ( @$modules ) { 1379 next unless exists $hash{ lc $module->userid }; 1380 print $module->id, "\n"; 1381 } 1382 1383 return HEY_IT_WORKED; 1384 } 1385 1386sub _list_all_mods # -l 1387 { 1388 require File::Find; 1389 1390 my $args = shift; 1391 1392 1393 my $fh = \*STDOUT; 1394 1395 INC: foreach my $inc ( @INC ) 1396 { 1397 my( $wanted, $reporter ) = _generator(); 1398 File::Find::find( { wanted => $wanted }, $inc ); 1399 1400 my $count = 0; 1401 FILE: foreach my $file ( @{ $reporter->() } ) 1402 { 1403 my $version = _parse_version_safely( $file ); 1404 1405 my $module_name = _path_to_module( $inc, $file ); 1406 next FILE unless defined $module_name; 1407 1408 print $fh "$module_name\t$version\n"; 1409 1410 #last if $count++ > 5; 1411 } 1412 } 1413 1414 return HEY_IT_WORKED; 1415 } 1416 1417sub _generator 1418 { 1419 my @files = (); 1420 1421 sub { push @files, 1422 File::Spec->canonpath( $File::Find::name ) 1423 if m/\A\w+\.pm\z/ }, 1424 sub { \@files }, 1425 } 1426 1427sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored 1428 { 1429 my( $file ) = @_; 1430 1431 local $/ = "\n"; 1432 local $_; # don't mess with the $_ in the map calling this 1433 1434 return unless open FILE, "<$file"; 1435 1436 my $in_pod = 0; 1437 my $version; 1438 while( <FILE> ) 1439 { 1440 chomp; 1441 $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod; 1442 next if $in_pod || /^\s*#/; 1443 1444 next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; 1445 my( $sigil, $var ) = ( $1, $2 ); 1446 1447 $version = _eval_version( $_, $sigil, $var ); 1448 last; 1449 } 1450 close FILE; 1451 1452 return 'undef' unless defined $version; 1453 1454 return $version; 1455 } 1456 1457sub _eval_version 1458 { 1459 my( $line, $sigil, $var ) = @_; 1460 1461 # split package line to hide from PAUSE 1462 my $eval = qq{ 1463 package 1464 ExtUtils::MakeMaker::_version; 1465 1466 local $sigil$var; 1467 \$$var=undef; do { 1468 $line 1469 }; \$$var 1470 }; 1471 1472 my $version = do { 1473 local $^W = 0; 1474 no strict; 1475 eval( $eval ); 1476 }; 1477 1478 return $version; 1479 } 1480 1481sub _path_to_module 1482 { 1483 my( $inc, $path ) = @_; 1484 return if length $path < length $inc; 1485 1486 my $module_path = substr( $path, length $inc ); 1487 $module_path =~ s/\.pm\z//; 1488 1489 # XXX: this is cheating and doesn't handle everything right 1490 my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path ); 1491 shift @dirs; 1492 1493 my $module_name = join "::", @dirs; 1494 1495 return $module_name; 1496 } 1497 1498 1499sub _expand_module 1500 { 1501 my( $module ) = @_; 1502 1503 my $expanded = CPAN::Shell->expandany( $module ); 1504 return $expanded if $expanded; 1505 $expanded = CPAN::Shell->expand( "Module", $module ); 1506 unless( defined $expanded ) { 1507 $logger->error( "Could not expand [$module]. Check the module name." ); 1508 my $threshold = ( 1509 grep { int } 1510 sort { length $a <=> length $b } 1511 length($module)/4, 4 1512 )[0]; 1513 1514 my $guesses = _guess_at_module_name( $module, $threshold ); 1515 if( defined $guesses and @$guesses ) { 1516 $logger->info( "Perhaps you meant one of these:" ); 1517 foreach my $guess ( @$guesses ) { 1518 $logger->info( "\t$guess" ); 1519 } 1520 } 1521 return; 1522 } 1523 1524 return $expanded; 1525 } 1526 1527my $guessers = [ 1528 [ qw( Text::Levenshtein::XS distance 7 1 ) ], 1529 [ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 1 ) ], 1530 1531 [ qw( Text::Levenshtein distance 7 1 ) ], 1532 [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 1 ) ], 1533 1534 ]; 1535 1536sub _disable_guessers 1537 { 1538 $_->[-1] = 0 for @$guessers; 1539 } 1540 1541# for -x 1542sub _guess_namespace 1543 { 1544 my $args = shift; 1545 1546 foreach my $arg ( @$args ) 1547 { 1548 $logger->debug( "Checking $arg" ); 1549 my $guesses = _guess_at_module_name( $arg ); 1550 1551 foreach my $guess ( @$guesses ) { 1552 print $guess, "\n"; 1553 } 1554 } 1555 1556 return HEY_IT_WORKED; 1557 } 1558 1559sub _list_all_namespaces { 1560 my $modules = _get_all_namespaces(); 1561 1562 foreach my $module ( @$modules ) { 1563 print $module, "\n"; 1564 } 1565 } 1566 1567BEGIN { 1568my $distance; 1569my $_threshold; 1570my $can_guess; 1571my $shown_help = 0; 1572sub _guess_at_module_name 1573 { 1574 my( $target, $threshold ) = @_; 1575 1576 unless( defined $distance ) { 1577 foreach my $try ( @$guessers ) { 1578 $can_guess = eval "require $try->[0]; 1" or next; 1579 1580 $try->[-1] or next; # disabled 1581 no strict 'refs'; 1582 $distance = \&{ join "::", @$try[0,1] }; 1583 $threshold ||= $try->[2]; 1584 } 1585 } 1586 $_threshold ||= $threshold; 1587 1588 unless( $distance ) { 1589 unless( $shown_help ) { 1590 my $modules = join ", ", map { $_->[0] } @$guessers; 1591 substr $modules, rindex( $modules, ',' ), 1, ', and'; 1592 1593 # Should this be colorized? 1594 if( $can_guess ) { 1595 $logger->info( "I can suggest names if you provide the -x option on invocation." ); 1596 } 1597 else { 1598 $logger->info( "I can suggest names if you install one of $modules" ); 1599 $logger->info( "and you provide the -x option on invocation." ); 1600 } 1601 $shown_help++; 1602 } 1603 return; 1604 } 1605 1606 my $modules = _get_all_namespaces(); 1607 $logger->info( "Checking " . @$modules . " namespaces for close match suggestions" ); 1608 1609 my %guesses; 1610 foreach my $guess ( @$modules ) { 1611 my $distance = $distance->( $target, $guess ); 1612 next if $distance > $_threshold; 1613 $guesses{$guess} = $distance; 1614 } 1615 1616 my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses; 1617 return [ grep { defined } @guesses[0..9] ]; 1618 } 1619} 1620 16211; 1622 1623=back 1624 1625=head1 EXIT VALUES 1626 1627The script exits with zero if it thinks that everything worked, or a 1628positive number if it thinks that something failed. Note, however, that 1629in some cases it has to divine a failure by the output of things it does 1630not control. For now, the exit codes are vague: 1631 1632 1 An unknown error 1633 1634 2 The was an external problem 1635 1636 4 There was an internal problem with the script 1637 1638 8 A module failed to install 1639 1640=head1 TO DO 1641 1642* There is initial support for Log4perl if it is available, but I 1643haven't gone through everything to make the NullLogger work out 1644correctly if Log4perl is not installed. 1645 1646* When I capture CPAN.pm output, I need to check for errors and 1647report them to the user. 1648 1649* Warnings switch 1650 1651* Check then exit 1652 1653=head1 BUGS 1654 1655* none noted 1656 1657=head1 SEE ALSO 1658 1659L<CPAN>, L<App::cpanminus> 1660 1661=head1 SOURCE AVAILABILITY 1662 1663This code is in Github in the CPAN.pm repository: 1664 1665 https://github.com/andk/cpanpm 1666 1667The source used to be tracked separately in another GitHub repo, 1668but the canonical source is now in the above repo. 1669 1670=head1 CREDITS 1671 1672Japheth Cleaver added the bits to allow a forced install (C<-f>). 1673 1674Jim Brandt suggest and provided the initial implementation for the 1675up-to-date and Changes features. 1676 1677Adam Kennedy pointed out that C<exit()> causes problems on Windows 1678where this script ends up with a .bat extension 1679 1680David Golden helps integrate this into the C<CPAN.pm> repos. 1681 1682=head1 AUTHOR 1683 1684brian d foy, C<< <bdfoy@cpan.org> >> 1685 1686=head1 COPYRIGHT 1687 1688Copyright (c) 2001-2015, brian d foy, All Rights Reserved. 1689 1690You may redistribute this under the same terms as Perl itself. 1691 1692=cut 1693