cpan/CPAN/lib/App/Cpan.pm

   1 package App::Cpan;
   2 use strict;
   3 use warnings;
   4 use vars qw($VERSION);
   5
   6 $VERSION = '1.57';
   7
   8 =head1 NAME
   9
  10 App::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
  35 This script provides a command interface (not a shell) to CPAN. At the
  36 moment it uses CPAN.pm to do the work, but it is not a one-shot command
  37 runner for CPAN.pm.
  38
  39 =head2 Options
  40
  41 =over 4
  42
  43 =item -a
  44
  45 Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
  46
  47 =item -A module [ module ... ]
  48
  49 Shows the primary maintainers for the specified modules.
  50
  51 =item -c module
  52
  53 Runs a `make clean` in the specified module's directories.
  54
  55 =item -C module [ module ... ]
  56
  57 Show the F<Changes> files for the specified modules
  58
  59 =item -D module [ module ... ]
  60
  61 Show the module details. This prints one line for each out-of-date module
  62 (meaning, modules locally installed but have newer versions on CPAN).
  63 Each line has three columns: module name, local version, and CPAN
  64 version.
  65
  66 =item -f
  67
  68 Force the specified action, when it normally would have failed. Use this
  69 to 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
  76 Turn off CPAN.pm's attempts to lock anything. You should be careful with
  77 this since you might end up with multiple scripts trying to muck in the
  78 same directory. This isn't so much of a concern if you're loading a special
  79 config with C<-j>, and that config sets up its own work directories.
  80
  81 =item -g module [ module ... ]
  82
  83 Downloads to the current directory the latest distribution of the module.
  84
  85 =item -G module [ module ... ]
  86
  87 UNIMPLEMENTED
  88
  89 Download to the current directory the latest distribution of the
  90 modules, unpack each distribution, and create a git repository for each
  91 distribution.
  92
  93 If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
  94 distribution.
  95
  96 =item -h
  97
  98 Print a help message and exit. When you specify C<-h>, it ignores all
  99 of the other options and arguments.
 100
 101 =item -i
 102
 103 Install the specified modules.
 104
 105 =item -j Config.pm
 106
 107 Load the file that has the CPAN configuration data. This should have the
 108 same format as the standard F<CPAN/Config.pm> file, which defines
 109 C<$CPAN::Config> as an anonymous hash.
 110
 111 =item -J
 112
 113 Dump the configuration in the same format that CPAN.pm uses. This is useful
 114 for checking the configuration as well as using the dump as a starting point
 115 for a new, custom configuration.
 116
 117 =item -l
 118
 119 Use C<local::lib>.
 120
 121 =item -L author [ author ... ]
 122
 123 List the modules by the specified authors.
 124
 125 =item -m
 126
 127 Make the specified modules.
 128
 129 =item -O
 130
 131 Show the out-of-date modules.
 132
 133 =item -t
 134
 135 Run a `make test` on the specified modules.
 136
 137 =item -r
 138
 139 Recompiles dynamically loaded modules with CPAN::Shell->recompile.
 140
 141 =item -u
 142
 143 Upgrade all installed modules. Blindly doing this can really break things,
 144 so keep a backup.
 145
 146 =item -v
 147
 148 Print 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
 182 use autouse Carp => qw(carp croak cluck);
 183 use CPAN ();
 184 use autouse Cwd => qw(cwd);
 185 use autouse 'Data::Dumper' => qw(Dumper);
 186 use File::Spec::Functions;
 187 use File::Basename;
 188
 189 use Getopt::Std;
 190
 191 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 192 # Internal constants
 193 use constant TRUE  => 1;
 194 use constant FALSE => 0;
 195
 196
 197 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 198 # The return values
 199 use constant HEY_IT_WORKED              =>   0;
 200 use constant I_DONT_KNOW_WHAT_HAPPENED  =>   1; # 0b0000_0001
 201 use constant ITS_NOT_MY_FAULT           =>   2;
 202 use constant THE_PROGRAMMERS_AN_IDIOT   =>   4;
 203 use constant A_MODULE_FAILED_TO_INSTALL =>   8;
 204
 205
 206 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 207 # set up the order of options that we layer over CPAN::Shell
 208 BEGIN { # most of this should be in methods
 209 use 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
 233 sub NO_ARGS   () { 0 }
 234 sub ARGS      () { 1 }
 235 sub 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
 284 sub _stupid_interface_hack_for_non_rtfmers
 285         {
 286         no warnings 'uninitialized';
 287         shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
 288         }
 289
 290 sub _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
 304 sub _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,
 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
 340 Just do it.
 341
 342 The C<run> method returns 0 on success and a postive number on
 343 failure. See the section on EXIT CODES for details on the values.
 344
 345 =cut
 346
 347 my $logger;
 348
 349 sub 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 {
 395 package Local::Null::Logger;
 396
 397 sub new { bless \ my $x, $_[0] }
 398 sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ if $ENV{CPAN_NULL_LOGGER} }
 399 sub DESTROY { 1 }
 400 }
 401
 402 sub _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" );
 415 log4perl.rootLogger=$LEVEL, A1
 416 log4perl.appender.A1=Log::Log4perl::Appender::Screen
 417 log4perl.appender.A1.layout=PatternLayout
 418 log4perl.appender.A1.layout.ConversionPattern=%m%n
 419 HERE
 420
 421         $logger = Log::Log4perl->get_logger( 'App::Cpan' );
 422         }
 423
 424 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 425  # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 426 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 427
 428 sub _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
 480 CPAN.pm sends all the good stuff either to STDOUT, or to a temp
 481 file if $CPAN::Be_Silent is set. I have to intercept that output
 482 so I can find out what happened.
 483
 484 =cut
 485
 486 {
 487 my $scalar = '';
 488
 489 sub _hook_into_CPANpm_report
 490         {
 491         no warnings 'redefine';
 492
 493         *CPAN::Shell::myprint = sub {
 494                 my($self,$what) = @_;
 495                 $scalar .= $what if defined $what;
 496                 $self->print_ornamented($what,
 497                         $CPAN::Config->{colorize_print}||'bold blue on_white',
 498                         );
 499                 };
 500
 501         *CPAN::Shell::mywarn = sub {
 502                 my($self,$what) = @_;
 503                 $scalar .= $what if defined $what;
 504                 $self->print_ornamented($what,
 505                         $CPAN::Config->{colorize_warn}||'bold red on_white'
 506                         );
 507                 };
 508
 509         }
 510
 511 sub _clear_cpanpm_output { $scalar = '' }
 512
 513 sub _get_cpanpm_output   { $scalar }
 514
 515 BEGIN {
 516 my @skip_lines = (
 517         qr/^\QWarning \(usually harmless\)/,
 518         qr/\bwill not store persistent state\b/,
 519         qr(//hint//),
 520         qr/^\s+reports\s+/,
 521         );
 522
 523 sub _get_cpanpm_last_line
 524         {
 525         open my($fh), "<", \ $scalar;
 526
 527         my @lines = <$fh>;
 528
 529     # This is a bit ugly. Once we examine a line, we have to
 530     # examine the line before it and go through all of the same
 531     # regexes. I could do something fancy, but this works.
 532     REGEXES: {
 533         foreach my $regex ( @skip_lines )
 534                 {
 535                 if( $lines[-1] =~ m/$regex/ )
 536             {
 537             pop @lines;
 538             redo REGEXES; # we have to go through all of them for every line!
 539             }
 540                 }
 541     }
 542
 543     $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
 544
 545         $lines[-1];
 546         }
 547 }
 548
 549 BEGIN {
 550 my $epic_fail_words = join '|',
 551         qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? );
 552
 553 sub _cpanpm_output_indicates_failure
 554         {
 555         my $last_line = _get_cpanpm_last_line();
 556
 557         my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
 558         $result || ();
 559         }
 560 }
 561
 562 sub _cpanpm_output_indicates_success
 563         {
 564         my $last_line = _get_cpanpm_last_line();
 565
 566         my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
 567         $result || ();
 568         }
 569
 570 sub _cpanpm_output_is_vague
 571         {
 572         return FALSE if
 573                 _cpanpm_output_indicates_failure() ||
 574                 _cpanpm_output_indicates_success();
 575
 576         return TRUE;
 577         }
 578
 579 }
 580
 581 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
 582 sub _print_help
 583         {
 584         $logger->info( "Use perldoc to read the documentation" );
 585         exec "perldoc $0";
 586         }
 587
 588 sub _print_version
 589         {
 590         $logger->info(
 591                 "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
 592
 593         return HEY_IT_WORKED;
 594         }
 595
 596 sub _create_autobundle
 597         {
 598         $logger->info(
 599                 "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
 600
 601         CPAN::Shell->autobundle;
 602
 603         return HEY_IT_WORKED;
 604         }
 605
 606 sub _recompile
 607         {
 608         $logger->info( "Recompiling dynamically-loaded extensions" );
 609
 610         CPAN::Shell->recompile;
 611
 612         return HEY_IT_WORKED;
 613         }
 614
 615 sub _upgrade
 616         {
 617         $logger->info( "Upgrading all modules" );
 618
 619         CPAN::Shell->upgrade();
 620
 621         return HEY_IT_WORKED;
 622         }
 623
 624 sub _load_config # -j
 625         {
 626         my $file = shift || '';
 627
 628         # should I clear out any existing config here?
 629         $CPAN::Config = {};
 630         delete $INC{'CPAN/Config.pm'};
 631         croak( "Config file [$file] does not exist!\n" ) unless -e $file;
 632
 633         my $rc = eval "require '$file'";
 634
 635         # CPAN::HandleConfig::require_myconfig_or_config looks for this
 636         $INC{'CPAN/MyConfig.pm'} = 'fake out!';
 637
 638         # CPAN::HandleConfig::load looks for this
 639         $CPAN::Config_loaded = 'fake out';
 640
 641         croak( "Could not load [$file]: $@\n") unless $rc;
 642
 643         return HEY_IT_WORKED;
 644         }
 645
 646 sub _dump_config
 647         {
 648         my $args = shift;
 649         require Data::Dumper;
 650
 651         my $fh = $args->[0] || \*STDOUT;
 652
 653         my $dd = Data::Dumper->new(
 654                 [$CPAN::Config],
 655                 ['$CPAN::Config']
 656                 );
 657
 658         print $fh $dd->Dump, "\n1;\n__END__\n";
 659
 660         return HEY_IT_WORKED;
 661         }
 662
 663 sub _lock_lobotomy
 664         {
 665         no warnings 'redefine';
 666
 667         *CPAN::_flock    = sub { 1 };
 668         *CPAN::checklock = sub { 1 };
 669
 670         return HEY_IT_WORKED;
 671         }
 672
 673 sub _download
 674         {
 675         my $args = shift;
 676
 677         local $CPAN::DEBUG = 1;
 678
 679         my %paths;
 680
 681         foreach my $module ( @$args )
 682                 {
 683                 $logger->info( "Checking $module" );
 684                 my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
 685
 686                 $logger->debug( "Inst file would be $path\n" );
 687
 688                 $paths{$module} = _get_file( _make_path( $path ) );
 689                 }
 690
 691         return \%paths;
 692         }
 693
 694 sub _make_path { join "/", qw(authors id), $_[0] }
 695
 696 sub _get_file
 697         {
 698         my $path = shift;
 699
 700         my $loaded = eval "require LWP::Simple; 1;";
 701         croak "You need LWP::Simple to use features that fetch files from CPAN\n"
 702                 unless $loaded;
 703
 704         my $file = substr $path, rindex( $path, '/' ) + 1;
 705         my $store_path = catfile( cwd(), $file );
 706         $logger->debug( "Store path is $store_path" );
 707
 708         foreach my $site ( @{ $CPAN::Config->{urllist} } )
 709                 {
 710                 my $fetch_path = join "/", $site, $path;
 711                 $logger->debug( "Trying $fetch_path" );
 712             last if LWP::Simple::getstore( $fetch_path, $store_path );
 713                 }
 714
 715         return $store_path;
 716         }
 717
 718 sub _gitify
 719         {
 720         my $args = shift;
 721
 722         my $loaded = eval "require Archive::Extract; 1;";
 723         croak "You need Archive::Extract to use features that gitify distributions\n"
 724                 unless $loaded;
 725
 726         my $starting_dir = cwd();
 727
 728         foreach my $module ( @$args )
 729                 {
 730                 $logger->info( "Checking $module" );
 731                 my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
 732
 733                 my $store_paths = _download( [ $module ] );
 734                 $logger->debug( "gitify Store path is $store_paths->{$module}" );
 735                 my $dirname = dirname( $store_paths->{$module} );
 736
 737                 my $ae = Archive::Extract->new( archive => $store_paths->{$module} );
 738                 $ae->extract( to => $dirname );
 739
 740                 chdir $ae->extract_path;
 741
 742                 my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
 743                 croak "Could not find $git"    unless -e $git;
 744                 croak "$git is not executable" unless -x $git;
 745
 746                 # can we do this in Pure Perl?
 747                 system( $git, 'init'    );
 748                 system( $git, qw( add . ) );
 749                 system( $git, qw( commit -a -m ), 'initial import' );
 750                 }
 751
 752         chdir $starting_dir;
 753
 754         return HEY_IT_WORKED;
 755         }
 756
 757 sub _show_Changes
 758         {
 759         my $args = shift;
 760
 761         foreach my $arg ( @$args )
 762                 {
 763                 $logger->info( "Checking $arg\n" );
 764
 765                 my $module = eval { CPAN::Shell->expand( "Module", $arg ) };
 766                 my $out = _get_cpanpm_output();
 767
 768                 next unless eval { $module->inst_file };
 769                 #next if $module->uptodate;
 770
 771                 ( my $id = $module->id() ) =~ s/::/\-/;
 772
 773                 my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
 774                         $id . "-" . $module->cpan_version() . "/";
 775
 776                 #print "URL: $url\n";
 777                 _get_changes_file($url);
 778                 }
 779
 780         return HEY_IT_WORKED;
 781         }
 782
 783 sub _get_changes_file
 784         {
 785         croak "Reading Changes files requires LWP::Simple and URI\n"
 786                 unless eval "require LWP::Simple; require URI; 1";
 787
 788     my $url = shift;
 789
 790     my $content = LWP::Simple::get( $url );
 791     $logger->info( "Got $url ..." ) if defined $content;
 792         #print $content;
 793
 794         my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;
 795
 796         my $changes_url = URI->new_abs( $change_link, $url );
 797         $logger->debug( "Change link is: $changes_url" );
 798
 799         my $changes =  LWP::Simple::get( $changes_url );
 800
 801         print $changes;
 802
 803         return HEY_IT_WORKED;
 804         }
 805
 806 sub _show_Author
 807         {
 808         my $args = shift;
 809
 810         foreach my $arg ( @$args )
 811                 {
 812                 my $module = CPAN::Shell->expand( "Module", $arg );
 813                 unless( $module )
 814                         {
 815                         $logger->info( "Didn't find a $arg module, so no author!" );
 816                         next;
 817                         }
 818
 819                 my $author = CPAN::Shell->expand( "Author", $module->userid );
 820
 821                 next unless $module->userid;
 822
 823                 printf "%-25s %-8s %-25s %s\n",
 824                         $arg, $module->userid, $author->email, $author->fullname;
 825                 }
 826
 827         return HEY_IT_WORKED;
 828         }
 829
 830 sub _show_Details
 831         {
 832         my $args = shift;
 833
 834         foreach my $arg ( @$args )
 835                 {
 836                 my $module = CPAN::Shell->expand( "Module", $arg );
 837                 my $author = CPAN::Shell->expand( "Author", $module->userid );
 838
 839                 next unless $module->userid;
 840
 841                 print "$arg\n", "-" x 73, "\n\t";
 842                 print join "\n\t",
 843                         $module->description ? $module->description : "(no description)",
 844                         $module->cpan_file,
 845                         $module->inst_file,
 846                         'Installed: ' . $module->inst_version,
 847                         'CPAN:      ' . $module->cpan_version . '  ' .
 848                                 ($module->uptodate ? "" : "Not ") . "up to date",
 849                         $author->fullname . " (" . $module->userid . ")",
 850                         $author->email;
 851                 print "\n\n";
 852
 853                 }
 854
 855         return HEY_IT_WORKED;
 856         }
 857
 858 sub _show_out_of_date
 859         {
 860         my @modules = CPAN::Shell->expand( "Module", "/./" );
 861
 862         printf "%-40s  %6s  %6s\n", "Module Name", "Local", "CPAN";
 863         print "-" x 73, "\n";
 864
 865         foreach my $module ( @modules )
 866                 {
 867                 next unless $module->inst_file;
 868                 next if $module->uptodate;
 869                 printf "%-40s  %.4f  %.4f\n",
 870                         $module->id,
 871                         $module->inst_version ? $module->inst_version : '',
 872                         $module->cpan_version;
 873                 }
 874
 875         return HEY_IT_WORKED;
 876         }
 877
 878 sub _show_author_mods
 879         {
 880         my $args = shift;
 881
 882         my %hash = map { lc $_, 1 } @$args;
 883
 884         my @modules = CPAN::Shell->expand( "Module", "/./" );
 885
 886         foreach my $module ( @modules )
 887                 {
 888                 next unless exists $hash{ lc $module->userid };
 889                 print $module->id, "\n";
 890                 }
 891
 892         return HEY_IT_WORKED;
 893         }
 894
 895 sub _list_all_mods
 896         {
 897         require File::Find;
 898
 899         my $args = shift;
 900
 901
 902         my $fh = \*STDOUT;
 903
 904         INC: foreach my $inc ( @INC )
 905                 {
 906                 my( $wanted, $reporter ) = _generator();
 907                 File::Find::find( { wanted => $wanted }, $inc );
 908
 909                 my $count = 0;
 910                 FILE: foreach my $file ( @{ $reporter->() } )
 911                         {
 912                         my $version = _parse_version_safely( $file );
 913
 914                         my $module_name = _path_to_module( $inc, $file );
 915                         next FILE unless defined $module_name;
 916
 917                         print $fh "$module_name\t$version\n";
 918
 919                         #last if $count++ > 5;
 920                         }
 921                 }
 922
 923         return HEY_IT_WORKED;
 924         }
 925
 926 sub _generator
 927         {
 928         my @files = ();
 929
 930         sub { push @files,
 931                 File::Spec->canonpath( $File::Find::name )
 932                 if m/\A\w+\.pm\z/ },
 933         sub { \@files },
 934         }
 935
 936 sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
 937         {
 938         my( $file ) = @_;
 939
 940         local $/ = "\n";
 941         local $_; # don't mess with the $_ in the map calling this
 942
 943         return unless open FILE, "<$file";
 944
 945         my $in_pod = 0;
 946         my $version;
 947         while( <FILE> )
 948                 {
 949                 chomp;
 950                 $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
 951                 next if $in_pod || /^\s*#/;
 952
 953                 next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
 954                 my( $sigil, $var ) = ( $1, $2 );
 955
 956                 $version = _eval_version( $_, $sigil, $var );
 957                 last;
 958                 }
 959         close FILE;
 960
 961         return 'undef' unless defined $version;
 962
 963         return $version;
 964         }
 965
 966 sub _eval_version
 967         {
 968         my( $line, $sigil, $var ) = @_;
 969
 970         my $eval = qq{
 971                 package ExtUtils::MakeMaker::_version;
 972
 973                 local $sigil$var;
 974                 \$$var=undef; do {
 975                         $line
 976                         }; \$$var
 977                 };
 978
 979         my $version = do {
 980                 local $^W = 0;
 981                 no strict;
 982                 eval( $eval );
 983                 };
 984
 985         return $version;
 986         }
 987
 988 sub _path_to_module
 989         {
 990         my( $inc, $path ) = @_;
 991         return if length $path< length $inc;
 992
 993         my $module_path = substr( $path, length $inc );
 994         $module_path =~ s/\.pm\z//;
 995
 996         # XXX: this is cheating and doesn't handle everything right
 997         my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
 998         shift @dirs;
 999
1000         my $module_name = join "::", @dirs;
1001
1002         return $module_name;
1003         }
1004
1005 1;
1006
1007 =back
1008
1009 =head1 EXIT VALUES
1010
1011 The script exits with zero if it thinks that everything worked, or a
1012 positive number if it thinks that something failed. Note, however, that
1013 in some cases it has to divine a failure by the output of things it does
1014 not control. For now, the exit codes are vague:
1015
1016         1       An unknown error
1017
1018         2       The was an external problem
1019
1020         4       There was an internal problem with the script
1021
1022         8       A module failed to install
1023
1024 =head1 TO DO
1025
1026 * There is initial support for Log4perl if it is available, but I
1027 haven't gone through everything to make the NullLogger work out
1028 correctly if Log4perl is not installed.
1029
1030 * When I capture CPAN.pm output, I need to check for errors and
1031 report them to the user.
1032
1033 =head1 BUGS
1034
1035 * none noted
1036
1037 =head1 SEE ALSO
1038
1039 Most behaviour, including environment variables and configuration,
1040 comes directly from CPAN.pm.
1041
1042 =head1 SOURCE AVAILABILITY
1043
1044 This code is in Github:
1045
1046         git://github.com/briandfoy/cpan_script.git
1047
1048 =head1 CREDITS
1049
1050 Japheth Cleaver added the bits to allow a forced install (-f).
1051
1052 Jim Brandt suggest and provided the initial implementation for the
1053 up-to-date and Changes features.
1054
1055 Adam Kennedy pointed out that exit() causes problems on Windows
1056 where this script ends up with a .bat extension
1057
1058 =head1 AUTHOR
1059
1060 brian d foy, C<< <bdfoy@cpan.org> >>
1061
1062 =head1 COPYRIGHT
1063
1064 Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
1065
1066 You may redistribute this under the same terms as Perl itself.
1067
1068 =cut