File Coverage

blib/lib/App/Cpan.pm
Criterion Covered Total %
statement 151 623 24.2
branch 17 210 8.1
condition 10 54 18.5
subroutine 48 109 44.0
pod 1 1 100.0
total 227 997 22.7


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