This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Import CPAN.pm 1.94_53 from CPAN
[perl5.git] / cpan / CPAN / lib / App / Cpan.pm
CommitLineData
0124e695
JV
1package App::Cpan;
2use strict;
3use warnings;
4use vars qw($VERSION);
5
6$VERSION = '1.57';
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,
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: ", @_, $/ }
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, or to a temp
481file if $CPAN::Be_Silent is set. I have to intercept that output
482so I can find out what happened.
483
484=cut
485
486{
487my $scalar = '';
488
489sub _hook_into_CPANpm_report
490 {
491 no warnings 'redefine';
492
493 *CPAN::Shell::myprint = sub {
494 my($self,$what) = @_;
495 $scalar .= $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;
504 $self->print_ornamented($what,
505 $CPAN::Config->{colorize_warn}||'bold red on_white'
506 );
507 };
508
509 }
510
511sub _clear_cpanpm_output { $scalar = '' }
512
513sub _get_cpanpm_output { $scalar }
514
515BEGIN {
516my @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
523sub _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
549BEGIN {
550my $epic_fail_words = join '|',
551 qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? );
552
553sub _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
562sub _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
570sub _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# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
582sub _print_help
583 {
584 $logger->info( "Use perldoc to read the documentation" );
585 exec "perldoc $0";
586 }
587
588sub _print_version
589 {
590 $logger->info(
591 "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
592
593 return HEY_IT_WORKED;
594 }
595
596sub _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
606sub _recompile
607 {
608 $logger->info( "Recompiling dynamically-loaded extensions" );
609
610 CPAN::Shell->recompile;
611
612 return HEY_IT_WORKED;
613 }
614
615sub _upgrade
616 {
617 $logger->info( "Upgrading all modules" );
618
619 CPAN::Shell->upgrade();
620
621 return HEY_IT_WORKED;
622 }
623
624sub _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
646sub _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
663sub _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
673sub _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
694sub _make_path { join "/", qw(authors id), $_[0] }
695
696sub _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
718sub _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
757sub _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
783sub _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
806sub _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
830sub _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
858sub _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
878sub _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
895sub _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
926sub _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
936sub _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
966sub _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
988sub _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
10051;
1006
1007=back
1008
1009=head1 EXIT VALUES
1010
1011The script exits with zero if it thinks that everything worked, or a
1012positive number if it thinks that something failed. Note, however, that
1013in some cases it has to divine a failure by the output of things it does
1014not 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
1027haven't gone through everything to make the NullLogger work out
1028correctly if Log4perl is not installed.
1029
1030* When I capture CPAN.pm output, I need to check for errors and
1031report them to the user.
1032
1033=head1 BUGS
1034
1035* none noted
1036
1037=head1 SEE ALSO
1038
1039Most behaviour, including environment variables and configuration,
1040comes directly from CPAN.pm.
1041
1042=head1 SOURCE AVAILABILITY
1043
1044This code is in Github:
1045
1046 git://github.com/briandfoy/cpan_script.git
1047
1048=head1 CREDITS
1049
1050Japheth Cleaver added the bits to allow a forced install (-f).
1051
1052Jim Brandt suggest and provided the initial implementation for the
1053up-to-date and Changes features.
1054
1055Adam Kennedy pointed out that exit() causes problems on Windows
1056where this script ends up with a .bat extension
1057
1058=head1 AUTHOR
1059
1060brian d foy, C<< <bdfoy@cpan.org> >>
1061
1062=head1 COPYRIGHT
1063
1064Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
1065
1066You may redistribute this under the same terms as Perl itself.
1067
1068=cut