File Coverage

blib/lib/App/Cpan.pm
Criterion Covered Total %
statement 138 531 25.9
branch 13 158 8.2
condition 10 43 23.2
subroutine 44 97 45.3
pod 1 1 100.0
total 206 830 24.8


line stmt bran cond sub pod time code
1             package App::Cpan;
2              
3 5     5   33472 use strict;
  5         8  
  5         178  
4 5     5   24 use warnings;
  5         6  
  5         156  
5 5     5   26 use vars qw($VERSION);
  5         6  
  5         275  
6              
7 5     5   3042 use if $] < 5.008 => 'IO::Scalar';
  5         41  
  5         23  
8              
9             $VERSION = '1.63';
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 [-ahpruvACDLOP]
38              
39             =head1 DESCRIPTION
40              
41             This script provides a command interface (not a shell) to CPAN. At the
42             moment it uses CPAN.pm to do the work, but it is not a one-shot command
43             runner for CPAN.pm.
44              
45             =head2 Options
46              
47             =over 4
48              
49             =item -a
50              
51             Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
52              
53             =item -A module [ module ... ]
54              
55             Shows the primary maintainers for the specified modules.
56              
57             =item -c module
58              
59             Runs a `make clean` in the specified module's directories.
60              
61             =item -C module [ module ... ]
62              
63             Show the F files for the specified modules
64              
65             =item -D module [ module ... ]
66              
67             Show the module details. This prints one line for each out-of-date module
68             (meaning, modules locally installed but have newer versions on CPAN).
69             Each line has three columns: module name, local version, and CPAN
70             version.
71              
72             =item -f
73              
74             Force the specified action, when it normally would have failed. Use this
75             to install a module even if its tests fail. When you use this option,
76             -i is not optional for installing a module when you need to force it:
77              
78             % cpan -f -i Module::Foo
79              
80             =item -F
81              
82             Turn off CPAN.pm's attempts to lock anything. You should be careful with
83             this since you might end up with multiple scripts trying to muck in the
84             same directory. This isn't so much of a concern if you're loading a special
85             config with C<-j>, and that config sets up its own work directories.
86              
87             =item -g module [ module ... ]
88              
89             Downloads to the current directory the latest distribution of the module.
90              
91             =item -G module [ module ... ]
92              
93             UNIMPLEMENTED
94              
95             Download to the current directory the latest distribution of the
96             modules, unpack each distribution, and create a git repository for each
97             distribution.
98              
99             If you want this feature, check out Yanick Champoux's C
100             distribution.
101              
102             =item -h
103              
104             Print a help message and exit. When you specify C<-h>, it ignores all
105             of the other options and arguments.
106              
107             =item -i
108              
109             Install the specified modules. With no other switches, this switch
110             is implied.
111              
112             =item -I
113              
114             Load C (think like C<-I> for loading lib paths). Too bad
115             C<-l> was already taken.
116              
117             =item -j Config.pm
118              
119             Load the file that has the CPAN configuration data. This should have the
120             same format as the standard F file, which defines
121             C<$CPAN::Config> as an anonymous hash.
122              
123             =item -J
124              
125             Dump the configuration in the same format that CPAN.pm uses. This is useful
126             for checking the configuration as well as using the dump as a starting point
127             for a new, custom configuration.
128              
129             =item -l
130              
131             List all installed modules with their versions
132              
133             =item -L author [ author ... ]
134              
135             List the modules by the specified authors.
136              
137             =item -m
138              
139             Make the specified modules.
140              
141             =item -M mirror1,mirror2,...
142              
143             A comma-separated list of mirrors to use for just this run. The C<-P>
144             option can find them for you automatically.
145              
146             =item -n
147              
148             Do a dry run, but don't actually install anything. (unimplemented)
149              
150             =item -O
151              
152             Show the out-of-date modules.
153              
154             =item -p
155              
156             Ping the configured mirrors and print a report
157              
158             =item -P
159              
160             Find the best mirrors you could be using and use them for the current
161             session.
162              
163             =item -r
164              
165             Recompiles dynamically loaded modules with CPAN::Shell->recompile.
166              
167             =item -t
168              
169             Run a `make test` on the specified modules.
170              
171             =item -T
172              
173             Do not test modules. Simply install them.
174              
175             =item -u
176              
177             Upgrade all installed modules. Blindly doing this can really break things,
178             so keep a backup.
179              
180             =item -v
181              
182             Print the script version and CPAN.pm version then exit.
183              
184             =item -V
185              
186             Print detailed information about the cpan client.
187              
188             =item -w
189              
190             UNIMPLEMENTED
191              
192             Turn on cpan warnings. This checks various things, like directory permissions,
193             and tells you about problems you might have.
194              
195             =back
196              
197             =head2 Examples
198              
199             # print a help message
200             cpan -h
201              
202             # print the version numbers
203             cpan -v
204              
205             # create an autobundle
206             cpan -a
207              
208             # recompile modules
209             cpan -r
210              
211             # upgrade all installed modules
212             cpan -u
213              
214             # install modules ( sole -i is optional )
215             cpan -i Netscape::Booksmarks Business::ISBN
216              
217             # force install modules ( must use -i )
218             cpan -fi CGI::Minimal URI
219              
220             # install modules but without testing them
221             cpan -Ti CGI::Minimal URI
222              
223             =head2 Environment variables
224              
225             There are several components in CPAN.pm that use environment variables.
226             The build tools, L and L use some,
227             while others matter to the levels above them. Some of these are specified
228             by the Perl Toolchain Gang:
229              
230             Lancaster Concensus: L
231              
232             Oslo Concensus: L
233              
234             =over 4
235              
236             =item NONINTERACTIVE_TESTING
237              
238             Assume no one is paying attention and skips prompts for distributions
239             that do that correctly. C sets this to C<1> unless it already
240             has a value (even if that value is false).
241              
242             =item PERL_MM_USE_DEFAULT
243              
244             Use the default answer for a prompted questions. C sets this
245             to C<1> unless it already has a value (even if that value is false).
246              
247             =item CPAN_OPTS
248              
249             As with C, a string of additional C options to
250             add to those you specify on the command line.
251              
252             =item CPANSCRIPT_LOGLEVEL
253              
254             The log level to use, with either the embedded, minimal logger or
255             L if it is installed. Possible values are the same as
256             the C levels: C, C, C, C,
257             C, and C. The default is C.
258              
259             =item GIT_COMMAND
260              
261             The path to the C binary to use for the Git features. The default
262             is C.
263              
264             =back
265              
266             =head2 Methods
267              
268             =over 4
269              
270             =cut
271              
272 5     5   2577 use autouse Carp => qw(carp croak cluck);
  5         3004  
  5         25  
