File Coverage

blib/lib/App/Cpan.pm
Criterion Covered Total %
statement 151 617 24.4
branch 15 200 7.5
condition 10 56 17.8
subroutine 48 109 44.0
pod 1 1 100.0
total 225 983 22.8


line stmt bran cond sub pod time code
1             package App::Cpan;
2              
3 5     5   138372 use strict;
  5         30  
  5         147  
4 5     5   75 use warnings;
  5         10  
  5         178  
5 5     5   41 use vars qw($VERSION);
  5         8  
  5         324  
6              
7 5     5   3175 use if $] < 5.008 => 'IO::Scalar';
  5         67  
  5         30  
8              
9             $VERSION = '1.672';
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 Concensus: L
248              
249             Oslo Concensus: 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   2436 use autouse Carp => qw(carp croak cluck);
  5         3752  
  5         29  
290 5     5   4670 use CPAN 1.80 (); # needs no test
  5         245  
  5         602  
291 5     5   81 use Config;
  5         29  
  5         544  
292 5     5   47 use autouse Cwd => qw(cwd);
  5         22  
  5         65  
293 5     5   1076 use autouse 'Data::Dumper' => qw(Dumper);
  5         29  
  5         59  
294 5     5   4649 use File::Spec::Functions qw(catfile file_name_is_absolute rel2abs);
  5         6075  
  5         537  
295 5     5   52 use File::Basename;
  5         17  
  5         688  
296 5     5   11487 use Getopt::Std;
  5         294  
  5         411  
297              
298             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
299             # Internal constants
300 5     5   40 use constant TRUE => 1;
  5         16  
  5         712  
301 5     5   50 use constant FALSE => 0;
  5         26  
  5         312  
302              
303              
304             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
305             # The return values
306 5     5   41 use constant HEY_IT_WORKED => 0;
  5         23  
  5         323  
307 5     5   52 use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001
  5         21  
  5         297  
308 5     5   34 use constant ITS_NOT_MY_FAULT => 2;
  5         14  
  5         280  
309 5     5   46 use constant THE_PROGRAMMERS_AN_IDIOT => 4;
  5         22  
  5         254  
310 5     5   31 use constant A_MODULE_FAILED_TO_INSTALL => 8;
  5         12  
  5         377  
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         3575 use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order
317 5     5   41 %Method_table %Method_table_index );
  5         32  
318              
319 5     5   55 @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         166 %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         68 @CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
  45         112  
335              
336 5         54 @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         428 %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         288 %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   43 no warnings 'uninitialized';
  5         17  
  5         2591  
406 4 100 100 4   3487 shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
407             }
408              
409             sub _process_options
410             {
411 1     1   94 my %options;
412              
413 1   50     12 push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || '';
414              
415             # if no arguments, just drop into the shell
416 1 50       5 if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
  1         7  
  1         82  
417             else
418             {
419 0         0 Getopt::Std::getopts(
420             join( '', @option_order ), \%options );
421 0         0 \%options;
422             }
423             }
424              
425             sub _process_setup_options
426             {
427 0     0   0 my( $class, $options ) = @_;
428              
429 0 0       0 if( $options->{j} )
430             {
431 0         0 $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
432 0         0 delete $options->{j};
433             }
434             else
435             {
436             # this is what CPAN.pm would do otherwise
437 0         0 local $CPAN::Be_Silent = 1;
438 0         0 CPAN::HandleConfig->load(
439             # be_silent => 1, deprecated
440             write_file => 0,
441             );
442             }
443              
444 0 0       0 $class->_turn_off_testing if $options->{T};
445              
446 0         0 foreach my $o ( qw(F I w P M) )
447             {
448 0 0       0 next unless exists $options->{$o};
449 0         0 $Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} );
450 0         0 delete $options->{$o};
451             }
452              
453 0 0       0 if( $options->{o} )
454             {
455 0         0 my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o};
  0         0  
456 0         0 foreach my $pair ( @pairs )
457             {
458 0         0 my( $setting, $value ) = @$pair;
459 0         0 $CPAN::Config->{$setting} = $value;
460             # $logger->debug( "Setting [$setting] to [$value]" );
461             }
462 0         0 delete $options->{o};
463             }
464              
465 0         0 my $option_count = grep { $options->{$_} } @option_order;
  0         0  
466 5     5   39 no warnings 'uninitialized';
  5         10  
  5         7825  
