This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
hotfix App::Cpan
[perl5.git] / 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