This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
cpan/: remove . from @INC when loading optional modules
[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 # 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->die( "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->die( "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->inst_file;
1351                 next if $module->uptodate;
1352                 printf "%-40s  %.4f  %.4f\n",
1353                         $module->id,
1354                         $module->inst_version ? $module->inst_version : '',
1355                         $module->cpan_version;
1356                 }
1357
1358         return HEY_IT_WORKED;
1359         }
1360
1361 sub _show_author_mods
1362         {
1363         my $args = shift;
1364
1365         my %hash = map { lc $_, 1 } @$args;
1366
1367         my $modules = _get_all_namespaces();
1368
1369         foreach my $module ( @$modules ) {
1370                 next unless exists $hash{ lc $module->userid };
1371                 print $module->id, "\n";
1372                 }
1373
1374         return HEY_IT_WORKED;
1375         }
1376
1377 sub _list_all_mods # -l
1378         {
1379         require File::Find;
1380
1381         my $args = shift;
1382
1383
1384         my $fh = \*STDOUT;
1385
1386         INC: foreach my $inc ( @INC )
1387                 {
1388                 my( $wanted, $reporter ) = _generator();
1389                 File::Find::find( { wanted => $wanted }, $inc );
1390
1391                 my $count = 0;
1392                 FILE: foreach my $file ( @{ $reporter->() } )
1393                         {
1394                         my $version = _parse_version_safely( $file );
1395
1396                         my $module_name = _path_to_module( $inc, $file );
1397                         next FILE unless defined $module_name;
1398
1399                         print $fh "$module_name\t$version\n";
1400
1401                         #last if $count++ > 5;
1402                         }
1403                 }
1404
1405         return HEY_IT_WORKED;
1406         }
1407
1408 sub _generator
1409         {
1410         my @files = ();
1411
1412         sub { push @files,
1413                 File::Spec->canonpath( $File::Find::name )
1414                 if m/\A\w+\.pm\z/ },
1415         sub { \@files },
1416         }
1417
1418 sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
1419         {
1420         my( $file ) = @_;
1421
1422         local $/ = "\n";
1423         local $_; # don't mess with the $_ in the map calling this
1424
1425         return unless open FILE, "<$file";
1426
1427         my $in_pod = 0;
1428         my $version;
1429         while( <FILE> )
1430                 {
1431                 chomp;
1432                 $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
1433                 next if $in_pod || /^\s*#/;
1434
1435                 next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
1436                 my( $sigil, $var ) = ( $1, $2 );
1437
1438                 $version = _eval_version( $_, $sigil, $var );
1439                 last;
1440                 }
1441         close FILE;
1442
1443         return 'undef' unless defined $version;
1444
1445         return $version;
1446         }
1447
1448 sub _eval_version
1449         {
1450         my( $line, $sigil, $var ) = @_;
1451
1452         # split package line to hide from PAUSE
1453         my $eval = qq{
1454                 package
1455                   ExtUtils::MakeMaker::_version;
1456
1457                 local $sigil$var;
1458                 \$$var=undef; do {
1459                         $line
1460                         }; \$$var
1461                 };
1462
1463         my $version = do {
1464                 local $^W = 0;
1465                 no strict;
1466                 eval( $eval );
1467                 };
1468
1469         return $version;
1470         }
1471
1472 sub _path_to_module
1473         {
1474         my( $inc, $path ) = @_;
1475         return if length $path < length $inc;
1476
1477         my $module_path = substr( $path, length $inc );
1478         $module_path =~ s/\.pm\z//;
1479
1480         # XXX: this is cheating and doesn't handle everything right
1481         my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
1482         shift @dirs;
1483
1484         my $module_name = join "::", @dirs;
1485
1486         return $module_name;
1487         }
1488
1489
1490 sub _expand_module
1491         {
1492         my( $module ) = @_;
1493
1494         my $expanded = CPAN::Shell->expand( "Module", $module );
1495         unless( defined $expanded ) {
1496                 $logger->error( "Could not expand [$module]. Check the module name." );
1497                 my $threshold = (
1498                         grep { int }
1499                         sort { length $a <=> length $b }
1500                                 length($module)/4, 4
1501                         )[0];
1502
1503                 my $guesses = _guess_at_module_name( $module, $threshold );
1504                 if( defined $guesses and @$guesses ) {
1505                         $logger->info( "Perhaps you meant one of these:" );
1506                         foreach my $guess ( @$guesses ) {
1507                                 $logger->info( "\t$guess" );
1508                                 }
1509                         }
1510                 return;
1511                 }
1512
1513         return $expanded;
1514         }
1515
1516 my $guessers = [
1517         [ qw( Text::Levenshtein::XS distance 7 ) ],
1518         [ qw( Text::Levenshtein::Damerau::XS     xs_edistance 7 ) ],
1519
1520         [ qw( Text::Levenshtein     distance 7 ) ],
1521         [ qw( Text::Levenshtein::Damerau::PP     pp_edistance 7 ) ],
1522
1523         ];
1524
1525 # for -x
1526 sub _guess_namespace
1527         {
1528         my $args = shift;
1529
1530         foreach my $arg ( @$args )
1531                 {
1532                 $logger->debug( "Checking $arg" );
1533                 my $guesses = _guess_at_module_name( $arg );
1534
1535                 foreach my $guess ( @$guesses ) {
1536                         print $guess, "\n";
1537                         }
1538                 }
1539
1540         return HEY_IT_WORKED;
1541         }
1542
1543 sub _list_all_namespaces {
1544         my $modules = _get_all_namespaces();
1545
1546         foreach my $module ( @$modules ) {
1547                 print $module, "\n";
1548                 }
1549         }
1550
1551 BEGIN {
1552 my $distance;
1553 sub _guess_at_module_name
1554         {
1555         my( $target, $threshold ) = @_;
1556
1557         unless( defined $distance ) {
1558                 foreach my $try ( @$guessers ) {
1559                         my $can_guess = eval "require $try->[0]; 1" or next;
1560
1561                         no strict 'refs';
1562                         $distance = \&{ join "::", @$try[0,1] };
1563                         $threshold ||= $try->[2];
1564                         }
1565                 }
1566
1567         unless( $distance ) {
1568                 my $modules = join ", ", map { $_->[0] } @$guessers;
1569                 substr $modules, rindex( $modules, ',' ), 1, ', and';
1570
1571                 $logger->info( "I can suggest names if you install one of $modules" );
1572                 return;
1573                 }
1574
1575         my $modules = _get_all_namespaces();
1576         $logger->info( "Checking " . @$modules . " namespaces for close match suggestions" );
1577
1578         my %guesses;
1579         foreach my $guess ( @$modules ) {
1580                 my $distance = $distance->( $target, $guess );
1581                 next if $distance > $threshold;
1582                 $guesses{$guess} = $distance;
1583                 }
1584
1585         my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses;
1586         return [ grep { defined } @guesses[0..9] ];
1587         }
1588 }
1589
1590 1;
1591
1592 =back
1593
1594 =head1 EXIT VALUES
1595
1596 The script exits with zero if it thinks that everything worked, or a
1597 positive number if it thinks that something failed. Note, however, that
1598 in some cases it has to divine a failure by the output of things it does
1599 not control. For now, the exit codes are vague:
1600
1601         1       An unknown error
1602
1603         2       The was an external problem
1604
1605         4       There was an internal problem with the script
1606
1607         8       A module failed to install
1608
1609 =head1 TO DO
1610
1611 * There is initial support for Log4perl if it is available, but I
1612 haven't gone through everything to make the NullLogger work out
1613 correctly if Log4perl is not installed.
1614
1615 * When I capture CPAN.pm output, I need to check for errors and
1616 report them to the user.
1617
1618 * Warnings switch
1619
1620 * Check then exit
1621
1622 =head1 BUGS
1623
1624 * none noted
1625
1626 =head1 SEE ALSO
1627
1628 L<CPAN>, L<App::cpanminus>
1629
1630 =head1 SOURCE AVAILABILITY
1631
1632 This code is in Github in the CPAN.pm repository:
1633
1634         https://github.com/andk/cpanpm
1635
1636 The source used to be tracked separately in another GitHub repo,
1637 but the canonical source is now in the above repo.
1638
1639 =head1 CREDITS
1640
1641 Japheth Cleaver added the bits to allow a forced install (C<-f>).
1642
1643 Jim Brandt suggest and provided the initial implementation for the
1644 up-to-date and Changes features.
1645
1646 Adam Kennedy pointed out that C<exit()> causes problems on Windows
1647 where this script ends up with a .bat extension
1648
1649 David Golden helps integrate this into the C<CPAN.pm> repos.
1650
1651 =head1 AUTHOR
1652
1653 brian d foy, C<< <bdfoy@cpan.org> >>
1654
1655 =head1 COPYRIGHT
1656
1657 Copyright (c) 2001-2015, brian d foy, All Rights Reserved.
1658
1659 You may redistribute this under the same terms as Perl itself.
1660
1661 =cut