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