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