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