273 5     5   4250 use CPAN 1.80 (); # needs no test
  5         186  
  5         344  
274 5     5   58 use Config;
  5         9  
  5         296  
275 5     5   28 use autouse Cwd => qw(cwd);
  5         10  
  5         41  
276 5     5   552 use autouse 'Data::Dumper' => qw(Dumper);
  5         11  
  5         22  
277 5     5   3867 use File::Spec::Functions;
  5         3961  
  5         363  
278 5     5   34 use File::Basename;
  5         9  
  5         345  
279 5     5   9576 use Getopt::Std;
  5         242  
  5         310  
280              
281             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
282             # Internal constants
283 5     5   35 use constant TRUE => 1;
  5         9  
  5         413  
284 5     5   25 use constant FALSE => 0;
  5         11  
  5         199  
285              
286              
287             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
288             # The return values
289 5     5   24 use constant HEY_IT_WORKED => 0;
  5         8  
  5         179  
290 5     5   22 use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001
  5         8  
  5         207  
291 5     5   25 use constant ITS_NOT_MY_FAULT => 2;
  5         10  
  5         192  
292 5     5   24 use constant THE_PROGRAMMERS_AN_IDIOT => 4;
  5         8  
  5         197  
293 5     5   28 use constant A_MODULE_FAILED_TO_INSTALL => 8;
  5         10  
  5         304  
294              
295              
296             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
297             # set up the order of options that we layer over CPAN::Shell
298             BEGIN { # most of this should be in methods
299 5         2791 use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order
300 5     5   28 %Method_table %Method_table_index );
  5         9  
301              
302 5     5   26 @META_OPTIONS = qw( h v V I g G M: C A D O l L a r p P j: J w T);
303              
304 5         10 $Default = 'default';
305              
306 5         67 %CPAN_METHODS = ( # map switches to method names in CPAN::Shell
307             $Default => 'install',
308             'c' => 'clean',
309             'f' => 'force',
310             'i' => 'install',
311             'm' => 'make',
312             't' => 'test',
313             'u' => 'upgrade',
314             'T' => 'notest',
315             );
316 5         39 @CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
  40         56  
317              
318 5         21 @option_order = ( @META_OPTIONS, @CPAN_OPTIONS );
319              
320              
321             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
322             # map switches to the subroutines in this script, along with other information.
323             # use this stuff instead of hard-coded indices and values
324             sub NO_ARGS () { 0 }
325             sub ARGS () { 1 }
326             sub GOOD_EXIT () { 0 }
327              
328 5         277 %Method_table = (
329             # key => [ sub ref, takes args?, exit value, description ]
330              
331             # options that do their thing first, then exit
332             h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ],
333             v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ],
334             V => [ \&_print_details, NO_ARGS, GOOD_EXIT, 'Printing detailed version' ],
335              
336             # options that affect other options
337             j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ],
338             J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ],
339             F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ],
340             I => [ \&_load_local_lib, NO_ARGS, GOOD_EXIT, 'Loading local::lib' ],
341             M => [ \&_use_these_mirrors, ARGS, GOOD_EXIT, 'Setting per session mirrors' ],
342             P => [ \&_find_good_mirrors, NO_ARGS, GOOD_EXIT, 'Finding good mirrors' ],
343             w => [ \&_turn_on_warnings, NO_ARGS, GOOD_EXIT, 'Turning on warnings' ],
344              
345             # options that do their one thing
346             g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ],
347             G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
348              
349             C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ],
350             A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ],
351             D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ],
352             O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ],
353             l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ],
354              
355             L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ],
356             a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ],
357             p => [ \&_ping_mirrors, NO_ARGS, GOOD_EXIT, 'Pinging mirrors' ],
358              
359             r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ],
360             u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
361              
362             c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ],
363             f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ],
364             i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ],
365             'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ],
366             t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ],
367             T => [ \&_default, ARGS, GOOD_EXIT, 'Installing with notest' ],
368             );
369              
370 5         220 %Method_table_index = (
371             code => 0,
372             takes_args => 1,
373             exit_value => 2,
374             description => 3,
375             );
376             }
377              
378              
379             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
380             # finally, do some argument processing
381              
382             sub _stupid_interface_hack_for_non_rtfmers
383             {
384 5     5   32 no warnings 'uninitialized';
  5         9  
  5         2040  
385 4 100 100 4   1919 shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
386             }
387              
388             sub _process_options
389             {
390 1     1   11 my %options;
391              
392 1   50     9 push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || '';
393              
394             # if no arguments, just drop into the shell
395 1 50       4 if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
  1         6  
  1         23  
396             else
397             {
398 0         0 Getopt::Std::getopts(
399             join( '', @option_order ), \%options );
400 0         0 \%options;
401             }
402             }
403              
404             sub _process_setup_options
405             {
406 0     0   0 my( $class, $options ) = @_;
407              
408 0 0       0 if( $options->{j} )
409             {
410 0         0 $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
411 0         0 delete $options->{j};
412             }
413             else
414             {
415             # this is what CPAN.pm would do otherwise
416 0         0 local $CPAN::Be_Silent = 1;
417 0         0 CPAN::HandleConfig->load(
418             # be_silent => 1, deprecated
419             write_file => 0,
420             );
421             }
422              
423 0 0       0 $class->_turn_off_testing if $options->{T};
424              
425 0         0 foreach my $o ( qw(F I w P M) )
426             {
427 0 0       0 next unless exists $options->{$o};
428 0         0 $Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} );
429 0         0 delete $options->{$o};
430             }
431              
432 0 0       0 if( $options->{o} )
433             {
434 0         0 my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o};
  0         0  