467              
468             # don't count options that imply installation
469 0         0 foreach my $opt ( qw(f T) ) { # don't count force or notest
470 0         0 $option_count -= $options->{$opt};
471             }
472              
473             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
474             # if there are no options, set -i (this line fixes RT ticket 16915)
475 0 0       0 $options->{i}++ unless $option_count;
476             }
477              
478             sub _setup_environment {
479             # should we override or set defaults? If this were a true interactive
480             # session, we'd be in the CPAN shell.
481              
482             # https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
483 0 0   0   0 $ENV{NONINTERACTIVE_TESTING} = 1 unless defined $ENV{NONINTERACTIVE_TESTING};
484 0 0       0 $ENV{PERL_MM_USE_DEFAULT} = 1 unless defined $ENV{PERL_MM_USE_DEFAULT};
485             }
486              
487             =item run()
488              
489             Just do it.
490              
491             The C method returns 0 on success and a positive number on
492             failure. See the section on EXIT CODES for details on the values.
493              
494             =cut
495              
496             my $logger;
497              
498             sub run
499             {
500 0     0 1 0 my $class = shift;
501              
502 0         0 my $return_value = HEY_IT_WORKED; # assume that things will work
503              
504 0         0 $logger = $class->_init_logger;
505 0         0 $logger->debug( "Using logger from @{[ref $logger]}" );
  0         0  
506              
507 0         0 $class->_hook_into_CPANpm_report;
508 0         0 $logger->debug( "Hooked into output" );
509              
510 0         0 $class->_stupid_interface_hack_for_non_rtfmers;
511 0         0 $logger->debug( "Patched cargo culting" );
512              
513 0         0 my $options = $class->_process_options;
514 0         0 $logger->debug( "Options are @{[Dumper($options)]}" );
  0         0  
515              
516 0         0 $class->_process_setup_options( $options );
517              
518 0         0 $class->_setup_environment( $options );
519              
520 0         0 OPTION: foreach my $option ( @option_order )
521             {
522 0 0       0 next unless $options->{$option};
523              
524             my( $sub, $takes_args, $description ) =
525 0         0 map { $Method_table{$option}[ $Method_table_index{$_} ] }
  0         0  
526             qw( code takes_args description );
527              
528 0 0   0   0 unless( ref $sub eq ref sub {} )
529             {
530 0         0 $return_value = THE_PROGRAMMERS_AN_IDIOT;
531 0         0 last OPTION;
532             }
533              
534 0 0 0     0 $logger->info( "[$option] $description -- ignoring other arguments" )
535             if( @ARGV && ! $takes_args );
536              
537 0         0 $return_value = $sub->( \ @ARGV, $options );
538              
539 0         0 last;
540             }
541              
542 0         0 return $return_value;
543             }
544              
545             {
546             package
547             Local::Null::Logger; # hide from PAUSE
548              
549 2     2   14 sub new { bless \ my $x, $_[0] }
550             sub AUTOLOAD {
551 38     38   67 my $autoload = our $AUTOLOAD;
552 38         174 $autoload =~ s/.*://;
553 38 50       191 return if $autoload =~ /^(debug|trace)$/;
554             $CPAN::Frontend->mywarn(">($autoload): $_\n")
555 0         0 for split /[\r\n]+/, $_[1];
556             }
557 0     0   0 sub DESTROY { 1 }
558             }
559              
560             # load a module without searching the default entry for the current
561             # directory
562             sub _safe_load_module {
563 2     2   6 my $name = shift;
564              
565 2         40 local @INC = @INC;
566 2 50       27 pop @INC if $INC[-1] eq '.';
567              
568 2         185 eval "require $name; 1";
569             }
570              
571             sub _init_logger
572             {
573 2     2   1563 my $log4perl_loaded = _safe_load_module("Log::Log4perl");
574              
575 2 50       13 unless( $log4perl_loaded )
576             {
577 2         87 print STDOUT "Loading internal logger. Log::Log4perl recommended for better logging\n";
578 2         24 $logger = Local::Null::Logger->new;
579 2         75 return $logger;
580             }
581              
582 0   0     0 my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';
583              
584 0         0 Log::Log4perl::init( \ <<"HERE" );
585             log4perl.rootLogger=$LEVEL, A1
586             log4perl.appender.A1=Log::Log4perl::Appender::Screen
587             log4perl.appender.A1.layout=PatternLayout
588             log4perl.appender.A1.layout.ConversionPattern=%m%n
589             HERE
590              
591 0         0 $logger = Log::Log4perl->get_logger( 'App::Cpan' );
592             }
593              
594             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
595             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
596             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
597              
598             sub _default
599             {
600 0     0   0 my( $args, $options ) = @_;
601              
602 0         0 my $switch = '';
603              
604             # choose the option that we're going to use
605             # we'll deal with 'f' (force) later, so skip it
606 0         0 foreach my $option ( @CPAN_OPTIONS )
607             {
608 0 0 0     0 next if ( $option eq 'f' or $option eq 'T' );
609 0 0       0 next unless $options->{$option};
610 0         0 $switch = $option;
611 0         0 last;
612             }
613              
614             # 1. with no switches, but arguments, use the default switch (install)
615             # 2. with no switches and no args, start the shell
616             # 3. With a switch but no args, die! These switches need arguments.
617 0 0 0     0 if( not $switch and @$args ) { $switch = $Default; }
  0 0 0     0  
    0 0        
618 0         0 elsif( not $switch and not @$args ) { return CPAN::shell() }
619             elsif( $switch and not @$args )
620 0         0 { die "Nothing to $CPAN_METHODS{$switch}!\n"; }
621              
622             # Get and check the method from CPAN::Shell
623 0         0 my $method = $CPAN_METHODS{$switch};
624 0 0       0 die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method );
625              
626             # call the CPAN::Shell method, with force or notest if specified
627 0         0 my $action = do {
628 0 0   0   0 if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } }
  0 0       0  
  0         0  
629 0     0   0 elsif( $options->{T} ) { sub { CPAN::Shell->notest( $method, @_ ) } }
  0         0  
630 0     0   0 else { sub { CPAN::Shell->$method( @_ ) } }
  0         0  
