File Coverage

blib/lib/App/Cpan.pm
Criterion Covered Total %
statement 143 595 24.0
branch 13 182 7.1
condition 10 49 20.4
subroutine 47 107 43.9
pod 1 1 100.0
total 214 934 22.9


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