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