435 0         0 foreach my $pair ( @pairs )
436             {
437 0         0 my( $setting, $value ) = @$pair;
438 0         0 $CPAN::Config->{$setting} = $value;
439             # $logger->debug( "Setting [$setting] to [$value]" );
440             }
441 0         0 delete $options->{o};
442             }
443              
444 0         0 my $option_count = grep { $options->{$_} } @option_order;
  0         0  
445 5     5   39 no warnings 'uninitialized';
  5         13  
  5         4636  
446              
447             # don't count options that imply installation
448 0         0 foreach my $opt ( qw(f T) ) { # don't count force or notest
449 0         0 $option_count -= $options->{$opt};
450             }
451              
452             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
453             # if there are no options, set -i (this line fixes RT ticket 16915)
454 0 0       0 $options->{i}++ unless $option_count;
455             }
456              
457             sub _setup_environment {
458             # should we override or set defaults? If this were a true interactive
459             # session, we'd be in the CPAN shell.
460              
461             # https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
462 0 0   0   0 $ENV{NONINTERACTIVE_TESTING} = 1 unless defined $ENV{NONINTERACTIVE_TESTING};
463 0 0       0 $ENV{PERL_MM_USE_DEFAULT} = 1 unless defined $ENV{PERL_MM_USE_DEFAULT};
464             }
465              
466             =item run()
467              
468             Just do it.
469              
470             The C method returns 0 on success and a positive number on
471             failure. See the section on EXIT CODES for details on the values.
472              
473             =cut
474              
475             my $logger;
476              
477             sub run
478             {
479 0     0 1 0 my $class = shift;
480              
481 0         0 my $return_value = HEY_IT_WORKED; # assume that things will work
482              
483 0         0 $logger = $class->_init_logger;
484 0         0 $logger->debug( "Using logger from @{[ref $logger]}" );
  0         0  
485              
486 0         0 $class->_hook_into_CPANpm_report;
487 0         0 $logger->debug( "Hooked into output" );
488              
489 0         0 $class->_stupid_interface_hack_for_non_rtfmers;
490 0         0 $logger->debug( "Patched cargo culting" );
491              
492 0         0 my $options = $class->_process_options;
493 0         0 $logger->debug( "Options are @{[Dumper($options)]}" );
  0         0  
494              
495 0         0 $class->_process_setup_options( $options );
496              
497 0         0 $class->_setup_environment( $options );
498              
499 0         0 OPTION: foreach my $option ( @option_order )
500             {
501 0 0       0 next unless $options->{$option};
502              
503 0         0 my( $sub, $takes_args, $description ) =
504 0         0 map { $Method_table{$option}[ $Method_table_index{$_} ] }
505             qw( code takes_args description );
506              
507 0 0   0   0 unless( ref $sub eq ref sub {} )
  0         0  
508             {
509 0         0 $return_value = THE_PROGRAMMERS_AN_IDIOT;
510 0         0 last OPTION;
511             }
512              
513 0 0 0     0 $logger->info( "$description -- ignoring other arguments" )
514             if( @ARGV && ! $takes_args );
515              
516 0         0 $return_value = $sub->( \ @ARGV, $options );
517              
518 0         0 last;
519             }
520              
521 0         0 return $return_value;
522             }
523              
524             {
525             package
526             Local::Null::Logger; # hide from PAUSE
527              
528 2     2   7 sub new { bless \ my $x, $_[0] }
529 38     38   40 sub AUTOLOAD { 1 }
530 0     0   0 sub DESTROY { 1 }
531             }
532              
533             sub _init_logger
534             {
535 2     2   930 my $log4perl_loaded = eval "require Log::Log4perl; 1";
536              
537 2 50       18 unless( $log4perl_loaded )
538             {
539 2         54 print "Loading internal null logger. Install Log::Log4perl for logging messages\n";
540 2         48 $logger = Local::Null::Logger->new;
541 2         74 return $logger;
542             }
543              
544 0   0     0 my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';
545              
546 0         0 Log::Log4perl::init( \ <<"HERE" );
547             log4perl.rootLogger=$LEVEL, A1
548             log4perl.appender.A1=Log::Log4perl::Appender::Screen
549             log4perl.appender.A1.layout=PatternLayout
550             log4perl.appender.A1.layout.ConversionPattern=%m%n
551             HERE
552              
553 0         0 $logger = Log::Log4perl->get_logger( 'App::Cpan' );
554             }
555              
556             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
557             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
558             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
559              
560             sub _default
561             {
562 0     0   0 my( $args, $options ) = @_;
563              
564 0         0 my $switch = '';
565              
566             # choose the option that we're going to use
567             # we'll deal with 'f' (force) later, so skip it
568 0         0 foreach my $option ( @CPAN_OPTIONS )
569             {
570 0 0 0     0 next if ( $option eq 'f' or $option eq 'T' );
571 0 0       0 next unless $options->{$option};
572 0         0 $switch = $option;
573 0         0 last;
574             }
575              
576             # 1. with no switches, but arguments, use the default switch (install)
577             # 2. with no switches and no args, start the shell
578             # 3. With a switch but no args, die! These switches need arguments.
579 0 0 0     0 if( not $switch and @$args ) { $switch = $Default; }
  0 0 0     0  
    0 0        
580 0         0 elsif( not $switch and not @$args ) { return CPAN::shell() }
581             elsif( $switch and not @$args )
582 0         0 { die "Nothing to $CPAN_METHODS{$switch}!\n"; }
583              
584             # Get and check the method from CPAN::Shell
585 0         0 my $method = $CPAN_METHODS{$switch};
586 0 0       0 die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method );
587              
588             # call the CPAN::Shell method, with force or notest if specified
589 0         0 my $action = do {
590 0 0   0   0 if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } }
  0 0       0  
  0         0  
