1package App::Cpan; 2use strict; 3use warnings; 4use vars qw($VERSION); 5 6$VERSION = '1.5701'; 7 8=head1 NAME 9 10App::Cpan - easily interact with CPAN from the command line 11 12=head1 SYNOPSIS 13 14 # with arguments and no switches, installs specified modules 15 cpan module_name [ module_name ... ] 16 17 # with switches, installs modules with extra behavior 18 cpan [-cfFimt] module_name [ module_name ... ] 19 20 # use local::lib 21 cpan -l module_name [ module_name ... ] 22 23 # with just the dot, install from the distribution in the 24 # current directory 25 cpan . 26 27 # without arguments, starts CPAN.pm shell 28 cpan 29 30 # without arguments, but some switches 31 cpan [-ahruvACDLO] 32 33=head1 DESCRIPTION 34 35This script provides a command interface (not a shell) to CPAN. At the 36moment it uses CPAN.pm to do the work, but it is not a one-shot command 37runner for CPAN.pm. 38 39=head2 Options 40 41=over 4 42 43=item -a 44 45Creates a CPAN.pm autobundle with CPAN::Shell->autobundle. 46 47=item -A module [ module ... ] 48 49Shows the primary maintainers for the specified modules. 50 51=item -c module 52 53Runs a `make clean` in the specified module's directories. 54 55=item -C module [ module ... ] 56 57Show the F<Changes> files for the specified modules 58 59=item -D module [ module ... ] 60 61Show the module details. This prints one line for each out-of-date module 62(meaning, modules locally installed but have newer versions on CPAN). 63Each line has three columns: module name, local version, and CPAN 64version. 65 66=item -f 67 68Force the specified action, when it normally would have failed. Use this 69to install a module even if its tests fail. When you use this option, 70-i is not optional for installing a module when you need to force it: 71 72 % cpan -f -i Module::Foo 73 74=item -F 75 76Turn off CPAN.pm's attempts to lock anything. You should be careful with 77this since you might end up with multiple scripts trying to muck in the 78same directory. This isn't so much of a concern if you're loading a special 79config with C<-j>, and that config sets up its own work directories. 80 81=item -g module [ module ... ] 82 83Downloads to the current directory the latest distribution of the module. 84 85=item -G module [ module ... ] 86 87UNIMPLEMENTED 88 89Download to the current directory the latest distribution of the 90modules, unpack each distribution, and create a git repository for each 91distribution. 92 93If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch> 94distribution. 95 96=item -h 97 98Print a help message and exit. When you specify C<-h>, it ignores all 99of the other options and arguments. 100 101=item -i 102 103Install the specified modules. 104 105=item -j Config.pm 106 107Load the file that has the CPAN configuration data. This should have the 108same format as the standard F<CPAN/Config.pm> file, which defines 109C<$CPAN::Config> as an anonymous hash. 110 111=item -J 112 113Dump the configuration in the same format that CPAN.pm uses. This is useful 114for checking the configuration as well as using the dump as a starting point 115for a new, custom configuration. 116 117=item -l 118 119Use C<local::lib>. 120 121=item -L author [ author ... ] 122 123List the modules by the specified authors. 124 125=item -m 126 127Make the specified modules. 128 129=item -O 130 131Show the out-of-date modules. 132 133=item -t 134 135Run a `make test` on the specified modules. 136 137=item -r 138 139Recompiles dynamically loaded modules with CPAN::Shell->recompile. 140 141=item -u 142 143Upgrade all installed modules. Blindly doing this can really break things, 144so keep a backup. 145 146=item -v 147 148Print the script version and CPAN.pm version then exit. 149 150=back 151 152=head2 Examples 153 154 # print a help message 155 cpan -h 156 157 # print the version numbers 158 cpan -v 159 160 # create an autobundle 161 cpan -a 162 163 # recompile modules 164 cpan -r 165 166 # upgrade all installed modules 167 cpan -u 168 169 # install modules ( sole -i is optional ) 170 cpan -i Netscape::Booksmarks Business::ISBN 171 172 # force install modules ( must use -i ) 173 cpan -fi CGI::Minimal URI 174 175 176=head2 Methods 177 178=over 4 179 180=cut 181 182use autouse Carp => qw(carp croak cluck); 183use CPAN (); 184use autouse Cwd => qw(cwd); 185use autouse 'Data::Dumper' => qw(Dumper); 186use File::Spec::Functions; 187use File::Basename; 188 189use Getopt::Std; 190 191# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 192# Internal constants 193use constant TRUE => 1; 194use constant FALSE => 0; 195 196 197# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 198# The return values 199use constant HEY_IT_WORKED => 0; 200use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001 201use constant ITS_NOT_MY_FAULT => 2; 202use constant THE_PROGRAMMERS_AN_IDIOT => 4; 203use constant A_MODULE_FAILED_TO_INSTALL => 8; 204 205 206# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 207# set up the order of options that we layer over CPAN::Shell 208BEGIN { # most of this should be in methods 209use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order 210 %Method_table %Method_table_index ); 211 212@META_OPTIONS = qw( h v g G C A D O l L a r j: J ); 213 214$Default = 'default'; 215 216%CPAN_METHODS = ( # map switches to method names in CPAN::Shell 217 $Default => 'install', 218 'c' => 'clean', 219 'f' => 'force', 220 'i' => 'install', 221 'm' => 'make', 222 't' => 'test', 223 'u' => 'upgrade', 224 ); 225@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS; 226 227@option_order = ( @META_OPTIONS, @CPAN_OPTIONS ); 228 229 230# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 231# map switches to the subroutines in this script, along with other information. 232# use this stuff instead of hard-coded indices and values 233sub NO_ARGS () { 0 } 234sub ARGS () { 1 } 235sub GOOD_EXIT () { 0 } 236 237%Method_table = ( 238# key => [ sub ref, takes args?, exit value, description ] 239 240 # options that do their thing first, then exit 241 h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ], 242 v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ], 243 244 # options that affect other options 245 j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ], 246 J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ], 247 F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ], 248 249 # options that do their one thing 250 g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ], 251 G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ], 252 253 C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ], 254 A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ], 255 D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ], 256 O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ], 257 258 l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ], 259 260 L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ], 261 a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ], 262 r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ], 263 u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ], 264 265 c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ], 266 f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ], 267 i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ], 268 'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ], 269 t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ], 270 271 ); 272 273%Method_table_index = ( 274 code => 0, 275 takes_args => 1, 276 exit_value => 2, 277 description => 3, 278 ); 279} 280 281# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 282# finally, do some argument processing 283 284sub _stupid_interface_hack_for_non_rtfmers 285 { 286 no warnings 'uninitialized'; 287 shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 ) 288 } 289 290sub _process_options 291 { 292 my %options; 293 294 # if no arguments, just drop into the shell 295 if( 0 == @ARGV ) { CPAN::shell(); exit 0 } 296 else 297 { 298 Getopt::Std::getopts( 299 join( '', @option_order ), \%options ); 300 \%options; 301 } 302 } 303 304sub _process_setup_options 305 { 306 my( $class, $options ) = @_; 307 308 if( $options->{j} ) 309 { 310 $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} ); 311 delete $options->{j}; 312 } 313 else 314 { 315 # this is what CPAN.pm would do otherwise 316 CPAN::HandleConfig->load( 317 # be_silent => 1, # candidate to be ripped out forever 318 write_file => 0, 319 ); 320 } 321 322 if( $options->{F} ) 323 { 324 $Method_table{F}[ $Method_table_index{code} ]->( $options->{F} ); 325 delete $options->{F}; 326 } 327 328 my $option_count = grep { $options->{$_} } @option_order; 329 no warnings 'uninitialized'; 330 $option_count -= $options->{'f'}; # don't count force 331 332 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 333 # if there are no options, set -i (this line fixes RT ticket 16915) 334 $options->{i}++ unless $option_count; 335 } 336 337 338=item run() 339 340Just do it. 341 342The C<run> method returns 0 on success and a postive number on 343failure. See the section on EXIT CODES for details on the values. 344 345=cut 346 347my $logger; 348 349sub run 350 { 351 my $class = shift; 352 353 my $return_value = HEY_IT_WORKED; # assume that things will work 354 355 $logger = $class->_init_logger; 356 $logger->debug( "Using logger from @{[ref $logger]}" ); 357 358 $class->_hook_into_CPANpm_report; 359 $logger->debug( "Hooked into output" ); 360 361 $class->_stupid_interface_hack_for_non_rtfmers; 362 $logger->debug( "Patched cargo culting" ); 363 364 my $options = $class->_process_options; 365 $logger->debug( "Options are @{[Dumper($options)]}" ); 366 367 $class->_process_setup_options( $options ); 368 369 OPTION: foreach my $option ( @option_order ) 370 { 371 next unless $options->{$option}; 372 373 my( $sub, $takes_args, $description ) = 374 map { $Method_table{$option}[ $Method_table_index{$_} ] } 375 qw( code takes_args ); 376 377 unless( ref $sub eq ref sub {} ) 378 { 379 $return_value = THE_PROGRAMMERS_AN_IDIOT; 380 last OPTION; 381 } 382 383 $logger->info( "$description -- ignoring other arguments" ) 384 if( @ARGV && ! $takes_args ); 385 386 $return_value = $sub->( \ @ARGV, $options ); 387 388 last; 389 } 390 391 return $return_value; 392 } 393 394{ 395package Local::Null::Logger; 396 397sub new { bless \ my $x, $_[0] } 398sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ if $ENV{CPAN_NULL_LOGGER} } 399sub DESTROY { 1 } 400} 401 402sub _init_logger 403 { 404 my $log4perl_loaded = eval "require Log::Log4perl; 1"; 405 406 unless( $log4perl_loaded ) 407 { 408 $logger = Local::Null::Logger->new; 409 return $logger; 410 } 411 412 my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO'; 413 414 Log::Log4perl::init( \ <<"HERE" ); 415log4perl.rootLogger=$LEVEL, A1 416log4perl.appender.A1=Log::Log4perl::Appender::Screen 417log4perl.appender.A1.layout=PatternLayout 418log4perl.appender.A1.layout.ConversionPattern=%m%n 419HERE 420 421 $logger = Log::Log4perl->get_logger( 'App::Cpan' ); 422 } 423 424# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 425 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 426# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 427 428sub _default 429 { 430 my( $args, $options ) = @_; 431 432 my $switch = ''; 433 434 # choose the option that we're going to use 435 # we'll deal with 'f' (force) later, so skip it 436 foreach my $option ( @CPAN_OPTIONS ) 437 { 438 next if $option eq 'f'; 439 next unless $options->{$option}; 440 $switch = $option; 441 last; 442 } 443 444 # 1. with no switches, but arguments, use the default switch (install) 445 # 2. with no switches and no args, start the shell 446 # 3. With a switch but no args, die! These switches need arguments. 447 if( not $switch and @$args ) { $switch = $Default; } 448 elsif( not $switch and not @$args ) { return CPAN::shell() } 449 elsif( $switch and not @$args ) 450 { die "Nothing to $CPAN_METHODS{$switch}!\n"; } 451 452 # Get and check the method from CPAN::Shell 453 my $method = $CPAN_METHODS{$switch}; 454 die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method ); 455 456 # call the CPAN::Shell method, with force if specified 457 my $action = do { 458 if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } } 459 else { sub { CPAN::Shell->$method( @_ ) } } 460 }; 461 462 # How do I handle exit codes for multiple arguments? 463 my $errors = 0; 464 465 foreach my $arg ( @$args ) 466 { 467 _clear_cpanpm_output(); 468 $action->( $arg ); 469 470 $errors += defined _cpanpm_output_indicates_failure(); 471 } 472 473 $errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED; 474 } 475 476# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 477 478=for comment 479 480CPAN.pm sends all the good stuff either to STDOUT. I have to intercept 481that output so I can find out what happened. 482 483=cut 484 485{ 486my $scalar = ''; 487 488sub _hook_into_CPANpm_report 489 { 490 no warnings 'redefine'; 491 492 *CPAN::Shell::myprint = sub { 493 my($self,$what) = @_; 494 $scalar .= $what if defined $what; 495 $self->print_ornamented($what, 496 $CPAN::Config->{colorize_print}||'bold blue on_white', 497 ); 498 }; 499 500 *CPAN::Shell::mywarn = sub { 501 my($self,$what) = @_; 502 $scalar .= $what if defined $what; 503 $self->print_ornamented($what, 504 $CPAN::Config->{colorize_warn}||'bold red on_white' 505 ); 506 }; 507 508 } 509 510sub _clear_cpanpm_output { $scalar = '' } 511 512sub _get_cpanpm_output { $scalar } 513 514BEGIN { 515my @skip_lines = ( 516 qr/^\QWarning \(usually harmless\)/, 517 qr/\bwill not store persistent state\b/, 518 qr(//hint//), 519 qr/^\s+reports\s+/, 520 ); 521 522sub _get_cpanpm_last_line 523 { 524 open my($fh), "<", \ $scalar; 525 526 my @lines = <$fh>; 527 528 # This is a bit ugly. Once we examine a line, we have to 529 # examine the line before it and go through all of the same 530 # regexes. I could do something fancy, but this works. 531 REGEXES: { 532 foreach my $regex ( @skip_lines ) 533 { 534 if( $lines[-1] =~ m/$regex/ ) 535 { 536 pop @lines; 537 redo REGEXES; # we have to go through all of them for every line! 538 } 539 } 540 } 541 542 $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" ); 543 544 $lines[-1]; 545 } 546} 547 548BEGIN { 549my $epic_fail_words = join '|', 550 qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? ); 551 552sub _cpanpm_output_indicates_failure 553 { 554 my $last_line = _get_cpanpm_last_line(); 555 556 my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i; 557 $result || (); 558 } 559} 560 561sub _cpanpm_output_indicates_success 562 { 563 my $last_line = _get_cpanpm_last_line(); 564 565 my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/; 566 $result || (); 567 } 568 569sub _cpanpm_output_is_vague 570 { 571 return FALSE if 572 _cpanpm_output_indicates_failure() || 573 _cpanpm_output_indicates_success(); 574 575 return TRUE; 576 } 577 578} 579 580# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 581sub _print_help 582 { 583 $logger->info( "Use perldoc to read the documentation" ); 584 exec "perldoc $0"; 585 } 586 587sub _print_version 588 { 589 $logger->info( 590 "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION ); 591 592 return HEY_IT_WORKED; 593 } 594 595sub _create_autobundle 596 { 597 $logger->info( 598 "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" ); 599 600 CPAN::Shell->autobundle; 601 602 return HEY_IT_WORKED; 603 } 604 605sub _recompile 606 { 607 $logger->info( "Recompiling dynamically-loaded extensions" ); 608 609 CPAN::Shell->recompile; 610 611 return HEY_IT_WORKED; 612 } 613 614sub _upgrade 615 { 616 $logger->info( "Upgrading all modules" ); 617 618 CPAN::Shell->upgrade(); 619 620 return HEY_IT_WORKED; 621 } 622 623sub _load_config # -j 624 { 625 my $file = shift || ''; 626 627 # should I clear out any existing config here? 628 $CPAN::Config = {}; 629 delete $INC{'CPAN/Config.pm'}; 630 croak( "Config file [$file] does not exist!\n" ) unless -e $file; 631 632 my $rc = eval "require '$file'"; 633 634 # CPAN::HandleConfig::require_myconfig_or_config looks for this 635 $INC{'CPAN/MyConfig.pm'} = 'fake out!'; 636 637 # CPAN::HandleConfig::load looks for this 638 $CPAN::Config_loaded = 'fake out'; 639 640 croak( "Could not load [$file]: $@\n") unless $rc; 641 642 return HEY_IT_WORKED; 643 } 644 645sub _dump_config 646 { 647 my $args = shift; 648 require Data::Dumper; 649 650 my $fh = $args->[0] || \*STDOUT; 651 652 my $dd = Data::Dumper->new( 653 [$CPAN::Config], 654 ['$CPAN::Config'] 655 ); 656 657 print $fh $dd->Dump, "\n1;\n__END__\n"; 658 659 return HEY_IT_WORKED; 660 } 661 662sub _lock_lobotomy 663 { 664 no warnings 'redefine'; 665 666 *CPAN::_flock = sub { 1 }; 667 *CPAN::checklock = sub { 1 }; 668 669 return HEY_IT_WORKED; 670 } 671 672sub _download 673 { 674 my $args = shift; 675 676 local $CPAN::DEBUG = 1; 677 678 my %paths; 679 680 foreach my $module ( @$args ) 681 { 682 $logger->info( "Checking $module" ); 683 my $path = CPAN::Shell->expand( "Module", $module )->cpan_file; 684 685 $logger->debug( "Inst file would be $path\n" ); 686 687 $paths{$module} = _get_file( _make_path( $path ) ); 688 } 689 690 return \%paths; 691 } 692 693sub _make_path { join "/", qw(authors id), $_[0] } 694 695sub _get_file 696 { 697 my $path = shift; 698 699 my $loaded = eval "require LWP::Simple; 1;"; 700 croak "You need LWP::Simple to use features that fetch files from CPAN\n" 701 unless $loaded; 702 703 my $file = substr $path, rindex( $path, '/' ) + 1; 704 my $store_path = catfile( cwd(), $file ); 705 $logger->debug( "Store path is $store_path" ); 706 707 foreach my $site ( @{ $CPAN::Config->{urllist} } ) 708 { 709 my $fetch_path = join "/", $site, $path; 710 $logger->debug( "Trying $fetch_path" ); 711 last if LWP::Simple::getstore( $fetch_path, $store_path ); 712 } 713 714 return $store_path; 715 } 716 717sub _gitify 718 { 719 my $args = shift; 720 721 my $loaded = eval "require Archive::Extract; 1;"; 722 croak "You need Archive::Extract to use features that gitify distributions\n" 723 unless $loaded; 724 725 my $starting_dir = cwd(); 726 727 foreach my $module ( @$args ) 728 { 729 $logger->info( "Checking $module" ); 730 my $path = CPAN::Shell->expand( "Module", $module )->cpan_file; 731 732 my $store_paths = _download( [ $module ] ); 733 $logger->debug( "gitify Store path is $store_paths->{$module}" ); 734 my $dirname = dirname( $store_paths->{$module} ); 735 736 my $ae = Archive::Extract->new( archive => $store_paths->{$module} ); 737 $ae->extract( to => $dirname ); 738 739 chdir $ae->extract_path; 740 741 my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git'; 742 croak "Could not find $git" unless -e $git; 743 croak "$git is not executable" unless -x $git; 744 745 # can we do this in Pure Perl? 746 system( $git, 'init' ); 747 system( $git, qw( add . ) ); 748 system( $git, qw( commit -a -m ), 'initial import' ); 749 } 750 751 chdir $starting_dir; 752 753 return HEY_IT_WORKED; 754 } 755 756sub _show_Changes 757 { 758 my $args = shift; 759 760 foreach my $arg ( @$args ) 761 { 762 $logger->info( "Checking $arg\n" ); 763 764 my $module = eval { CPAN::Shell->expand( "Module", $arg ) }; 765 my $out = _get_cpanpm_output(); 766 767 next unless eval { $module->inst_file }; 768 #next if $module->uptodate; 769 770 ( my $id = $module->id() ) =~ s/::/\-/; 771 772 my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" . 773 $id . "-" . $module->cpan_version() . "/"; 774 775 #print "URL: $url\n"; 776 _get_changes_file($url); 777 } 778 779 return HEY_IT_WORKED; 780 } 781 782sub _get_changes_file 783 { 784 croak "Reading Changes files requires LWP::Simple and URI\n" 785 unless eval "require LWP::Simple; require URI; 1"; 786 787 my $url = shift; 788 789 my $content = LWP::Simple::get( $url ); 790 $logger->info( "Got $url ..." ) if defined $content; 791 #print $content; 792 793 my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi; 794 795 my $changes_url = URI->new_abs( $change_link, $url ); 796 $logger->debug( "Change link is: $changes_url" ); 797 798 my $changes = LWP::Simple::get( $changes_url ); 799 800 print $changes; 801 802 return HEY_IT_WORKED; 803 } 804 805sub _show_Author 806 { 807 my $args = shift; 808 809 foreach my $arg ( @$args ) 810 { 811 my $module = CPAN::Shell->expand( "Module", $arg ); 812 unless( $module ) 813 { 814 $logger->info( "Didn't find a $arg module, so no author!" ); 815 next; 816 } 817 818 my $author = CPAN::Shell->expand( "Author", $module->userid ); 819 820 next unless $module->userid; 821 822 printf "%-25s %-8s %-25s %s\n", 823 $arg, $module->userid, $author->email, $author->fullname; 824 } 825 826 return HEY_IT_WORKED; 827 } 828 829sub _show_Details 830 { 831 my $args = shift; 832 833 foreach my $arg ( @$args ) 834 { 835 my $module = CPAN::Shell->expand( "Module", $arg ); 836 my $author = CPAN::Shell->expand( "Author", $module->userid ); 837 838 next unless $module->userid; 839 840 print "$arg\n", "-" x 73, "\n\t"; 841 print join "\n\t", 842 $module->description ? $module->description : "(no description)", 843 $module->cpan_file, 844 $module->inst_file, 845 'Installed: ' . $module->inst_version, 846 'CPAN: ' . $module->cpan_version . ' ' . 847 ($module->uptodate ? "" : "Not ") . "up to date", 848 $author->fullname . " (" . $module->userid . ")", 849 $author->email; 850 print "\n\n"; 851 852 } 853 854 return HEY_IT_WORKED; 855 } 856 857sub _show_out_of_date 858 { 859 my @modules = CPAN::Shell->expand( "Module", "/./" ); 860 861 printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN"; 862 print "-" x 73, "\n"; 863 864 foreach my $module ( @modules ) 865 { 866 next unless $module->inst_file; 867 next if $module->uptodate; 868 printf "%-40s %.4f %.4f\n", 869 $module->id, 870 $module->inst_version ? $module->inst_version : '', 871 $module->cpan_version; 872 } 873 874 return HEY_IT_WORKED; 875 } 876 877sub _show_author_mods 878 { 879 my $args = shift; 880 881 my %hash = map { lc $_, 1 } @$args; 882 883 my @modules = CPAN::Shell->expand( "Module", "/./" ); 884 885 foreach my $module ( @modules ) 886 { 887 next unless exists $hash{ lc $module->userid }; 888 print $module->id, "\n"; 889 } 890 891 return HEY_IT_WORKED; 892 } 893 894sub _list_all_mods 895 { 896 require File::Find; 897 898 my $args = shift; 899 900 901 my $fh = \*STDOUT; 902 903 INC: foreach my $inc ( @INC ) 904 { 905 my( $wanted, $reporter ) = _generator(); 906 File::Find::find( { wanted => $wanted }, $inc ); 907 908 my $count = 0; 909 FILE: foreach my $file ( @{ $reporter->() } ) 910 { 911 my $version = _parse_version_safely( $file ); 912 913 my $module_name = _path_to_module( $inc, $file ); 914 next FILE unless defined $module_name; 915 916 print $fh "$module_name\t$version\n"; 917 918 #last if $count++ > 5; 919 } 920 } 921 922 return HEY_IT_WORKED; 923 } 924 925sub _generator 926 { 927 my @files = (); 928 929 sub { push @files, 930 File::Spec->canonpath( $File::Find::name ) 931 if m/\A\w+\.pm\z/ }, 932 sub { \@files }, 933 } 934 935sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored 936 { 937 my( $file ) = @_; 938 939 local $/ = "\n"; 940 local $_; # don't mess with the $_ in the map calling this 941 942 return unless open FILE, "<$file"; 943 944 my $in_pod = 0; 945 my $version; 946 while( <FILE> ) 947 { 948 chomp; 949 $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod; 950 next if $in_pod || /^\s*#/; 951 952 next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; 953 my( $sigil, $var ) = ( $1, $2 ); 954 955 $version = _eval_version( $_, $sigil, $var ); 956 last; 957 } 958 close FILE; 959 960 return 'undef' unless defined $version; 961 962 return $version; 963 } 964 965sub _eval_version 966 { 967 my( $line, $sigil, $var ) = @_; 968 969 my $eval = qq{ 970 package ExtUtils::MakeMaker::_version; 971 972 local $sigil$var; 973 \$$var=undef; do { 974 $line 975 }; \$$var 976 }; 977 978 my $version = do { 979 local $^W = 0; 980 no strict; 981 eval( $eval ); 982 }; 983 984 return $version; 985 } 986 987sub _path_to_module 988 { 989 my( $inc, $path ) = @_; 990 return if length $path< length $inc; 991 992 my $module_path = substr( $path, length $inc ); 993 $module_path =~ s/\.pm\z//; 994 995 # XXX: this is cheating and doesn't handle everything right 996 my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path ); 997 shift @dirs; 998 999 my $module_name = join "::", @dirs; 1000 1001 return $module_name; 1002 } 1003 10041; 1005 1006=back 1007 1008=head1 EXIT VALUES 1009 1010The script exits with zero if it thinks that everything worked, or a 1011positive number if it thinks that something failed. Note, however, that 1012in some cases it has to divine a failure by the output of things it does 1013not control. For now, the exit codes are vague: 1014 1015 1 An unknown error 1016 1017 2 The was an external problem 1018 1019 4 There was an internal problem with the script 1020 1021 8 A module failed to install 1022 1023=head1 TO DO 1024 1025* There is initial support for Log4perl if it is available, but I 1026haven't gone through everything to make the NullLogger work out 1027correctly if Log4perl is not installed. 1028 1029* When I capture CPAN.pm output, I need to check for errors and 1030report them to the user. 1031 1032=head1 BUGS 1033 1034* none noted 1035 1036=head1 SEE ALSO 1037 1038Most behaviour, including environment variables and configuration, 1039comes directly from CPAN.pm. 1040 1041=head1 SOURCE AVAILABILITY 1042 1043This code is in Github: 1044 1045 git://github.com/briandfoy/cpan_script.git 1046 1047=head1 CREDITS 1048 1049Japheth Cleaver added the bits to allow a forced install (-f). 1050 1051Jim Brandt suggest and provided the initial implementation for the 1052up-to-date and Changes features. 1053 1054Adam Kennedy pointed out that exit() causes problems on Windows 1055where this script ends up with a .bat extension 1056 1057=head1 AUTHOR 1058 1059brian d foy, C<< <bdfoy@cpan.org> >> 1060 1061=head1 COPYRIGHT 1062 1063Copyright (c) 2001-2009, brian d foy, All Rights Reserved. 1064 1065You may redistribute this under the same terms as Perl itself. 1066 1067=cut 1068