631             };
632              
633             # How do I handle exit codes for multiple arguments?
634 0         0 my @errors = ();
635              
636 0 0       0 $options->{x} or _disable_guessers();
637              
638 0         0 foreach my $arg ( @$args )
639             {
640             # check the argument and perhaps capture typos
641 0 0       0 my $module = _expand_module( $arg ) or do {
642 0         0 $logger->error( "Skipping $arg because I couldn't find a matching namespace." );
643 0         0 next;
644             };
645              
646 0         0 _clear_cpanpm_output();
647 0         0 $action->( $arg );
648              
649 0         0 my $error = _cpanpm_output_indicates_failure();
650 0 0       0 push @errors, $error if $error;
651             }
652              
653 0         0 return do {
654 0 0       0 if( @errors ) { $errors[0] }
  0         0  
655 0         0 else { HEY_IT_WORKED }
656             };
657              
658             }
659              
660             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
661              
662             =for comment
663              
664             CPAN.pm sends all the good stuff either to STDOUT, or to a temp
665             file if $CPAN::Be_Silent is set. I have to intercept that output
666             so I can find out what happened.
667              
668             =cut
669              
670 0         0 BEGIN {
671 5     5   30 my $scalar = '';
672              
673             sub _hook_into_CPANpm_report
674             {
675 5     5   51 no warnings 'redefine';
  5         13  
  5         2874  
676              
677             *CPAN::Shell::myprint = sub {
678 18     18   1825 my($self,$what) = @_;
679 18         33 $scalar .= $what;
680             $self->print_ornamented($what,
681 18   100     84 $CPAN::Config->{colorize_print}||'bold blue on_white',
682             );
683 1     1   4210 };
684              
685             *CPAN::Shell::mywarn = sub {
686 14     14   582 my($self,$what) = @_;
687 14         34 $scalar .= $what;
688             $self->print_ornamented($what,
689 14   100     85 $CPAN::Config->{colorize_warn}||'bold red on_white'
690             );
691 1         28 };
692              
693             }
694              
695 8     8   5190 sub _clear_cpanpm_output { $scalar = '' }
696              
697 11     11   50 sub _get_cpanpm_output { $scalar }
698              
699             # These are lines I don't care about in CPAN.pm output. If I can
700             # filter out the informational noise, I have a better chance to
701             # catch the error signal
702 5         753 my @skip_lines = (
703             qr/^\QWarning \(usually harmless\)/,
704             qr/\bwill not store persistent state\b/,
705             qr(//hint//),
706             qr/^\s+reports\s+/,
707             qr/^Try the command/,
708             qr/^\s+$/,
709             qr/^to find objects/,
710             qr/^\s*Database was generated on/,
711             qr/^Going to read/,
712             qr|^\s+i\s+/|, # the i /Foo::Whatever/ line when it doesn't know
713             );
714              
715             sub _get_cpanpm_last_line
716             {
717 29     29   90 my $fh;
718              
719 29 50       70 if( $] < 5.008 ) {
720 0         0 $fh = IO::Scalar->new( \ $scalar );
721             }
722             else {
723 1     1   8 eval q{ open $fh, '<', \\ $scalar; };
  1         2  
  1         17  
  29         1924  
724             }
725              
726 29         1320 my @lines = <$fh>;
727              
728             # This is a bit ugly. Once we examine a line, we have to
729             # examine the line before it and go through all of the same
730             # regexes. I could do something fancy, but this works.
731             REGEXES: {
732 29         61 foreach my $regex ( @skip_lines )
  38         78  
733             {
734 314 100       1015 if( $lines[-1] =~ m/$regex/ )
735             {
736 9         17 pop @lines;
737 9         18 redo REGEXES; # we have to go through all of them for every line!
738             }
739             }
740             }
741              
742 29         208 $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
743              
744 29         165 $lines[-1];
745             }
746             }
747              
748 0         0 BEGIN {
749 5     5   5852 my $epic_fail_words = join '|',
750             qw( Error stop(?:ping)? problems force not unsupported
751             fail(?:ed)? Cannot\s+install );
752              
753             sub _cpanpm_output_indicates_failure
754             {
755 9     9   5343 my $last_line = _get_cpanpm_last_line();
756              
757 9         145 my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
758 9 50       40 return A_MODULE_FAILED_TO_INSTALL if $last_line =~ /\b(?:Cannot\s+install)\b/i;
759              
760 9 100       44 $result || ();
761             }
762             }
763              
764             sub _cpanpm_output_indicates_success
765             {
766 9     9   4642 my $last_line = _get_cpanpm_last_line();
767              
768 9         48 my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
769 9 100       41 $result || ();
770             }
771              
772             sub _cpanpm_output_is_vague
773             {
774 0 0 0 0   0 return FALSE if
775             _cpanpm_output_indicates_failure() ||
776             _cpanpm_output_indicates_success();
777              
778 0         0 return TRUE;
779             }
780              
781             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
782             sub _turn_on_warnings {
783 0     0   0 carp "Warnings are implemented yet";
784 0         0 return HEY_IT_WORKED;
785             }
786              
787             sub _turn_off_testing {
788 0     0   0 $logger->debug( 'Trusting test report history' );
789 0         0 $CPAN::Config->{trust_test_report_history} = 1;
790 0         0 return HEY_IT_WORKED;
791             }
792              
793             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
794             sub _print_help
795             {
796 0     0   0 $logger->info( "Use perldoc to read the documentation" );
797 0         0 exec "perldoc $0";
798             }
799              
800             sub _print_version # -v
801             {
802 0     0   0 $logger->info(
803             "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
804              
805 0         0 return HEY_IT_WORKED;
806             }
807              
808             sub _print_details # -V
809             {
810 0     0   0 _print_version();
811              
812 0         0 _check_install_dirs();
813              
814 0         0 $logger->info( '-' x 50 . "\nChecking configured mirrors..." );
815 0         0 foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) {
  0         0  
816 0         0 _print_ping_report( $mirror );
817             }
818              
819 0         0 $logger->info( '-' x 50 . "\nChecking for faster mirrors..." );
820              
821             {
822 0         0 require CPAN::Mirrors;
  0         0  
823              
824 0 0       0 if ( $CPAN::Config->{connect_to_internet_ok} ) {
825 0         0 $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
826 0 0       0 eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) }
  0         0  
827             or $CPAN::Frontend->mywarn(<<'HERE');
828             We failed to get a copy of the mirror list from the Internet.
829             You will need to provide CPAN mirror URLs yourself.
830             HERE
831 0         0 $CPAN::Frontend->myprint("\n");
832             }
833              
834 0         0 my $mirrors = CPAN::Mirrors->new( _mirror_file() );
835 0         0 my @continents = $mirrors->find_best_continents;
836              
837 0         0 my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] );
838 0         0 my @timings = $mirrors->get_mirrors_timings( \@mirrors );
839              
840 0         0 foreach my $timing ( @timings ) {
841 0         0 $logger->info( sprintf "%s (%0.2f ms)",
842             $timing->hostname, $timing->rtt );
843             }
844             }
845              
846 0         0 return HEY_IT_WORKED;
847             }
848              
849             sub _check_install_dirs
850             {
851 0     0   0 my $makepl_arg = $CPAN::Config->{makepl_arg};
852 0         0 my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg};
853              
854 0         0 my @custom_dirs;
855             # PERL_MM_OPT
856 0         0 push @custom_dirs,
857             $makepl_arg =~ m/INSTALL_BASE\s*=\s*(\S+)/g,
858             $mbuildpl_arg =~ m/--install_base\s*=\s*(\S+)/g;
859              
860 0 0       0 if( @custom_dirs ) {
861 0         0 foreach my $dir ( @custom_dirs ) {
862 0         0 _print_inc_dir_report( $dir );
863             }
864             }
865              
866             # XXX: also need to check makepl_args, etc
867              
868             my @checks = (
869             [ 'core', [ grep $_, @Config{qw(installprivlib installarchlib)} ] ],
870             [ 'vendor', [ grep $_, @Config{qw(installvendorlib installvendorarch)} ] ],
871             [ 'site', [ grep $_, @Config{qw(installsitelib installsitearch)} ] ],
872             [ 'PERL5LIB', _split_paths( $ENV{PERL5LIB} ) ],
873 0         0 [ 'PERLLIB', _split_paths( $ENV{PERLLIB} ) ],
874             );
875              
876 0         0 $logger->info( '-' x 50 . "\nChecking install dirs..." );
877 0         0 foreach my $tuple ( @checks ) {
878 0         0 my( $label ) = $tuple->[0];
879              
880 0         0 $logger->info( "Checking $label" );
881 0 0       0 $logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] };
  0         0  