591 0     0   0 elsif( $options->{T} ) { sub { CPAN::Shell->notest( $method, @_ ) } }
  0         0  
592 0     0   0 else { sub { CPAN::Shell->$method( @_ ) } }
  0         0  
593             };
594              
595             # How do I handle exit codes for multiple arguments?
596 0         0 my @errors = ();
597              
598 0         0 foreach my $arg ( @$args )
599             {
600 0         0 _clear_cpanpm_output();
601 0         0 $action->( $arg );
602              
603 0         0 my $error = _cpanpm_output_indicates_failure();
604 0 0       0 push @errors, $error if $error;
605             }
606              
607 0         0 return do {
608 0 0       0 if( @errors ) { $errors[0] }
  0         0  
609 0         0 else { HEY_IT_WORKED }
610             };
611              
612             }
613              
614             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
615              
616             =for comment
617              
618             CPAN.pm sends all the good stuff either to STDOUT, or to a temp
619             file if $CPAN::Be_Silent is set. I have to intercept that output
620             so I can find out what happened.
621              
622             =cut
623              
624             BEGIN {
625 5     5   14 my $scalar = '';
626              
627             sub _hook_into_CPANpm_report
628             {
629 5     5   27 no warnings 'redefine';
  5         8  
  5         2305  
630              
631             *CPAN::Shell::myprint = sub {
632 18     18   1137 my($self,$what) = @_;
633 18         21 $scalar .= $what;
634 18   100     70 $self->print_ornamented($what,
635             $CPAN::Config->{colorize_print}||'bold blue on_white',
636             );
637 1     1   2850 };
638              
639             *CPAN::Shell::mywarn = sub {
640 14     14   396 my($self,$what) = @_;
641 14         23 $scalar .= $what;
642 14   100     71 $self->print_ornamented($what,
643             $CPAN::Config->{colorize_warn}||'bold red on_white'
644             );
645 1         15 };
646              
647             }
648              
649 8     8   3329 sub _clear_cpanpm_output { $scalar = '' }
650              
651 11     11   50 sub _get_cpanpm_output { $scalar }
652              
653             # These are lines I don't care about in CPAN.pm output. If I can
654             # filter out the informational noise, I have a better chance to
655             # catch the error signal
656 5         525 my @skip_lines = (
657             qr/^\QWarning \(usually harmless\)/,
658             qr/\bwill not store persistent state\b/,
659             qr(//hint//),
660             qr/^\s+reports\s+/,
661             qr/^Try the command/,
662             qr/^\s+$/,
663             qr/^to find objects/,
664             qr/^\s*Database was generated on/,
665             qr/^Going to read/,
666             qr|^\s+i\s+/|, # the i /Foo::Whatever/ line when it doesn't know
667             );
668              
669             sub _get_cpanpm_last_line
670             {
671 29     29   66 my $fh;
672              
673 29 50       56 if( $] < 5.008 ) {
674 0         0 $fh = IO::Scalar->new( \ $scalar );
675             }
676             else {
677 1     1   7 eval q{ open $fh, '<', \\ $scalar; };
  1         2  
  1         6  
  29         1698  
678             }
679              
680 29         1431 my @lines = <$fh>;
681              
682             # This is a bit ugly. Once we examine a line, we have to
683             # examine the line before it and go through all of the same
684             # regexes. I could do something fancy, but this works.
685             REGEXES: {
686 29         36 foreach my $regex ( @skip_lines )
  38         50  
687             {
688 314 100       834 if( $lines[-1] =~ m/$regex/ )
689             {
690 9         8 pop @lines;
691 9         18 redo REGEXES; # we have to go through all of them for every line!
692             }
693             }
694             }
695              
696 29         157 $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
697              
698 29         134 $lines[-1];
699             }
700             }
701              
702             BEGIN {
703 5     5   4203 my $epic_fail_words = join '|',
704             qw( Error stop(?:ping)? problems force not unsupported
705             fail(?:ed)? Cannot\s+install );
706              
707             sub _cpanpm_output_indicates_failure
708             {
709 9     9   2945 my $last_line = _get_cpanpm_last_line();
710              
711 9         110 my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
712 9 50       28 return A_MODULE_FAILED_TO_INSTALL if $last_line =~ /\b(?:Cannot\s+install)\b/i;
713              
714 9 100       34 $result || ();
715             }
716             }
717              
718             sub _cpanpm_output_indicates_success
719             {
720 9     9   2649 my $last_line = _get_cpanpm_last_line();
721              
722 9         39 my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
723 9 100       34 $result || ();
724             }
725              
726             sub _cpanpm_output_is_vague
727             {
728 0 0 0 0   0 return FALSE if
729             _cpanpm_output_indicates_failure() ||
730             _cpanpm_output_indicates_success();
731              
732 0         0 return TRUE;
733             }
734              
735             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
736             sub _turn_on_warnings {
737 0     0   0 carp "Warnings are implemented yet";
738 0         0 return HEY_IT_WORKED;
739             }
740              
741             sub _turn_off_testing {
742 0     0   0 $logger->debug( 'Trusting test report history' );
743 0         0 $CPAN::Config->{trust_test_report_history} = 1;
744 0         0 return HEY_IT_WORKED;
745             }
746              
747             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
748             sub _print_help
749             {
750 0     0   0 $logger->info( "Use perldoc to read the documentation" );
751 0         0 exec "perldoc $0";
752             }
753              
754             sub _print_version # -v
755             {
756 0     0   0 $logger->info(
757             "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
758              
759 0         0 return HEY_IT_WORKED;
760             }
761              
762             sub _print_details # -V
763             {
764 0     0   0 _print_version();
765              
766 0         0 _check_install_dirs();
767              
768 0         0 $logger->info( '-' x 50 . "\nChecking configured mirrors..." );
769 0         0 foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) {
  0         0  
770 0         0 _print_ping_report( $mirror );
771             }
772              
773 0         0 $logger->info( '-' x 50 . "\nChecking for faster mirrors..." );
774              
775             {
776 0         0 require CPAN::Mirrors;
  0         0  
777              
778 0 0       0 if ( $CPAN::Config->{connect_to_internet_ok} ) {
779 0         0 $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
780 0 0       0 eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) }
  0         0  
781             or $CPAN::Frontend->mywarn(<<'HERE');
782             We failed to get a copy of the mirror list from the Internet.
783             You will need to provide CPAN mirror URLs yourself.
784             HERE
785 0         0 $CPAN::Frontend->myprint("\n");
786             }
787              
788 0         0 my $mirrors = CPAN::Mirrors->new( );
789 0         0 $mirrors->parse_mirrored_by( File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY') );
790 0         0 my @continents = $mirrors->find_best_continents;
791              
792 0         0 my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] );
793 0         0 my @timings = $mirrors->get_mirrors_timings( \@mirrors );
794              
795 0         0 foreach my $timing ( @timings ) {
796 0         0 $logger->info( sprintf "%s (%0.2f ms)",
797             $timing->hostname, $timing->rtt );
798             }
799             }
800              
801 0         0 return HEY_IT_WORKED;
802             }
803              
804             sub _check_install_dirs
805             {
806 0     0   0 my $makepl_arg = $CPAN::Config->{makepl_arg};
807 0         0 my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg};
808              
809 0         0 my @custom_dirs;
810             # PERL_MM_OPT
811 0         0 push @custom_dirs,
812             $makepl_arg =~ m/INSTALL_BASE\s*=\s*(\S+)/g,
813             $mbuildpl_arg =~ m/--install_base\s*=\s*(\S+)/g;
814              
815 0 0       0 if( @custom_dirs ) {
816 0         0 foreach my $dir ( @custom_dirs ) {
817 0         0 _print_inc_dir_report( $dir );
818             }
819             }
820              
821             # XXX: also need to check makepl_args, etc
822              
823 0         0 my @checks = (
824             [ 'core', [ grep $_, @Config{qw(installprivlib installarchlib)} ] ],
825             [ 'vendor', [ grep $_, @Config{qw(installvendorlib installvendorarch)} ] ],
826             [ 'site', [ grep $_, @Config{qw(installsitelib installsitearch)} ] ],
827             [ 'PERL5LIB', _split_paths( $ENV{PERL5LIB} ) ],
828             [ 'PERLLIB', _split_paths( $ENV{PERLLIB} ) ],
829             );
830              
831 0         0 $logger->info( '-' x 50 . "\nChecking install dirs..." );
832 0         0 foreach my $tuple ( @checks ) {
833 0         0 my( $label ) = $tuple->[0];
834              
835 0         0 $logger->info( "Checking $label" );
836 0 0       0 $logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] };
  0         0  
