File Coverage

blib/lib/App/Cpan.pm
Criterion Covered Total %
statement 151 614 24.5
branch 15 198 7.5
condition 10 55 18.1
subroutine 48 109 44.0
pod 1 1 100.0
total 225 977 23.0


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