882 0         0 foreach my $dir ( @{ $tuple->[1] } ) {
  0         0  
883 0         0 _print_inc_dir_report( $dir );
884             }
885             }
886              
887             }
888              
889             sub _split_paths
890             {
891 0   0 0   0 [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
  0         0  
892             }
893              
894              
895             =pod
896              
897             Stolen from File::Path::Expand
898              
899             =cut
900              
901             sub _expand_filename
902             {
903 9     9   4866 my( $path ) = @_;
904 5     5   53 no warnings 'uninitialized';
  5         13  
  5         8397  
905 9         111 $logger->debug( "Expanding path $path\n" );
906 9         32 $path =~ s{\A~([^/]+)?}{
907 3 50 66     28 _home_of( $1 || $> ) || "~$1"
908             }e;
909 9         65 return $path;
910             }
911              
912             sub _home_of
913             {
914 0     0     require User::pwent;
915 0           my( $user ) = @_;
916 0 0         my $ent = User::pwent::getpw($user) or return;
917 0           return $ent->dir;
918             }
919              
920             sub _get_default_inc
921             {
922 0     0     require Config;
923              
924 0           [ @Config::Config{ _vars() }, '.' ];
925             }
926              
927             sub _vars {
928 0     0     qw(
929             installarchlib
930             installprivlib
931             installsitearch
932             installsitelib
933             );
934             }
935              
936             sub _ping_mirrors {
937 0     0     my $urls = $CPAN::Config->{urllist};
938 0           require URI;
939              
940 0           foreach my $url ( @$urls ) {
941 0           my( $obj ) = URI->new( $url );
942 0 0         next unless _is_pingable_scheme( $obj );
943 0           my $host = $obj->host;
944 0           _print_ping_report( $obj );
945             }
946              
947             }
948              
949             sub _is_pingable_scheme {
950 0     0     my( $uri ) = @_;
951              
952 0           $uri->scheme eq 'file'
953             }
954              
955             sub _mirror_file {
956 0     0     my $file = do {
957 0           my $file = 'MIRRORED.BY';
958             my $local_path = File::Spec->catfile(
959 0           $CPAN::Config->{keep_source_where}, $file );
960              
961 0 0         if( -e $local_path ) { $local_path }
  0            
962             else {
963 0           require CPAN::FTP;
964 0           CPAN::FTP->localize( $file, $local_path, 3, 1 );
965 0           $local_path;
966             }
967             };
968             }
969              
970             sub _find_good_mirrors {
971 0     0     require CPAN::Mirrors;
972              
973 0           my $mirrors = CPAN::Mirrors->new( _mirror_file() );
974              
975 0           my @mirrors = $mirrors->best_mirrors(
976             how_many => 5,
977             verbose => 1,
978             );
979              
980 0           foreach my $mirror ( @mirrors ) {
981 0 0         next unless eval { $mirror->can( 'http' ) };
  0            
982 0           _print_ping_report( $mirror->http );
983             }
984              
985             $CPAN::Config->{urllist} = [
986 0           map { $_->http } @mirrors
  0            
987             ];
988             }
989              
990             sub _print_inc_dir_report
991             {
992 0     0     my( $dir ) = shift;
993              
994 0 0         my $writeable = -w $dir ? '+' : '!!! (not writeable)';
995 0           $logger->info( "\t$writeable $dir" );
996 0           return -w $dir;
997             }
998              
999             sub _print_ping_report
1000             {
1001 0     0     my( $mirror ) = @_;
1002              
1003 0           my $rtt = eval { _get_ping_report( $mirror ) };
  0            
1004 0 0         my $result = $rtt ? sprintf "+ (%4d ms)", $rtt * 1000 : '!';
1005              
1006 0           $logger->info(
1007             sprintf "\t%s %s", $result, $mirror
1008             );
1009             }
1010              
1011             sub _get_ping_report
1012             {
1013 0     0     require URI;
1014 0           my( $mirror ) = @_;
1015 0 0         my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX
1016 0           require Net::Ping;
1017              
1018 0           my $ping = Net::Ping->new( 'tcp', 1 );
1019              
1020 0 0         if( $url->scheme eq 'file' ) {
1021 0           return -e $url->file;
1022             }
1023              
1024 0           my( $port ) = $url->port;
1025              
1026 0 0         return unless $port;
1027              
1028 0 0         if ( $ping->can('port_number') ) {
1029 0           $ping->port_number($port);
1030             }
1031             else {
1032 0           $ping->{'port_num'} = $port;
1033             }
1034              
1035 0 0         $ping->hires(1) if $ping->can( 'hires' );
1036 0           my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) };
  0            
