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