File Coverage

blib/lib/App/Cpan.pm
Criterion Covered Total %
statement 147 600 24.5
branch 14 188 7.4
condition 10 52 19.2
subroutine 48 108 44.4
pod 1 1 100.0
total 220 949 23.1


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