837 0         0 foreach my $dir ( @{ $tuple->[1] } ) {
  0         0  
838 0         0 _print_inc_dir_report( $dir );
839             }
840             }
841              
842             }
843              
844             sub _split_paths
845             {
846 0   0 0   0 [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
  0         0  
847             }
848              
849              
850             =pod
851              
852             Stolen from File::Path::Expand
853              
854             =cut
855              
856             sub _expand_filename
857             {
858 9     9   2387 my( $path ) = @_;
859 5     5   34 no warnings 'uninitialized';
  5         7  
  5         5972  
860 9         48 $logger->debug( "Expanding path $path\n" );
861 9         25 $path =~ s{\A~([^/]+)?}{
862 3 50 66     18 _home_of( $1 || $> ) || "~$1"
863             }e;
864 9         43 return $path;
865             }
866              
867             sub _home_of
868             {
869 0     0     require User::pwent;
870 0           my( $user ) = @_;
871 0 0         my $ent = User::pwent::getpw($user) or return;
872 0           return $ent->dir;
873             }
874              
875             sub _get_default_inc
876             {
877 0     0     require Config;
878              
879 0           [ @Config::Config{ _vars() }, '.' ];
880             }
881              
882             sub _vars {
883 0     0     qw(
884             installarchlib
885             installprivlib
886             installsitearch
887             installsitelib
888             );
889             }
890              
891             sub _ping_mirrors {
892 0     0     my $urls = $CPAN::Config->{urllist};
893 0           require URI;
894              
895 0           foreach my $url ( @$urls ) {
896 0           my( $obj ) = URI->new( $url );
897 0 0         next unless _is_pingable_scheme( $obj );
898 0           my $host = $obj->host;
899 0           _print_ping_report( $obj );
900             }
901              
902             }
903              
904             sub _is_pingable_scheme {
905 0     0     my( $uri ) = @_;
906              
907 0           $uri->scheme eq 'file'
908             }
909              
910             sub _find_good_mirrors {
911 0     0     require CPAN::Mirrors;
912              
913 0           my $file = do {
914 0           my $file = 'MIRRORED.BY';
915 0           my $local_path = File::Spec->catfile(
916             $CPAN::Config->{keep_source_where}, $file );
917              
918 0 0         if( -e $local_path ) { $local_path }
  0            
919             else {
920 0           require CPAN::FTP;
921 0           CPAN::FTP->localize( $file, $local_path, 3, 1 );
922 0           $local_path;
923             }
924             };
925 0           my $mirrors = CPAN::Mirrors->new( $file );
926              
927 0           my @mirrors = $mirrors->best_mirrors(
928             how_many => 5,
929             verbose => 1,
930             );
931              
932 0           foreach my $mirror ( @mirrors ) {
933 0 0         next unless eval { $mirror->can( 'http' ) };
  0            
934 0           _print_ping_report( $mirror->http );
935             }
936              
937 0           $CPAN::Config->{urllist} = [
938 0           map { $_->http } @mirrors
939             ];
940             }
941              
942             sub _print_inc_dir_report
943             {
944 0     0     my( $dir ) = shift;
945              
946 0 0         my $writeable = -w $dir ? '+' : '!!! (not writeable)';
947 0           $logger->info( "\t$writeable $dir" );
948 0           return -w $dir;
949             }
950              
951             sub _print_ping_report
952             {
953 0     0     my( $mirror ) = @_;
954              
955 0           my $rtt = eval { _get_ping_report( $mirror ) };
  0            
956 0 0         my $result = $rtt ? sprintf "+ (%4d ms)", $rtt * 1000 : '!';
957              
958 0           $logger->info(
959             sprintf "\t%s %s", $result, $mirror
960             );
961             }
962              
963             sub _get_ping_report
964             {
965 0     0     require URI;
966 0           my( $mirror ) = @_;
967 0 0         my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX
968 0           require Net::Ping;
969              
970 0           my $ping = Net::Ping->new( 'tcp', 1 );
971              
972 0 0         if( $url->scheme eq 'file' ) {
973 0           return -e $url->file;
974             }
975              
976 0           my( $port ) = $url->port;
977              
978 0 0         return unless $port;
979              
980 0 0         if ( $ping->can('port_number') ) {
981 0           $ping->port_number($port);
982             }
983             else {
984 0           $ping->{'port_num'} = $port;
985             }
986              
987 0 0         $ping->hires(1) if $ping->can( 'hires' );
988 0           my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) };
  0            
