This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade CPAN from version 2.18-TRIAL to 2.20-TRIAL
[perl5.git] / cpan / CPAN / lib / App / Cpan.pm
1 package App::Cpan;
2
3 use strict;
4 use warnings;
5 use vars qw($VERSION);
6
7 use if $] < 5.008 => 'IO::Scalar';
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<Changes> 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<Git::CPAN::Patch>
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<local::lib> (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<CPAN/Config.pm> 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<ExtUtils::MakeMaker> and L<Module::Build> 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<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>
246
247 Oslo Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/oslo-consensus.md>
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<cpan(1)> 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<cpan(1)> 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<PERL5OPTS>, a string of additional C<cpan(1)> 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<Log::Log4perl> if it is installed. Possible values are the same as
271 the C<Log::Log4perl> levels: C<TRACE>, C<DEBUG>, C<INFO>, C<WARN>,
272 C<ERROR>, and C<FATAL>. The default is C<INFO>.
273
274 =item GIT_COMMAND
275
276 The path to the C<git> binary to use for the Git features. The default
277 is C</usr/local/bin/git>.
278
279 =back
280
281 =head2 Methods
282
283 =over 4
284
285 =cut
286
287 use autouse Carp => qw(carp croak cluck);
288 use CPAN 1.80 (); # needs no test
289 use Config;
290 use autouse Cwd => qw(cwd);
291 use autouse 'Data::Dumper' => qw(Dumper);
292 use File::Spec::Functions;
293 use File::Basename;
294 use Getopt::Std;
295
296 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
297 # Internal constants
298 use constant TRUE  => 1;
299 use constant FALSE => 0;
300
301
302 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
303 # The return values
304 use constant HEY_IT_WORKED              =>   0;
305 use constant I_DONT_KNOW_WHAT_HAPPENED  =>   1; # 0b0000_0001
306 use constant ITS_NOT_MY_FAULT           =>   2;
307 use constant THE_PROGRAMMERS_AN_IDIOT   =>   4;
308 use constant A_MODULE_FAILED_TO_INSTALL =>   8;
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 use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS  @option_order
315         %Method_table %Method_table_index );
316
317 @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 $Default = 'default';
320
321 %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 @CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
333
334 @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 %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 %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         no warnings 'uninitialized';
404         shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
405         }
406
407 sub _process_options
408         {
409         my %options;
410
411         push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || '';
412
413         # if no arguments, just drop into the shell
414         if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
415         else
416                 {
417                 Getopt::Std::getopts(
418                   join( '', @option_order ), \%options );
419                  \%options;
420                 }
421         }
422
423 sub _process_setup_options
424         {
425         my( $class, $options ) = @_;
426
427         if( $options->{j} )
428                 {
429                 $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
430                 delete $options->{j};
431                 }
432         else
433                 {
434                 # this is what CPAN.pm would do otherwise
435                 local $CPAN::Be_Silent = 1;
436                 CPAN::HandleConfig->load(
437                         # be_silent  => 1, deprecated
438                         write_file => 0,
439                         );
440                 }
441
442         $class->_turn_off_testing if $options->{T};
443
444         foreach my $o ( qw(F I w P M) )
445                 {
446                 next unless exists $options->{$o};
447                 $Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} );
448                 delete $options->{$o};
449                 }
450
451         if( $options->{o} )
452                 {
453                 my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o};
454                 foreach my $pair ( @pairs )
455                         {
456                         my( $setting, $value ) = @$pair;
457                         $CPAN::Config->{$setting} = $value;
458                 #       $logger->debug( "Setting [$setting] to [$value]" );
459                         }
460                 delete $options->{o};
461                 }
462
463         my $option_count = grep { $options->{$_} } @option_order;
464         no warnings 'uninitialized';
465
466         # don't count options that imply installation
467         foreach my $opt ( qw(f T) ) { # don't count force or notest
468                 $option_count -= $options->{$opt};
469                 }
470
471         # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
472         # if there are no options, set -i (this line fixes RT ticket 16915)
473         $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         $ENV{NONINTERACTIVE_TESTING} = 1 unless defined $ENV{NONINTERACTIVE_TESTING};
482         $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<run> 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         my $class = shift;
499
500         my $return_value = HEY_IT_WORKED; # assume that things will work
501
502         $logger = $class->_init_logger;
503         $logger->debug( "Using logger from @{[ref $logger]}" );
504
505         $class->_hook_into_CPANpm_report;
506         $logger->debug( "Hooked into output" );
507
508         $class->_stupid_interface_hack_for_non_rtfmers;
509         $logger->debug( "Patched cargo culting" );
510
511         my $options = $class->_process_options;
512         $logger->debug( "Options are @{[Dumper($options)]}" );
513
514         $class->_process_setup_options( $options );
515
516         $class->_setup_environment( $options );
517
518         OPTION: foreach my $option ( @option_order )
519                 {
520                 next unless $options->{$option};
521
522                 my( $sub, $takes_args, $description ) =
523                         map { $Method_table{$option}[ $Method_table_index{$_} ] }
524                         qw( code takes_args description );
525
526                 unless( ref $sub eq ref sub {} )
527                         {
528                         $return_value = THE_PROGRAMMERS_AN_IDIOT;
529                         last OPTION;
530                         }
531
532                 $logger->info( "[$option] $description -- ignoring other arguments" )
533                         if( @ARGV && ! $takes_args );
534
535                 $return_value = $sub->( \ @ARGV, $options );
536
537                 last;
538                 }
539
540         return $return_value;
541         }
542
543 {
544 package
545   Local::Null::Logger; # hide from PAUSE
546
547 sub new { bless \ my $x, $_[0] }
548 sub AUTOLOAD {
549     my $autoload = our $AUTOLOAD;
550     $autoload =~ s/.*://;
551     return if $autoload =~ /^(debug|trace)$/;
552     $CPAN::Frontend->mywarn(">($autoload): $_\n")
553         for split /[\r\n]+/, $_[1];
554 }
555 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     my $name = shift;
562
563     local @INC = @INC;
564     pop @INC if $INC[-1] eq '.';
565
566     eval "require $name; 1";
567 }
568
569 sub _init_logger
570         {
571         my $log4perl_loaded = _safe_load_module("Log::Log4perl");
572
573     unless( $log4perl_loaded )
574         {
575         print STDOUT "Loading internal logger. Log::Log4perl recommended for better logging\n";
576         $logger = Local::Null::Logger->new;
577         return $logger;
578         }
579
580         my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';
581
582         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         $logger = Log::Log4perl->get_logger( 'App::Cpan' );
590         }
591
592 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
593  # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
594 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
595
596 sub _default
597         {
598         my( $args, $options ) = @_;
599
600         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         foreach my $option ( @CPAN_OPTIONS )
605                 {
606                 next if ( $option eq 'f' or $option eq 'T' );
607                 next unless $options->{$option};
608                 $switch = $option;
609                 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            if( not $switch and     @$args ) { $switch = $Default;  }
616         elsif( not $switch and not @$args ) { return CPAN::shell() }
617         elsif(     $switch and not @$args )
618                 { die "Nothing to $CPAN_METHODS{$switch}!\n"; }
619
620         # Get and check the method from CPAN::Shell
621         my $method = $CPAN_METHODS{$switch};
622         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         my $action = do {
626                    if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ )  } }
627                 elsif( $options->{T} ) { sub { CPAN::Shell->notest( $method, @_ ) } }
628                 else                   { sub { CPAN::Shell->$method( @_ )         } }
629                 };
630
631         # How do I handle exit codes for multiple arguments?
632         my @errors = ();
633
634         $options->{x} or _disable_guessers();
635
636         foreach my $arg ( @$args )
637                 {
638                 # check the argument and perhaps capture typos
639                 my $module = _expand_module( $arg ) or do {
640                         $logger->error( "Skipping $arg because I couldn't find a matching namespace." );
641                         next;
642                         };
643
644                 _clear_cpanpm_output();
645                 $action->( $arg );
646
647                 my $error = _cpanpm_output_indicates_failure();
648                 push @errors, $error if $error;
649                 }
650
651         return do {
652                 if( @errors ) { $errors[0] }
653                 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 BEGIN {
669 my $scalar = '';
670
671 sub _hook_into_CPANpm_report
672         {
673         no warnings 'redefine';
674
675         *CPAN::Shell::myprint = sub {
676                 my($self,$what) = @_;
677                 $scalar .= $what;
678                 $self->print_ornamented($what,
679                         $CPAN::Config->{colorize_print}||'bold blue on_white',
680                         );
681                 };
682
683         *CPAN::Shell::mywarn = sub {
684                 my($self,$what) = @_;
685                 $scalar .= $what;
686                 $self->print_ornamented($what,
687                         $CPAN::Config->{colorize_warn}||'bold red on_white'
688                         );
689                 };
690
691         }
692
693 sub _clear_cpanpm_output { $scalar = '' }
694
695 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 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         my $fh;
716
717         if( $] < 5.008 ) {
718                 $fh = IO::Scalar->new( \ $scalar );
719                 }
720         else {
721                 eval q{ open $fh, '<', \\ $scalar; };
722                 }
723
724         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         foreach my $regex ( @skip_lines )
731                 {
732                 if( $lines[-1] =~ m/$regex/ )
733             {
734             pop @lines;
735             redo REGEXES; # we have to go through all of them for every line!
736             }
737                 }
738         }
739
740     $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
741
742         $lines[-1];
743         }
744 }
745
746 BEGIN {
747 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         my $last_line = _get_cpanpm_last_line();
754
755         my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
756         return A_MODULE_FAILED_TO_INSTALL if $last_line =~ /\b(?:Cannot\s+install)\b/i;
757
758         $result || ();
759         }
760 }
761
762 sub _cpanpm_output_indicates_success
763         {
764         my $last_line = _get_cpanpm_last_line();
765
766         my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
767         $result || ();
768         }
769
770 sub _cpanpm_output_is_vague
771         {
772         return FALSE if
773                 _cpanpm_output_indicates_failure() ||
774                 _cpanpm_output_indicates_success();
775
776         return TRUE;
777         }
778
779 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
780 sub _turn_on_warnings {
781         carp "Warnings are implemented yet";
782         return HEY_IT_WORKED;
783         }
784
785 sub _turn_off_testing {
786         $logger->debug( 'Trusting test report history' );
787         $CPAN::Config->{trust_test_report_history} = 1;
788         return HEY_IT_WORKED;
789         }
790
791 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
792 sub _print_help
793         {
794         $logger->info( "Use perldoc to read the documentation" );
795         exec "perldoc $0";
796         }
797
798 sub _print_version # -v
799         {
800         $logger->info(
801                 "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
802
803         return HEY_IT_WORKED;
804         }
805
806 sub _print_details # -V
807         {
808         _print_version();
809
810         _check_install_dirs();
811
812         $logger->info( '-' x 50 . "\nChecking configured mirrors..." );
813         foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) {
814                 _print_ping_report( $mirror );
815                 }
816
817         $logger->info( '-' x 50 . "\nChecking for faster mirrors..." );
818
819         {
820         require CPAN::Mirrors;
821
822       if ( $CPAN::Config->{connect_to_internet_ok} ) {
823         $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
824         eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) }
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         $CPAN::Frontend->myprint("\n");
830       }
831
832         my $mirrors   = CPAN::Mirrors->new( _mirror_file() );
833         my @continents = $mirrors->find_best_continents;
834
835         my @mirrors   = $mirrors->get_mirrors_by_continents( $continents[0] );
836         my @timings   = $mirrors->get_mirrors_timings( \@mirrors );
837
838         foreach my $timing ( @timings ) {
839                 $logger->info( sprintf "%s (%0.2f ms)",
840                         $timing->hostname, $timing->rtt );
841                 }
842         }
843
844         return HEY_IT_WORKED;
845         }
846
847 sub _check_install_dirs
848         {
849         my $makepl_arg   = $CPAN::Config->{makepl_arg};
850         my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg};
851
852         my @custom_dirs;
853         # PERL_MM_OPT
854         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         if( @custom_dirs ) {
859                 foreach my $dir ( @custom_dirs ) {
860                         _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                 [ 'PERLLIB',      _split_paths( $ENV{PERLLIB} )  ],
872                 );
873
874         $logger->info( '-' x 50 . "\nChecking install dirs..." );
875         foreach my $tuple ( @checks ) {
876                 my( $label ) = $tuple->[0];
877
878                 $logger->info( "Checking $label" );
879                 $logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] };
880                 foreach my $dir ( @{ $tuple->[1] } ) {
881                         _print_inc_dir_report( $dir );
882                         }
883                 }
884
885         }
886
887 sub _split_paths
888         {
889         [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
890         }
891
892
893 =pod
894
895 Stolen from File::Path::Expand
896
897 =cut
898
899 sub _expand_filename
900         {
901     my( $path ) = @_;
902     no warnings 'uninitialized';
903     $logger->debug( "Expanding path $path\n" );
904     $path =~ s{\A~([^/]+)?}{
905                 _home_of( $1 || $> ) || "~$1"
906         }e;
907     return $path;
908         }
909
910 sub _home_of
911         {
912         require User::pwent;
913     my( $user ) = @_;
914     my $ent = User::pwent::getpw($user) or return;
915     return $ent->dir;
916         }
917
918 sub _get_default_inc
919         {
920         require Config;
921
922         [ @Config::Config{ _vars() }, '.' ];
923         }
924
925 sub _vars {
926         qw(
927         installarchlib
928         installprivlib
929         installsitearch
930         installsitelib
931         );
932         }
933
934 sub _ping_mirrors {
935         my $urls   = $CPAN::Config->{urllist};
936         require URI;
937
938         foreach my $url ( @$urls ) {
939                 my( $obj ) = URI->new( $url );
940                 next unless _is_pingable_scheme( $obj );
941                 my $host = $obj->host;
942                 _print_ping_report( $obj );
943                 }
944
945         }
946
947 sub _is_pingable_scheme {
948         my( $uri ) = @_;
949
950         $uri->scheme eq 'file'
951         }
952
953 sub _mirror_file {
954         my $file = do {
955                 my $file = 'MIRRORED.BY';
956                 my $local_path = File::Spec->catfile(
957                         $CPAN::Config->{keep_source_where}, $file );
958
959                 if( -e $local_path ) { $local_path }
960                 else {
961                         require CPAN::FTP;
962                         CPAN::FTP->localize( $file, $local_path, 3, 1 );
963                         $local_path;
964                         }
965                 };
966         }
967
968 sub _find_good_mirrors {
969         require CPAN::Mirrors;
970
971         my $mirrors = CPAN::Mirrors->new( _mirror_file() );
972
973         my @mirrors = $mirrors->best_mirrors(
974                 how_many   => 5,
975                 verbose    => 1,
976                 );
977
978         foreach my $mirror ( @mirrors ) {
979                 next unless eval { $mirror->can( 'http' ) };
980                 _print_ping_report( $mirror->http );
981                 }
982
983         $CPAN::Config->{urllist} = [
984                 map { $_->http } @mirrors
985                 ];
986         }
987
988 sub _print_inc_dir_report
989         {
990         my( $dir ) = shift;
991
992         my $writeable = -w $dir ? '+' : '!!! (not writeable)';
993         $logger->info( "\t$writeable $dir" );
994         return -w $dir;
995         }
996
997 sub _print_ping_report
998         {
999         my( $mirror ) = @_;
1000
1001         my $rtt = eval { _get_ping_report( $mirror ) };
1002         my $result = $rtt ? sprintf "+ (%4d ms)", $rtt * 1000 : '!';
1003
1004         $logger->info(
1005                 sprintf "\t%s %s", $result, $mirror
1006                 );
1007         }
1008
1009 sub _get_ping_report
1010         {
1011         require URI;
1012         my( $mirror ) = @_;
1013         my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX
1014         require Net::Ping;
1015
1016         my $ping = Net::Ping->new( 'tcp', 1 );
1017
1018         if( $url->scheme eq 'file' ) {
1019                 return -e $url->file;
1020                 }
1021
1022     my( $port ) = $url->port;
1023
1024     return unless $port;
1025
1026     if ( $ping->can('port_number') ) {
1027         $ping->port_number($port);
1028         }
1029     else {
1030         $ping->{'port_num'} = $port;
1031         }
1032
1033     $ping->hires(1) if $ping->can( 'hires' );
1034     my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) };
1035         $alive ? $rtt : undef;
1036         }
1037
1038 sub _load_local_lib # -I
1039         {
1040         $logger->debug( "Loading local::lib" );
1041
1042         my $rc = _safe_load_module("local::lib");
1043         unless( $rc ) {
1044                 $logger->logdie( "Could not load local::lib" );
1045                 }
1046
1047         local::lib->import;
1048
1049         return HEY_IT_WORKED;
1050         }
1051
1052 sub _use_these_mirrors # -M
1053         {
1054         $logger->debug( "Setting per session mirrors" );
1055         unless( $_[0] ) {
1056                 $logger->logdie( "The -M switch requires a comma-separated list of mirrors" );
1057                 }
1058
1059         $CPAN::Config->{urllist} = [ split /,/, $_[0] ];
1060
1061         $logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" );
1062
1063         }
1064
1065 sub _create_autobundle
1066         {
1067         $logger->info(
1068                 "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
1069
1070         CPAN::Shell->autobundle;
1071
1072         return HEY_IT_WORKED;
1073         }
1074
1075 sub _recompile
1076         {
1077         $logger->info( "Recompiling dynamically-loaded extensions" );
1078
1079         CPAN::Shell->recompile;
1080
1081         return HEY_IT_WORKED;
1082         }
1083
1084 sub _upgrade
1085         {
1086         $logger->info( "Upgrading all modules" );
1087
1088         CPAN::Shell->upgrade();
1089
1090         return HEY_IT_WORKED;
1091         }
1092
1093 sub _shell
1094         {
1095         $logger->info( "Dropping into shell" );
1096
1097         CPAN::shell();
1098
1099         return HEY_IT_WORKED;
1100         }
1101
1102 sub _load_config # -j
1103         {
1104         my $file = shift || '';
1105
1106         # should I clear out any existing config here?
1107         $CPAN::Config = {};
1108         delete $INC{'CPAN/Config.pm'};
1109         croak( "Config file [$file] does not exist!\n" ) unless -e $file;
1110
1111         my $rc = eval "require '$file'";
1112
1113         # CPAN::HandleConfig::require_myconfig_or_config looks for this
1114         $INC{'CPAN/MyConfig.pm'} = 'fake out!';
1115
1116         # CPAN::HandleConfig::load looks for this
1117         $CPAN::Config_loaded = 'fake out';
1118
1119         croak( "Could not load [$file]: $@\n") unless $rc;
1120
1121         return HEY_IT_WORKED;
1122         }
1123
1124 sub _dump_config # -J
1125         {
1126         my $args = shift;
1127         require Data::Dumper;
1128
1129         my $fh = $args->[0] || \*STDOUT;
1130
1131         local $Data::Dumper::Sortkeys = 1;
1132         my $dd = Data::Dumper->new(
1133                 [$CPAN::Config],
1134                 ['$CPAN::Config']
1135                 );
1136
1137         print $fh $dd->Dump, "\n1;\n__END__\n";
1138
1139         return HEY_IT_WORKED;
1140         }
1141
1142 sub _lock_lobotomy # -F
1143         {
1144         no warnings 'redefine';
1145
1146         *CPAN::_flock    = sub { 1 };
1147         *CPAN::checklock = sub { 1 };
1148
1149         return HEY_IT_WORKED;
1150         }
1151
1152 sub _download
1153         {
1154         my $args = shift;
1155
1156         local $CPAN::DEBUG = 1;
1157
1158         my %paths;
1159
1160         foreach my $arg ( @$args ) {
1161                 $logger->info( "Checking $arg" );
1162
1163                 my $module = _expand_module( $arg ) or next;
1164                 my $path = $module->cpan_file;
1165
1166                 $logger->debug( "Inst file would be $path\n" );
1167
1168                 $paths{$arg} = _get_file( _make_path( $path ) );
1169
1170                 $logger->info( "Downloaded [$arg] to [$paths{$module}]" );
1171                 }
1172
1173         return \%paths;
1174         }
1175
1176 sub _make_path { join "/", qw(authors id), $_[0] }
1177
1178 sub _get_file
1179         {
1180         my $path = shift;
1181
1182         my $loaded = _safe_load_module("LWP::Simple");
1183         croak "You need LWP::Simple to use features that fetch files from CPAN\n"
1184                 unless $loaded;
1185
1186         my $file = substr $path, rindex( $path, '/' ) + 1;
1187         my $store_path = catfile( cwd(), $file );
1188         $logger->debug( "Store path is $store_path" );
1189
1190         foreach my $site ( @{ $CPAN::Config->{urllist} } )
1191                 {
1192                 my $fetch_path = join "/", $site, $path;
1193                 $logger->debug( "Trying $fetch_path" );
1194             last if LWP::Simple::getstore( $fetch_path, $store_path );
1195                 }
1196
1197         return $store_path;
1198         }
1199
1200 sub _gitify
1201         {
1202         my $args = shift;
1203
1204         my $loaded = _safe_load_module("Archive::Extract");
1205         croak "You need Archive::Extract to use features that gitify distributions\n"
1206                 unless $loaded;
1207
1208         my $starting_dir = cwd();
1209
1210         foreach my $arg ( @$args )
1211                 {
1212                 $logger->info( "Checking $arg" );
1213                 my $store_paths = _download( [ $arg ] );
1214                 $logger->debug( "gitify Store path is $store_paths->{$arg}" );
1215                 my $dirname = dirname( $store_paths->{$arg} );
1216
1217                 my $ae = Archive::Extract->new( archive => $store_paths->{$arg} );
1218                 $ae->extract( to => $dirname );
1219
1220                 chdir $ae->extract_path;
1221
1222                 my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
1223                 croak "Could not find $git"    unless -e $git;
1224                 croak "$git is not executable" unless -x $git;
1225
1226                 # can we do this in Pure Perl?
1227                 system( $git, 'init'    );
1228                 system( $git, qw( add . ) );
1229                 system( $git, qw( commit -a -m ), 'initial import' );
1230                 }
1231
1232         chdir $starting_dir;
1233
1234         return HEY_IT_WORKED;
1235         }
1236
1237 sub _show_Changes
1238         {
1239         my $args = shift;
1240
1241         foreach my $arg ( @$args )
1242                 {
1243                 $logger->info( "Checking $arg\n" );
1244
1245                 my $module = _expand_module( $arg ) or next;
1246
1247                 my $out = _get_cpanpm_output();
1248
1249                 next unless eval { $module->inst_file };
1250                 #next if $module->uptodate;
1251
1252                 ( my $id = $module->id() ) =~ s/::/\-/;
1253
1254                 my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
1255                         $id . "-" . $module->cpan_version() . "/";
1256
1257                 #print "URL: $url\n";
1258                 _get_changes_file($url);
1259                 }
1260
1261         return HEY_IT_WORKED;
1262         }
1263
1264 sub _get_changes_file
1265         {
1266         croak "Reading Changes files requires LWP::Simple and URI\n"
1267                 unless _safe_load_module("LWP::Simple") && _safe_load_module("URI");
1268
1269     my $url = shift;
1270
1271     my $content = LWP::Simple::get( $url );
1272     $logger->info( "Got $url ..." ) if defined $content;
1273         #print $content;
1274
1275         my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;
1276
1277         my $changes_url = URI->new_abs( $change_link, $url );
1278         $logger->debug( "Change link is: $changes_url" );
1279
1280         my $changes =  LWP::Simple::get( $changes_url );
1281
1282         print $changes;
1283
1284         return HEY_IT_WORKED;
1285         }
1286
1287 sub _show_Author
1288         {
1289         my $args = shift;
1290
1291         foreach my $arg ( @$args )
1292                 {
1293                 my $module = _expand_module( $arg ) or next;
1294
1295                 unless( $module )
1296                         {
1297                         $logger->info( "Didn't find a $arg module, so no author!" );
1298                         next;
1299                         }
1300
1301                 my $author = CPAN::Shell->expand( "Author", $module->userid );
1302
1303                 next unless $module->userid;
1304
1305                 printf "%-25s %-8s %-25s %s\n",
1306                         $arg, $module->userid, $author->email, $author->name;
1307                 }
1308
1309         return HEY_IT_WORKED;
1310         }
1311
1312 sub _show_Details
1313         {
1314         my $args = shift;
1315
1316         foreach my $arg ( @$args )
1317                 {
1318                 my $module = _expand_module( $arg ) or next;
1319                 my $author = CPAN::Shell->expand( "Author", $module->userid );
1320
1321                 next unless $module->userid;
1322
1323                 print "$arg\n", "-" x 73, "\n\t";
1324                 print join "\n\t",
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                 print "\n\n";
1334
1335                 }
1336
1337         return HEY_IT_WORKED;
1338         }
1339
1340 BEGIN {
1341 my $modules;
1342 sub _get_all_namespaces
1343         {
1344         return $modules if $modules;
1345         $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
1346         }
1347 }
1348
1349 sub _show_out_of_date
1350         {
1351         my $modules = _get_all_namespaces();
1352
1353         printf "%-40s  %6s  %6s\n", "Module Name", "Local", "CPAN";
1354         print "-" x 73, "\n";
1355
1356         foreach my $module ( @$modules )
1357                 {
1358                 next unless $module = _expand_module($module);
1359                 next unless $module->inst_file;
1360                 next if $module->uptodate;
1361                 printf "%-40s  %.4f  %.4f\n",
1362                         $module->id,
1363                         $module->inst_version ? $module->inst_version : '',
1364                         $module->cpan_version;
1365                 }
1366
1367         return HEY_IT_WORKED;
1368         }
1369
1370 sub _show_author_mods
1371         {
1372         my $args = shift;
1373
1374         my %hash = map { lc $_, 1 } @$args;
1375
1376         my $modules = _get_all_namespaces();
1377
1378         foreach my $module ( @$modules ) {
1379                 next unless exists $hash{ lc $module->userid };
1380                 print $module->id, "\n";
1381                 }
1382
1383         return HEY_IT_WORKED;
1384         }
1385
1386 sub _list_all_mods # -l
1387         {
1388         require File::Find;
1389
1390         my $args = shift;
1391
1392
1393         my $fh = \*STDOUT;
1394
1395         INC: foreach my $inc ( @INC )
1396                 {
1397                 my( $wanted, $reporter ) = _generator();
1398                 File::Find::find( { wanted => $wanted }, $inc );
1399
1400                 my $count = 0;
1401                 FILE: foreach my $file ( @{ $reporter->() } )
1402                         {
1403                         my $version = _parse_version_safely( $file );
1404
1405                         my $module_name = _path_to_module( $inc, $file );
1406                         next FILE unless defined $module_name;
1407
1408                         print $fh "$module_name\t$version\n";
1409
1410                         #last if $count++ > 5;
1411                         }
1412                 }
1413
1414         return HEY_IT_WORKED;
1415         }
1416
1417 sub _generator
1418         {
1419         my @files = ();
1420
1421         sub { push @files,
1422                 File::Spec->canonpath( $File::Find::name )
1423                 if m/\A\w+\.pm\z/ },
1424         sub { \@files },
1425         }
1426
1427 sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
1428         {
1429         my( $file ) = @_;
1430
1431         local $/ = "\n";
1432         local $_; # don't mess with the $_ in the map calling this
1433
1434         return unless open FILE, "<$file";
1435
1436         my $in_pod = 0;
1437         my $version;
1438         while( <FILE> )
1439                 {
1440                 chomp;
1441                 $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
1442                 next if $in_pod || /^\s*#/;
1443
1444                 next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
1445                 my( $sigil, $var ) = ( $1, $2 );
1446
1447                 $version = _eval_version( $_, $sigil, $var );
1448                 last;
1449                 }
1450         close FILE;
1451
1452         return 'undef' unless defined $version;
1453
1454         return $version;
1455         }
1456
1457 sub _eval_version
1458         {
1459         my( $line, $sigil, $var ) = @_;
1460
1461         # split package line to hide from PAUSE
1462         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         my $version = do {
1473                 local $^W = 0;
1474                 no strict;
1475                 eval( $eval );
1476                 };
1477
1478         return $version;
1479         }
1480
1481 sub _path_to_module
1482         {
1483         my( $inc, $path ) = @_;
1484         return if length $path < length $inc;
1485
1486         my $module_path = substr( $path, length $inc );
1487         $module_path =~ s/\.pm\z//;
1488
1489         # XXX: this is cheating and doesn't handle everything right
1490         my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
1491         shift @dirs;
1492
1493         my $module_name = join "::", @dirs;
1494
1495         return $module_name;
1496         }
1497
1498
1499 sub _expand_module
1500         {
1501         my( $module ) = @_;
1502
1503         my $expanded = CPAN::Shell->expandany( $module );
1504         return $expanded if $expanded;
1505         $expanded = CPAN::Shell->expand( "Module", $module );
1506         unless( defined $expanded ) {
1507                 $logger->error( "Could not expand [$module]. Check the module name." );
1508                 my $threshold = (
1509                         grep { int }
1510                         sort { length $a <=> length $b }
1511                                 length($module)/4, 4
1512                         )[0];
1513
1514                 my $guesses = _guess_at_module_name( $module, $threshold );
1515                 if( defined $guesses and @$guesses ) {
1516                         $logger->info( "Perhaps you meant one of these:" );
1517                         foreach my $guess ( @$guesses ) {
1518                                 $logger->info( "\t$guess" );
1519                                 }
1520                         }
1521                 return;
1522                 }
1523
1524         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         $_->[-1] = 0 for @$guessers;
1539         }
1540
1541 # for -x
1542 sub _guess_namespace
1543         {
1544         my $args = shift;
1545
1546         foreach my $arg ( @$args )
1547                 {
1548                 $logger->debug( "Checking $arg" );
1549                 my $guesses = _guess_at_module_name( $arg );
1550
1551                 foreach my $guess ( @$guesses ) {
1552                         print $guess, "\n";
1553                         }
1554                 }
1555
1556         return HEY_IT_WORKED;
1557         }
1558
1559 sub _list_all_namespaces {
1560         my $modules = _get_all_namespaces();
1561
1562         foreach my $module ( @$modules ) {
1563                 print $module, "\n";
1564                 }
1565         }
1566
1567 BEGIN {
1568 my $distance;
1569 my $_threshold;
1570 my $can_guess;
1571 my $shown_help = 0;
1572 sub _guess_at_module_name
1573         {
1574         my( $target, $threshold ) = @_;
1575
1576         unless( defined $distance ) {
1577                 foreach my $try ( @$guessers ) {
1578                         $can_guess = eval "require $try->[0]; 1" or next;
1579
1580                         $try->[-1] or next; # disabled
1581                         no strict 'refs';
1582                         $distance = \&{ join "::", @$try[0,1] };
1583                         $threshold ||= $try->[2];
1584                         }
1585                 }
1586         $_threshold ||= $threshold;
1587
1588         unless( $distance ) {
1589                 unless( $shown_help ) {
1590                         my $modules = join ", ", map { $_->[0] } @$guessers;
1591                         substr $modules, rindex( $modules, ',' ), 1, ', and';
1592
1593                         # Should this be colorized?
1594                         if( $can_guess ) {
1595                                 $logger->info( "I can suggest names if you provide the -x option on invocation." );
1596                                 }
1597                         else {
1598                                 $logger->info( "I can suggest names if you install one of $modules" );
1599                                 $logger->info( "and you provide the -x option on invocation." );
1600                                 }
1601                         $shown_help++;
1602                         }
1603                 return;
1604                 }
1605
1606         my $modules = _get_all_namespaces();
1607         $logger->info( "Checking " . @$modules . " namespaces for close match suggestions" );
1608
1609         my %guesses;
1610         foreach my $guess ( @$modules ) {
1611                 my $distance = $distance->( $target, $guess );
1612                 next if $distance > $_threshold;
1613                 $guesses{$guess} = $distance;
1614                 }
1615
1616         my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses;
1617         return [ grep { defined } @guesses[0..9] ];
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<CPAN>, L<App::cpanminus>
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<exit()> causes problems on Windows
1678 where this script ends up with a .bat extension
1679
1680 David Golden helps integrate this into the C<CPAN.pm> repos.
1681
1682 =head1 AUTHOR
1683
1684 brian d foy, C<< <bdfoy@cpan.org> >>
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