1037 0 0         $alive ? $rtt : undef;
1038             }
1039              
1040             sub _load_local_lib # -I
1041             {
1042 0     0     $logger->debug( "Loading local::lib" );
1043              
1044 0           my $rc = _safe_load_module("local::lib");
1045 0 0         unless( $rc ) {
1046 0           $logger->logdie( "Could not load local::lib" );
1047             }
1048              
1049 0           local::lib->import;
1050              
1051 0           return HEY_IT_WORKED;
1052             }
1053              
1054             sub _use_these_mirrors # -M
1055             {
1056 0     0     $logger->debug( "Setting per session mirrors" );
1057 0 0         unless( $_[0] ) {
1058 0           $logger->logdie( "The -M switch requires a comma-separated list of mirrors" );
1059             }
1060              
1061 0           $CPAN::Config->{urllist} = [ split /,/, $_[0] ];
1062              
1063 0           $logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" );
  0            
1064              
1065             }
1066              
1067             sub _create_autobundle
1068             {
1069 0     0     $logger->info(
1070             "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
1071              
1072 0           CPAN::Shell->autobundle;
1073              
1074 0           return HEY_IT_WORKED;
1075             }
1076              
1077             sub _recompile
1078             {
1079 0     0     $logger->info( "Recompiling dynamically-loaded extensions" );
1080              
1081 0           CPAN::Shell->recompile;
1082              
1083 0           return HEY_IT_WORKED;
1084             }
1085              
1086             sub _upgrade
1087             {
1088 0     0     $logger->info( "Upgrading all modules" );
1089              
1090 0           CPAN::Shell->upgrade();
1091              
1092 0           return HEY_IT_WORKED;
1093             }
1094              
1095             sub _shell
1096             {
1097 0     0     $logger->info( "Dropping into shell" );
1098              
1099 0           CPAN::shell();
1100              
1101 0           return HEY_IT_WORKED;
1102             }
1103              
1104             sub _load_config # -j
1105             {
1106 0     0     my $argument = shift;
1107              
1108 0 0         my $file = file_name_is_absolute( $argument ) ? $argument : rel2abs( $argument );
1109 0 0         croak( "cpan config file [$file] for -j does not exist!\n" ) unless -e $file;
1110              
1111             # should I clear out any existing config here?
1112 0           $CPAN::Config = {};
1113 0           delete $INC{'CPAN/Config.pm'};
1114              
1115 0           my $rc = eval "require '$file'";
1116              
1117             # CPAN::HandleConfig::require_myconfig_or_config looks for this
1118 0           $INC{'CPAN/MyConfig.pm'} = 'fake out!';
1119              
1120             # CPAN::HandleConfig::load looks for this
1121 0           $CPAN::Config_loaded = 'fake out';
1122              
1123 0 0         croak( "Could not load [$file]: $@\n") unless $rc;
1124              
1125 0           return HEY_IT_WORKED;
1126             }
1127              
1128             sub _dump_config # -J
1129             {
1130 0     0     my $args = shift;
1131 0           require Data::Dumper;
1132              
1133 0   0       my $fh = $args->[0] || \*STDOUT;
1134              
1135 0           local $Data::Dumper::Sortkeys = 1;
1136 0           my $dd = Data::Dumper->new(
1137             [$CPAN::Config],
1138             ['$CPAN::Config']
1139             );
1140              
1141 0           print $fh $dd->Dump, "\n1;\n__END__\n";
1142              
1143 0           return HEY_IT_WORKED;
1144             }
1145              
1146             sub _lock_lobotomy # -F
1147             {
1148 5     5   76 no warnings 'redefine';
  5         16  
  5         8246  
1149              
1150 0     0     *CPAN::_flock = sub { 1 };
  0     0      
1151 0     0     *CPAN::checklock = sub { 1 };
  0            
1152              
1153 0           return HEY_IT_WORKED;
1154             }
1155              
1156             sub _download
1157             {
1158 0     0     my $args = shift;
1159              
1160 0           local $CPAN::DEBUG = 1;
1161              
1162 0           my %paths;
1163              
1164 0           foreach my $arg ( @$args ) {
1165 0           $logger->info( "Checking $arg" );
1166              
1167 0 0         my $module = _expand_module( $arg ) or next;
1168 0           my $path = $module->cpan_file;
1169              
1170 0           $logger->debug( "Inst file would be $path\n" );
1171              
1172 0           $paths{$module} = _get_file( _make_path( $path ) );
1173              
1174 0           $logger->info( "Downloaded [$arg] to [$paths{$arg}]" );
1175             }
1176              
1177 0           return \%paths;
1178             }
1179              
1180 0     0     sub _make_path { join "/", qw(authors id), $_[0] }
1181              
1182             sub _get_file
1183             {
1184 0     0     my $path = shift;
1185              
1186 0           my $loaded = _safe_load_module("LWP::Simple");
1187 0 0         croak "You need LWP::Simple to use features that fetch files from CPAN\n"
1188             unless $loaded;
1189              
1190 0           my $file = substr $path, rindex( $path, '/' ) + 1;
1191 0           my $store_path = catfile( cwd(), $file );
1192 0           $logger->debug( "Store path is $store_path" );
1193              
1194 0           foreach my $site ( @{ $CPAN::Config->{urllist} } )
  0            
1195             {
1196 0           my $fetch_path = join "/", $site, $path;
1197 0           $logger->debug( "Trying $fetch_path" );
1198 0           my $status_code = LWP::Simple::getstore( $fetch_path, $store_path );
1199 0 0 0       last if( 200 <= $status_code and $status_code <= 300 );
1200 0           $logger->warn( "Could not get [$fetch_path]: Status code $status_code" );
1201             }
1202              
1203 0           return $store_path;
1204             }
1205              
1206             sub _gitify
1207             {
1208 0     0     my $args = shift;
1209              
1210 0           my $loaded = _safe_load_module("Archive::Extract");
1211 0 0         croak "You need Archive::Extract to use features that gitify distributions\n"
1212             unless $loaded;
1213              
1214 0           my $starting_dir = cwd();
1215              
1216 0           foreach my $arg ( @$args )
1217             {
1218 0           $logger->info( "Checking $arg" );
1219 0           my $store_paths = _download( [ $arg ] );
1220 0           $logger->debug( "gitify Store path is $store_paths->{$arg}" );
1221 0           my $dirname = dirname( $store_paths->{$arg} );
1222              
1223 0           my $ae = Archive::Extract->new( archive => $store_paths->{$arg} );
1224 0           $ae->extract( to => $dirname );
1225              
1226 0           chdir $ae->extract_path;
1227              
1228 0   0       my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
1229 0 0         croak "Could not find $git" unless -e $git;
1230 0 0         croak "$git is not executable" unless -x $git;
1231              
1232             # can we do this in Pure Perl?
1233 0           system( $git, 'init' );
1234 0           system( $git, qw( add . ) );
1235 0           system( $git, qw( commit -a -m ), 'initial import' );
1236             }
1237              
1238 0           chdir $starting_dir;
1239              
1240 0           return HEY_IT_WORKED;
1241             }
1242              
1243             sub _show_Changes
1244             {
1245 0     0     my $args = shift;
1246              
1247 0           foreach my $arg ( @$args )
1248             {
1249 0           $logger->info( "Checking $arg\n" );
1250              
1251 0 0         my $module = _expand_module( $arg ) or next;
1252              
1253 0           my $out = _get_cpanpm_output();
1254              
1255 0 0         next unless eval { $module->inst_file };
  0            
1256             #next if $module->uptodate;
1257              
1258 0           ( my $id = $module->id() ) =~ s/::/\-/;
1259              
1260 0           my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
1261             $id . "-" . $module->cpan_version() . "/";
1262              
1263             #print "URL: $url\n";
1264 0           _get_changes_file($url);
1265             }
1266              
1267 0           return HEY_IT_WORKED;
1268             }
1269              
1270             sub _get_changes_file
1271             {
1272 0 0 0 0     croak "Reading Changes files requires LWP::Simple and URI\n"
1273             unless _safe_load_module("LWP::Simple") && _safe_load_module("URI");
1274              
1275 0           my $url = shift;
1276              
1277 0           my $content = LWP::Simple::get( $url );
1278 0 0         $logger->info( "Got $url ..." ) if defined $content;
1279             #print $content;
1280              
1281 0           my( $change_link ) = $content =~ m|Changes|gi;
1282              
1283 0           my $changes_url = URI->new_abs( $change_link, $url );
1284 0           $logger->debug( "Change link is: $changes_url" );
1285              
1286 0           my $changes = LWP::Simple::get( $changes_url );
1287              
1288 0           print $changes;
1289              
1290 0           return HEY_IT_WORKED;
1291             }
1292              
1293             sub _show_Author
1294             {
1295 0     0     my $args = shift;
1296              
1297 0           foreach my $arg ( @$args )
1298             {
1299 0 0         my $module = _expand_module( $arg ) or next;
1300              
1301 0 0         unless( $module )
1302             {
1303 0           $logger->info( "Didn't find a $arg module, so no author!" );
1304 0           next;
1305             }
1306              
1307 0           my $author = CPAN::Shell->expand( "Author", $module->userid );
1308              
1309 0 0         next unless $module->userid;
1310              
1311 0           printf "%-25s %-8s %-25s %s\n",
1312             $arg, $module->userid, $author->email, $author->name;
1313             }
1314              
1315 0           return HEY_IT_WORKED;
1316             }
1317              
1318             sub _show_Details
1319             {
1320 0     0     my $args = shift;
1321              
1322 0           foreach my $arg ( @$args )
1323             {
1324 0 0         my $module = _expand_module( $arg ) or next;
1325 0           my $author = CPAN::Shell->expand( "Author", $module->userid );
1326              
1327 0 0         next unless $module->userid;
1328              
1329 0           print "$arg\n", "-" x 73, "\n\t";
1330 0 0         print join "\n\t",
    0          
    0          
    0          
    0          
1331             $module->description ? $module->description : "(no description)",
1332             $module->cpan_file ? $module->cpan_file : "(no cpanfile)",
1333             $module->inst_file ? $module->inst_file :"(no installation file)" ,
1334             'Installed: ' . ($module->inst_version ? $module->inst_version : "not installed"),
1335             'CPAN: ' . $module->cpan_version . ' ' .
1336             ($module->uptodate ? "" : "Not ") . "up to date",
1337             $author->fullname . " (" . $module->userid . ")",
1338             $author->email;
1339 0           print "\n\n";
1340              
1341             }
1342              
1343 0           return HEY_IT_WORKED;
1344             }
1345              
1346 0         0 BEGIN {
1347 5     5   4847 my $modules;
1348             sub _get_all_namespaces
1349             {
1350 0 0   0     return $modules if $modules;
1351 0           $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
  0            
1352             }
1353             }
1354              
1355             sub _show_out_of_date
1356             {
1357 0     0     my $modules = _get_all_namespaces();
1358              
1359 0           printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
1360 0           print "-" x 73, "\n";
1361              
1362 0           foreach my $module ( @$modules )
1363             {
1364 0 0         next unless $module = _expand_module($module);
1365 0 0         next unless $module->inst_file;
1366 0 0         next if $module->uptodate;
1367 0 0         printf "%-40s %.4f %.4f\n",
1368             $module->id,
1369             $module->inst_version ? $module->inst_version : '',
1370             $module->cpan_version;
1371             }
1372              
1373 0           return HEY_IT_WORKED;
1374             }
1375              
1376             sub _show_author_mods
1377             {
1378 0     0     my $args = shift;
1379              
1380 0           my %hash = map { lc $_, 1 } @$args;
  0            
1381              
1382 0           my $modules = _get_all_namespaces();
1383              
1384 0           foreach my $module ( @$modules ) {
1385 0 0         next unless exists $hash{ lc $module->userid };
1386 0           print $module->id, "\n";
1387             }
1388              
1389 0           return HEY_IT_WORKED;
1390             }
1391              
1392             sub _list_all_mods # -l
1393             {
1394 0     0     require File::Find;
1395              
1396 0           my $args = shift;
1397              
1398              
1399 0           my $fh = \*STDOUT;
1400              
1401 0           INC: foreach my $inc ( @INC )
1402             {
1403 0           my( $wanted, $reporter ) = _generator();
1404 0           File::Find::find( { wanted => $wanted }, $inc );
1405              
1406 0           my $count = 0;
1407 0           FILE: foreach my $file ( @{ $reporter->() } )
  0            
1408             {
1409 0           my $version = _parse_version_safely( $file );
1410              
1411 0           my $module_name = _path_to_module( $inc, $file );
1412 0 0         next FILE unless defined $module_name;
1413              
1414 0           print $fh "$module_name\t$version\n";
1415              
1416             #last if $count++ > 5;
1417             }
1418             }
1419              
1420 0           return HEY_IT_WORKED;
1421             }
1422              
1423             sub _generator
1424             {
1425 0     0     my @files = ();
1426              
1427 0 0   0     sub { push @files,
1428             File::Spec->canonpath( $File::Find::name )
1429             if m/\A\w+\.pm\z/ },
1430 0     0     sub { \@files },
1431 0           }
1432              
1433             sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
1434             {
1435 0     0     my( $file ) = @_;
1436              
1437 0           local $/ = "\n";
1438 0           local $_; # don't mess with the $_ in the map calling this
1439              
1440 0 0         return unless open FILE, "<$file";
1441              
1442 0           my $in_pod = 0;
1443 0           my $version;
1444 0           while( )
1445             {
1446 0           chomp;
1447 0 0         $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
    0          
1448 0 0 0       next if $in_pod || /^\s*#/;
1449              
1450 0 0         next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
1451 0           my( $sigil, $var ) = ( $1, $2 );
1452              
1453 0           $version = _eval_version( $_, $sigil, $var );
1454 0           last;
1455             }
1456 0           close FILE;
1457              
1458 0 0         return 'undef' unless defined $version;
1459              
1460 0           return $version;
1461             }
1462              
1463             sub _eval_version
1464             {
1465 0     0     my( $line, $sigil, $var ) = @_;
1466              
1467             # split package line to hide from PAUSE
1468 0           my $eval = qq{
1469             package
1470             ExtUtils::MakeMaker::_version;
1471              
1472             local $sigil$var;
1473             \$$var=undef; do {
1474             $line
1475             }; \$$var
1476             };
1477              
1478 0           my $version = do {
1479 0           local $^W = 0;
1480 5     5   61 no strict;
  5         22  
  5         3912  
1481 0           eval( $eval );
1482             };
1483              
1484 0           return $version;
1485             }
1486              
1487             sub _path_to_module
1488             {
1489 0     0     my( $inc, $path ) = @_;
1490 0 0         return if length $path < length $inc;
1491              
1492 0           my $module_path = substr( $path, length $inc );
1493 0           $module_path =~ s/\.pm\z//;
1494              
1495             # XXX: this is cheating and doesn't handle everything right
1496 0           my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
  0            
1497 0           shift @dirs;
1498              
1499 0           my $module_name = join "::", @dirs;
1500              
1501 0           return $module_name;
1502             }
1503              
1504              
1505             sub _expand_module
1506             {
1507 0     0     my( $module ) = @_;
1508              
1509 0           my $expanded = CPAN::Shell->expandany( $module );
1510 0 0         return $expanded if $expanded;
1511 0           $expanded = CPAN::Shell->expand( "Module", $module );
1512 0 0         unless( defined $expanded ) {
1513 0           $logger->error( "Could not expand [$module]. Check the module name." );
1514             my $threshold = (
1515 0           grep { int }
1516 0           sort { length $a <=> length $b }
  0            
1517             length($module)/4, 4
1518             )[0];
1519              
1520 0           my $guesses = _guess_at_module_name( $module, $threshold );
1521 0 0 0       if( defined $guesses and @$guesses ) {
1522 0           $logger->info( "Perhaps you meant one of these:" );
1523 0           foreach my $guess ( @$guesses ) {
1524 0           $logger->info( "\t$guess" );
1525             }
1526             }
1527 0           return;
1528             }
1529              
1530 0           return $expanded;
1531             }
1532              
1533             my $guessers = [
1534             [ qw( Text::Levenshtein::XS distance 7 1 ) ],
1535             [ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 1 ) ],
1536              
1537             [ qw( Text::Levenshtein distance 7 1 ) ],
1538             [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 1 ) ],
1539              
1540             ];
1541              
1542             sub _disable_guessers
1543             {
1544 0     0     $_->[-1] = 0 for @$guessers;
1545             }
1546              
1547             # for -x
1548             sub _guess_namespace
1549             {
1550 0     0     my $args = shift;
1551              
1552 0           foreach my $arg ( @$args )
1553             {
1554 0           $logger->debug( "Checking $arg" );
1555 0           my $guesses = _guess_at_module_name( $arg );
1556              
1557 0           foreach my $guess ( @$guesses ) {
1558 0           print $guess, "\n";
1559             }
1560             }
1561              
1562 0           return HEY_IT_WORKED;
1563             }
1564              
1565             sub _list_all_namespaces {
1566 0     0     my $modules = _get_all_namespaces();
1567              
1568 0           foreach my $module ( @$modules ) {
1569 0           print $module, "\n";
1570             }
1571             }
1572              
1573 0         0 BEGIN {
1574 5     5   30 my $distance;
1575             my $_threshold;
1576 5         0 my $can_guess;
1577 5         238 my $shown_help = 0;
1578             sub _guess_at_module_name
1579             {
1580 0     0     my( $target, $threshold ) = @_;
1581              
1582 0 0         unless( defined $distance ) {
1583 0           foreach my $try ( @$guessers ) {
1584 0 0         $can_guess = eval "require $try->[0]; 1" or next;
1585              
1586 0 0         $try->[-1] or next; # disabled
1587 5     5   53 no strict 'refs';
  5         14  
  5         1737  
1588 0           $distance = \&{ join "::", @$try[0,1] };
  0            
1589 0   0       $threshold ||= $try->[2];
1590             }
1591             }
1592 0   0       $_threshold ||= $threshold;
1593              
1594 0 0         unless( $distance ) {
1595 0 0         unless( $shown_help ) {
1596 0           my $modules = join ", ", map { $_->[0] } @$guessers;
  0            
1597 0           substr $modules, rindex( $modules, ',' ), 1, ', and';
1598              
1599             # Should this be colorized?
1600 0 0         if( $can_guess ) {
1601 0           $logger->info( "I can suggest names if you provide the -x option on invocation." );
1602             }
1603             else {
1604 0           $logger->info( "I can suggest names if you install one of $modules" );
1605 0           $logger->info( "and you provide the -x option on invocation." );
1606             }
1607 0           $shown_help++;
1608             }
1609 0           return;
1610             }
1611              
1612 0           my $modules = _get_all_namespaces();
1613 0           $logger->info( "Checking " . @$modules . " namespaces for close match suggestions" );
1614              
1615 0           my %guesses;
1616 0           foreach my $guess ( @$modules ) {
1617 0           my $distance = $distance->( $target, $guess );
1618 0 0         next if $distance > $_threshold;
1619 0           $guesses{$guess} = $distance;
1620             }
1621              
1622 0           my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses;
  0            
1623 0           return [ grep { defined } @guesses[0..9] ];
  0            
1624             }
1625             }
1626              
1627             1;
1628              
1629             =back
1630              
1631             =head1 EXIT VALUES
1632              
1633             The script exits with zero if it thinks that everything worked, or a
1634             positive number if it thinks that something failed. Note, however, that
1635             in some cases it has to divine a failure by the output of things it does
1636             not control. For now, the exit codes are vague:
1637              
1638             1 An unknown error
1639              
1640             2 The was an external problem
1641              
1642             4 There was an internal problem with the script
1643              
1644             8 A module failed to install
1645              
1646             =head1 TO DO
1647              
1648             * There is initial support for Log4perl if it is available, but I
1649             haven't gone through everything to make the NullLogger work out
1650             correctly if Log4perl is not installed.
1651              
1652             * When I capture CPAN.pm output, I need to check for errors and
1653             report them to the user.
1654              
1655             * Warnings switch
1656              
1657             * Check then exit
1658              
1659             =head1 BUGS
1660              
1661             * none noted
1662              
1663             =head1 SEE ALSO
1664              
1665             L, L
1666              
1667             =head1 SOURCE AVAILABILITY
1668              
1669             This code is in Github in the CPAN.pm repository:
1670              
1671             https://github.com/andk/cpanpm
1672              
1673             The source used to be tracked separately in another GitHub repo,
1674             but the canonical source is now in the above repo.
1675              
1676             =head1 CREDITS
1677              
1678             Japheth Cleaver added the bits to allow a forced install (C<-f>).
1679              
1680             Jim Brandt suggest and provided the initial implementation for the
1681             up-to-date and Changes features.
1682              
1683             Adam Kennedy pointed out that C causes problems on Windows
1684             where this script ends up with a .bat extension
1685              
1686             David Golden helps integrate this into the C repos.
1687              
1688             Jim Keenan fixed up various issues with _download
1689              
1690             =head1 AUTHOR
1691              
1692             brian d foy, C<< >>
1693              
1694             =head1 COPYRIGHT
1695              
1696             Copyright (c) 2001-2018, brian d foy, All Rights Reserved.
1697              
1698             You may redistribute this under the same terms as Perl itself.
1699              
1700             =cut