989 0 0         $alive ? $rtt : undef;
990             }
991              
992             sub _load_local_lib # -I
993             {
994 0     0     $logger->debug( "Loading local::lib" );
995              
996 0           my $rc = eval { require local::lib; 1; };
  0            
  0            
997 0 0         unless( $rc ) {
998 0           $logger->die( "Could not load local::lib" );
999             }
1000              
1001 0           local::lib->import;
1002              
1003 0           return HEY_IT_WORKED;
1004             }
1005              
1006             sub _use_these_mirrors # -M
1007             {
1008 0     0     $logger->debug( "Setting per session mirrors" );
1009 0 0         unless( $_[0] ) {
1010 0           $logger->die( "The -M switch requires a comma-separated list of mirrors" );
1011             }
1012              
1013 0           $CPAN::Config->{urllist} = [ split /,/, $_[0] ];
1014              
1015 0           $logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" );
  0            
1016              
1017             }
1018              
1019             sub _create_autobundle
1020             {
1021 0     0     $logger->info(
1022             "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
1023              
1024 0           CPAN::Shell->autobundle;
1025              
1026 0           return HEY_IT_WORKED;
1027             }
1028              
1029             sub _recompile
1030             {
1031 0     0     $logger->info( "Recompiling dynamically-loaded extensions" );
1032              
1033 0           CPAN::Shell->recompile;
1034              
1035 0           return HEY_IT_WORKED;
1036             }
1037              
1038             sub _upgrade
1039             {
1040 0     0     $logger->info( "Upgrading all modules" );
1041              
1042 0           CPAN::Shell->upgrade();
1043              
1044 0           return HEY_IT_WORKED;
1045             }
1046              
1047             sub _load_config # -j
1048             {
1049 0   0 0     my $file = shift || '';
1050              
1051             # should I clear out any existing config here?
1052 0           $CPAN::Config = {};
1053 0           delete $INC{'CPAN/Config.pm'};
1054 0 0         croak( "Config file [$file] does not exist!\n" ) unless -e $file;
1055              
1056 0           my $rc = eval "require '$file'";
1057              
1058             # CPAN::HandleConfig::require_myconfig_or_config looks for this
1059 0           $INC{'CPAN/MyConfig.pm'} = 'fake out!';
1060              
1061             # CPAN::HandleConfig::load looks for this
1062 0           $CPAN::Config_loaded = 'fake out';
1063              
1064 0 0         croak( "Could not load [$file]: $@\n") unless $rc;
1065              
1066 0           return HEY_IT_WORKED;
1067             }
1068              
1069             sub _dump_config # -J
1070             {
1071 0     0     my $args = shift;
1072 0           require Data::Dumper;
1073              
1074 0   0       my $fh = $args->[0] || \*STDOUT;
1075              
1076 0           local $Data::Dumper::Sortkeys = 1;
1077 0           my $dd = Data::Dumper->new(
1078             [$CPAN::Config],
1079             ['$CPAN::Config']
1080             );
1081              
1082 0           print $fh $dd->Dump, "\n1;\n__END__\n";
1083              
1084 0           return HEY_IT_WORKED;
1085             }
1086              
1087             sub _lock_lobotomy # -F
1088             {
1089 5     5   31 no warnings 'redefine';
  5         8  
  5         9758  
1090              
1091 0     0     *CPAN::_flock = sub { 1 };
  0     0      
1092 0     0     *CPAN::checklock = sub { 1 };
  0            
1093              
1094 0           return HEY_IT_WORKED;
1095             }
1096              
1097             sub _download
1098             {
1099 0     0     my $args = shift;
1100              
1101 0           local $CPAN::DEBUG = 1;
1102              
1103 0           my %paths;
1104              
1105 0           foreach my $module ( @$args )
1106             {
1107 0           $logger->info( "Checking $module" );
1108 0           my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
1109              
1110 0           $logger->debug( "Inst file would be $path\n" );
1111              
1112 0           $paths{$module} = _get_file( _make_path( $path ) );
1113             }
1114              
1115 0           return \%paths;
1116             }
1117              
1118 0     0     sub _make_path { join "/", qw(authors id), $_[0] }
1119              
1120             sub _get_file
1121             {
1122 0     0     my $path = shift;
1123              
1124 0           my $loaded = eval "require LWP::Simple; 1;";
1125 0 0         croak "You need LWP::Simple to use features that fetch files from CPAN\n"
1126             unless $loaded;
1127              
1128 0           my $file = substr $path, rindex( $path, '/' ) + 1;
1129 0           my $store_path = catfile( cwd(), $file );
1130 0           $logger->debug( "Store path is $store_path" );
1131              
1132 0           foreach my $site ( @{ $CPAN::Config->{urllist} } )
  0            
1133             {
1134 0           my $fetch_path = join "/", $site, $path;
1135 0           $logger->debug( "Trying $fetch_path" );
1136 0 0         last if LWP::Simple::getstore( $fetch_path, $store_path );
1137             }
1138              
1139 0           return $store_path;
1140             }
1141              
1142             sub _gitify
1143             {
1144 0     0     my $args = shift;
1145              
1146 0           my $loaded = eval "require Archive::Extract; 1;";
1147 0 0         croak "You need Archive::Extract to use features that gitify distributions\n"
1148             unless $loaded;
1149              
1150 0           my $starting_dir = cwd();
1151              
1152 0           foreach my $module ( @$args )
1153             {
1154 0           $logger->info( "Checking $module" );
1155 0           my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
1156              
1157 0           my $store_paths = _download( [ $module ] );
1158 0           $logger->debug( "gitify Store path is $store_paths->{$module}" );
1159 0           my $dirname = dirname( $store_paths->{$module} );
1160              
1161 0           my $ae = Archive::Extract->new( archive => $store_paths->{$module} );
1162 0           $ae->extract( to => $dirname );
1163              
1164 0           chdir $ae->extract_path;
1165              
1166 0   0       my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
1167 0 0         croak "Could not find $git" unless -e $git;
1168 0 0         croak "$git is not executable" unless -x $git;
1169              
1170             # can we do this in Pure Perl?
1171 0           system( $git, 'init' );
1172 0           system( $git, qw( add . ) );
1173 0           system( $git, qw( commit -a -m ), 'initial import' );
1174             }
1175              
1176 0           chdir $starting_dir;
1177              
1178 0           return HEY_IT_WORKED;
1179             }
1180              
1181             sub _show_Changes
1182             {
1183 0     0     my $args = shift;
1184              
1185 0           foreach my $arg ( @$args )
1186             {
1187 0           $logger->info( "Checking $arg\n" );
1188              
1189 0           my $module = eval { CPAN::Shell->expand( "Module", $arg ) };
  0            
1190 0           my $out = _get_cpanpm_output();
1191              
1192 0 0         next unless eval { $module->inst_file };
  0            
1193             #next if $module->uptodate;
1194              
1195 0           ( my $id = $module->id() ) =~ s/::/\-/;
1196              
1197 0           my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
1198             $id . "-" . $module->cpan_version() . "/";
1199              
1200             #print "URL: $url\n";
1201 0           _get_changes_file($url);
1202             }
1203              
1204 0           return HEY_IT_WORKED;
1205             }
1206              
1207             sub _get_changes_file
1208             {
1209 0 0   0     croak "Reading Changes files requires LWP::Simple and URI\n"
1210             unless eval "require LWP::Simple; require URI; 1";
1211              
1212 0           my $url = shift;
1213              
1214 0           my $content = LWP::Simple::get( $url );
1215 0 0         $logger->info( "Got $url ..." ) if defined $content;
1216             #print $content;
1217              
1218 0           my( $change_link ) = $content =~ m|Changes|gi;
1219              
1220 0           my $changes_url = URI->new_abs( $change_link, $url );
1221 0           $logger->debug( "Change link is: $changes_url" );
1222              
1223 0           my $changes = LWP::Simple::get( $changes_url );
1224              
1225 0           print $changes;
1226              
1227 0           return HEY_IT_WORKED;
1228             }
1229              
1230             sub _show_Author
1231             {
1232 0     0     my $args = shift;
1233              
1234 0           foreach my $arg ( @$args )
1235             {
1236 0           my $module = CPAN::Shell->expand( "Module", $arg );
1237 0 0         unless( $module )
1238             {
1239 0           $logger->info( "Didn't find a $arg module, so no author!" );
1240 0           next;
1241             }
1242              
1243 0           my $author = CPAN::Shell->expand( "Author", $module->userid );
1244              
1245 0 0         next unless $module->userid;
1246              
1247 0           printf "%-25s %-8s %-25s %s\n",
1248             $arg, $module->userid, $author->email, $author->name;
1249             }
1250              
1251 0           return HEY_IT_WORKED;
1252             }
1253              
1254             sub _show_Details
1255             {
1256 0     0     my $args = shift;
1257              
1258 0           foreach my $arg ( @$args )
1259             {
1260 0           my $module = CPAN::Shell->expand( "Module", $arg );
1261 0           my $author = CPAN::Shell->expand( "Author", $module->userid );
1262              
1263 0 0         next unless $module->userid;
1264              
1265 0           print "$arg\n", "-" x 73, "\n\t";
1266 0 0         print join "\n\t",
    0          
    0          
    0          
    0          
1267             $module->description ? $module->description : "(no description)",
1268             $module->cpan_file ? $module->cpan_file : "(no cpanfile)",
1269             $module->inst_file ? $module->inst_file :"(no installation file)" ,
1270             'Installed: ' . ($module->inst_version ? $module->inst_version : "not installed"),
1271             'CPAN: ' . $module->cpan_version . ' ' .
1272             ($module->uptodate ? "" : "Not ") . "up to date",
1273             $author->fullname . " (" . $module->userid . ")",
1274             $author->email;
1275 0           print "\n\n";
1276              
1277             }
1278              
1279 0           return HEY_IT_WORKED;
1280             }
1281              
1282             sub _show_out_of_date
1283             {
1284 0     0     my @modules = CPAN::Shell->expand( "Module", "/./" );
1285              
1286 0           printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
1287 0           print "-" x 73, "\n";
1288              
1289 0           foreach my $module ( @modules )
1290             {
1291 0 0         next unless $module->inst_file;
1292 0 0         next if $module->uptodate;
1293 0 0         printf "%-40s %.4f %.4f\n",
1294             $module->id,
1295             $module->inst_version ? $module->inst_version : '',
1296             $module->cpan_version;
1297             }
1298              
1299 0           return HEY_IT_WORKED;
1300             }
1301              
1302             sub _show_author_mods
1303             {
1304 0     0     my $args = shift;
1305              
1306 0           my %hash = map { lc $_, 1 } @$args;
  0            
1307              
1308 0           my @modules = CPAN::Shell->expand( "Module", "/./" );
1309              
1310 0           foreach my $module ( @modules )
1311             {
1312 0 0         next unless exists $hash{ lc $module->userid };
1313 0           print $module->id, "\n";
1314             }
1315              
1316 0           return HEY_IT_WORKED;
1317             }
1318              
1319             sub _list_all_mods # -l
1320             {
1321 0     0     require File::Find;
1322              
1323 0           my $args = shift;
1324              
1325              
1326 0           my $fh = \*STDOUT;
1327              
1328 0           INC: foreach my $inc ( @INC )
1329             {
1330 0           my( $wanted, $reporter ) = _generator();
1331 0           File::Find::find( { wanted => $wanted }, $inc );
1332              
1333 0           my $count = 0;
1334 0           FILE: foreach my $file ( @{ $reporter->() } )
  0            
1335             {
1336 0           my $version = _parse_version_safely( $file );
1337              
1338 0           my $module_name = _path_to_module( $inc, $file );
1339 0 0         next FILE unless defined $module_name;
1340              
1341 0           print $fh "$module_name\t$version\n";
1342              
1343             #last if $count++ > 5;
1344             }
1345             }
1346              
1347 0           return HEY_IT_WORKED;
1348             }
1349              
1350             sub _generator
1351             {
1352 0     0     my @files = ();
1353              
1354 0 0   0     sub { push @files,
1355             File::Spec->canonpath( $File::Find::name )
1356             if m/\A\w+\.pm\z/ },
1357 0     0     sub { \@files },
1358 0           }
1359              
1360             sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
1361             {
1362 0     0     my( $file ) = @_;
1363              
1364 0           local $/ = "\n";
1365 0           local $_; # don't mess with the $_ in the map calling this
1366              
1367 0 0         return unless open FILE, "<$file";
1368              
1369 0           my $in_pod = 0;
1370 0           my $version;
1371 0           while( )
1372             {
1373 0           chomp;
1374 0 0         $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
    0          
1375 0 0 0       next if $in_pod || /^\s*#/;
1376              
1377 0 0         next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
1378 0           my( $sigil, $var ) = ( $1, $2 );
1379              
1380 0           $version = _eval_version( $_, $sigil, $var );
1381 0           last;
1382             }
1383 0           close FILE;
1384              
1385 0 0         return 'undef' unless defined $version;
1386              
1387 0           return $version;
1388             }
1389              
1390             sub _eval_version
1391             {
1392 0     0     my( $line, $sigil, $var ) = @_;
1393              
1394             # split package line to hide from PAUSE
1395 0           my $eval = qq{
1396             package
1397             ExtUtils::MakeMaker::_version;
1398              
1399             local $sigil$var;
1400             \$$var=undef; do {
1401             $line
1402             }; \$$var
1403             };
1404              
1405 0           my $version = do {
1406 0           local $^W = 0;
1407 5     5   36 no strict;
  5         11  
  5         999  
1408 0           eval( $eval );
1409             };
1410              
1411 0           return $version;
1412             }
1413              
1414             sub _path_to_module
1415             {
1416 0     0     my( $inc, $path ) = @_;
1417 0 0         return if length $path < length $inc;
1418              
1419 0           my $module_path = substr( $path, length $inc );
1420 0           $module_path =~ s/\.pm\z//;
1421              
1422             # XXX: this is cheating and doesn't handle everything right
1423 0           my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
  0            
1424 0           shift @dirs;
1425              
1426 0           my $module_name = join "::", @dirs;
1427              
1428 0           return $module_name;
1429             }
1430              
1431             1;
1432              
1433             =back
1434              
1435             =head1 EXIT VALUES
1436              
1437             The script exits with zero if it thinks that everything worked, or a
1438             positive number if it thinks that something failed. Note, however, that
1439             in some cases it has to divine a failure by the output of things it does
1440             not control. For now, the exit codes are vague:
1441              
1442             1 An unknown error
1443              
1444             2 The was an external problem
1445              
1446             4 There was an internal problem with the script
1447              
1448             8 A module failed to install
1449              
1450             =head1 TO DO
1451              
1452             * There is initial support for Log4perl if it is available, but I
1453             haven't gone through everything to make the NullLogger work out
1454             correctly if Log4perl is not installed.
1455              
1456             * When I capture CPAN.pm output, I need to check for errors and
1457             report them to the user.
1458              
1459             * Warnings switch
1460              
1461             * Check then exit
1462              
1463             * no test option
1464              
1465             =head1 BUGS
1466              
1467             * none noted
1468              
1469             =head1 SEE ALSO
1470              
1471             L, L
1472              
1473             =head1 SOURCE AVAILABILITY
1474              
1475             This code is in Github in the CPAN.pm repository:
1476              
1477             https://github.com/andk/cpanpm
1478              
1479             The source used to be tracked separately in another GitHub repo,
1480             but the canonical source is now in the above repo.
1481              
1482             =head1 CREDITS
1483              
1484             Japheth Cleaver added the bits to allow a forced install (C<-f>).
1485              
1486             Jim Brandt suggest and provided the initial implementation for the
1487             up-to-date and Changes features.
1488              
1489             Adam Kennedy pointed out that C causes problems on Windows
1490             where this script ends up with a .bat extension
1491              
1492             David Golden helps integrate this into the C repos.
1493              
1494             =head1 AUTHOR
1495              
1496             brian d foy, C<< >>
1497              
1498             =head1 COPYRIGHT
1499              
1500             Copyright (c) 2001-2014, brian d foy, All Rights Reserved.
1501              
1502             You may redistribute this under the same terms as Perl itself.
1503              
1504             =cut