← Index
NYTProf Performance Profile   « line view »
For /Users/brian/bin/perls/cpan5.26.1
  Run on Sat Dec 30 01:41:10 2017
Reported on Sat Dec 30 01:44:14 2017

Filename/usr/local/perls/perl-5.26.1/lib/5.26.1/App/Cpan.pm
StatementsExecuted 2448 statements in 10.4ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
80423711.6ms81.8msApp::Cpan::::__ANON__[:673] App::Cpan::__ANON__[:673]
111462µs462µsApp::Cpan::::_safe_load_module App::Cpan::_safe_load_module
111112µs119sApp::Cpan::::run App::Cpan::run
11174µs74µsApp::Cpan::::_hook_into_CPANpm_report App::Cpan::_hook_into_CPANpm_report
11169µs579µsApp::Cpan::::_init_logger App::Cpan::_init_logger
22162µs194µsApp::Cpan::::__ANON__[:681] App::Cpan::__ANON__[:681]
11135µs119sApp::Cpan::::_process_options App::Cpan::_process_options
11130µs30µsApp::Cpan::::CORE:print App::Cpan::CORE:print (opcode)
11118µs18µsLocal::Null::Logger::::newLocal::Null::Logger::new
3315µs5µsLocal::Null::Logger::::AUTOLOADLocal::Null::Logger::AUTOLOAD
1114µs4µsApp::Cpan::::_stupid_interface_hack_for_non_rtfmers App::Cpan::_stupid_interface_hack_for_non_rtfmers
0000s0sApp::Cpan::::BEGIN App::Cpan::BEGIN
0000s0sApp::Cpan::::__ANON__[:1138] App::Cpan::__ANON__[:1138]
0000s0sApp::Cpan::::__ANON__[:1139] App::Cpan::__ANON__[:1139]
0000s0sApp::Cpan::::__ANON__[:1415] App::Cpan::__ANON__[:1415]
0000s0sApp::Cpan::::__ANON__[:1416] App::Cpan::__ANON__[:1416]
0000s0sApp::Cpan::::__ANON__[:526] App::Cpan::__ANON__[:526]
0000s0sApp::Cpan::::__ANON__[:620] App::Cpan::__ANON__[:620]
0000s0sApp::Cpan::::__ANON__[:621] App::Cpan::__ANON__[:621]
0000s0sApp::Cpan::::__ANON__[:622] App::Cpan::__ANON__[:622]
0000s0sApp::Cpan::::_check_install_dirs App::Cpan::_check_install_dirs
0000s0sApp::Cpan::::_clear_cpanpm_output App::Cpan::_clear_cpanpm_output
0000s0sApp::Cpan::::_cpanpm_output_indicates_failure App::Cpan::_cpanpm_output_indicates_failure
0000s0sApp::Cpan::::_cpanpm_output_indicates_success App::Cpan::_cpanpm_output_indicates_success
0000s0sApp::Cpan::::_cpanpm_output_is_vague App::Cpan::_cpanpm_output_is_vague
0000s0sApp::Cpan::::_create_autobundle App::Cpan::_create_autobundle
0000s0sApp::Cpan::::_default App::Cpan::_default
0000s0sApp::Cpan::::_download App::Cpan::_download
0000s0sApp::Cpan::::_dump_config App::Cpan::_dump_config
0000s0sApp::Cpan::::_eval_version App::Cpan::_eval_version
0000s0sApp::Cpan::::_expand_filename App::Cpan::_expand_filename
0000s0sApp::Cpan::::_expand_module App::Cpan::_expand_module
0000s0sApp::Cpan::::_find_good_mirrors App::Cpan::_find_good_mirrors
0000s0sApp::Cpan::::_generator App::Cpan::_generator
0000s0sApp::Cpan::::_get_all_namespaces App::Cpan::_get_all_namespaces
0000s0sApp::Cpan::::_get_changes_file App::Cpan::_get_changes_file
0000s0sApp::Cpan::::_get_cpanpm_last_line App::Cpan::_get_cpanpm_last_line
0000s0sApp::Cpan::::_get_cpanpm_output App::Cpan::_get_cpanpm_output
0000s0sApp::Cpan::::_get_default_inc App::Cpan::_get_default_inc
0000s0sApp::Cpan::::_get_file App::Cpan::_get_file
0000s0sApp::Cpan::::_get_ping_report App::Cpan::_get_ping_report
0000s0sApp::Cpan::::_gitify App::Cpan::_gitify
0000s0sApp::Cpan::::_guess_at_module_name App::Cpan::_guess_at_module_name
0000s0sApp::Cpan::::_guess_namespace App::Cpan::_guess_namespace
0000s0sApp::Cpan::::_home_of App::Cpan::_home_of
0000s0sApp::Cpan::::_is_pingable_scheme App::Cpan::_is_pingable_scheme
0000s0sApp::Cpan::::_list_all_mods App::Cpan::_list_all_mods
0000s0sApp::Cpan::::_list_all_namespaces App::Cpan::_list_all_namespaces
0000s0sApp::Cpan::::_load_config App::Cpan::_load_config
0000s0sApp::Cpan::::_load_local_lib App::Cpan::_load_local_lib
0000s0sApp::Cpan::::_lock_lobotomy App::Cpan::_lock_lobotomy
0000s0sApp::Cpan::::_make_path App::Cpan::_make_path
0000s0sApp::Cpan::::_mirror_file App::Cpan::_mirror_file
0000s0sApp::Cpan::::_parse_version_safely App::Cpan::_parse_version_safely
0000s0sApp::Cpan::::_path_to_module App::Cpan::_path_to_module
0000s0sApp::Cpan::::_ping_mirrors App::Cpan::_ping_mirrors
0000s0sApp::Cpan::::_print_details App::Cpan::_print_details
0000s0sApp::Cpan::::_print_help App::Cpan::_print_help
0000s0sApp::Cpan::::_print_inc_dir_report App::Cpan::_print_inc_dir_report
0000s0sApp::Cpan::::_print_ping_report App::Cpan::_print_ping_report
0000s0sApp::Cpan::::_print_version App::Cpan::_print_version
0000s0sApp::Cpan::::_process_setup_options App::Cpan::_process_setup_options
0000s0sApp::Cpan::::_recompile App::Cpan::_recompile
0000s0sApp::Cpan::::_setup_environment App::Cpan::_setup_environment
0000s0sApp::Cpan::::_shell App::Cpan::_shell
0000s0sApp::Cpan::::_show_Author App::Cpan::_show_Author
0000s0sApp::Cpan::::_show_Changes App::Cpan::_show_Changes
0000s0sApp::Cpan::::_show_Details App::Cpan::_show_Details
0000s0sApp::Cpan::::_show_author_mods App::Cpan::_show_author_mods
0000s0sApp::Cpan::::_show_out_of_date App::Cpan::_show_out_of_date
0000s0sApp::Cpan::::_split_paths App::Cpan::_split_paths
0000s0sApp::Cpan::::_turn_off_testing App::Cpan::_turn_off_testing
0000s0sApp::Cpan::::_turn_on_warnings App::Cpan::_turn_on_warnings
0000s0sApp::Cpan::::_upgrade App::Cpan::_upgrade
0000s0sApp::Cpan::::_use_these_mirrors App::Cpan::_use_these_mirrors
0000s0sApp::Cpan::::_vars App::Cpan::_vars
0000s0sLocal::Null::Logger::::DESTROYLocal::Null::Logger::DESTROY
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package App::Cpan;
2
3use strict;
4use warnings;
5use vars qw($VERSION);
6
7use if $] < 5.008 => 'IO::Scalar';
8
9$VERSION = '1.66';
10
11=head1 NAME
12
13App::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
41This script provides a command interface (not a shell) to CPAN. At the
42moment it uses CPAN.pm to do the work, but it is not a one-shot command
43runner for CPAN.pm.
44
45=head2 Options
46
47=over 4
48
49=item -a
50
51Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
52
53=item -A module [ module ... ]
54
55Shows the primary maintainers for the specified modules.
56
57=item -c module
58
59Runs a `make clean` in the specified module's directories.
60
61=item -C module [ module ... ]
62
63Show the F<Changes> files for the specified modules
64
65=item -D module [ module ... ]
66
67Show the module details. This prints one line for each out-of-date module
68(meaning, modules locally installed but have newer versions on CPAN).
69Each line has three columns: module name, local version, and CPAN
70version.
71
72=item -f
73
74Force the specified action, when it normally would have failed. Use this
75to 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
82Turn off CPAN.pm's attempts to lock anything. You should be careful with
83this since you might end up with multiple scripts trying to muck in the
84same directory. This isn't so much of a concern if you're loading a special
85config with C<-j>, and that config sets up its own work directories.
86
87=item -g module [ module ... ]
88
89Downloads to the current directory the latest distribution of the module.
90
91=item -G module [ module ... ]
92
93UNIMPLEMENTED
94
95Download to the current directory the latest distribution of the
96modules, unpack each distribution, and create a git repository for each
97distribution.
98
99If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
100distribution.
101
102=item -h
103
104Print a help message and exit. When you specify C<-h>, it ignores all
105of the other options and arguments.
106
107=item -i module [ module ... ]
108
109Install the specified modules. With no other switches, this switch
110is implied.
111
112=item -I
113
114Load C<local::lib> (think like C<-I> for loading lib paths). Too bad
115C<-l> was already taken.
116
117=item -j Config.pm
118
119Load the file that has the CPAN configuration data. This should have the
120same format as the standard F<CPAN/Config.pm> file, which defines
121C<$CPAN::Config> as an anonymous hash.
122
123=item -J
124
125Dump the configuration in the same format that CPAN.pm uses. This is useful
126for checking the configuration as well as using the dump as a starting point
127for a new, custom configuration.
128
129=item -l
130
131List all installed modules with their versions
132
133=item -L author [ author ... ]
134
135List the modules by the specified authors.
136
137=item -m
138
139Make the specified modules.
140
141=item -M mirror1,mirror2,...
142
143A comma-separated list of mirrors to use for just this run. The C<-P>
144option can find them for you automatically.
145
146=item -n
147
148Do a dry run, but don't actually install anything. (unimplemented)
149
150=item -O
151
152Show the out-of-date modules.
153
154=item -p
155
156Ping the configured mirrors and print a report
157
158=item -P
159
160Find the best mirrors you could be using and use them for the current
161session.
162
163=item -r
164
165Recompiles dynamically loaded modules with CPAN::Shell->recompile.
166
167=item -s
168
169Drop in the CPAN.pm shell. This command does this automatically if you don't
170specify any arguments.
171
172=item -t module [ module ... ]
173
174Run a `make test` on the specified modules.
175
176=item -T
177
178Do not test modules. Simply install them.
179
180=item -u
181
182Upgrade all installed modules. Blindly doing this can really break things,
183so keep a backup.
184
185=item -v
186
187Print the script version and CPAN.pm version then exit.
188
189=item -V
190
191Print detailed information about the cpan client.
192
193=item -w
194
195UNIMPLEMENTED
196
197Turn on cpan warnings. This checks various things, like directory permissions,
198and tells you about problems you might have.
199
200=item -x module [ module ... ]
201
202Find close matches to the named modules that you think you might have
203mistyped. This requires the optional installation of Text::Levenshtein or
204Text::Levenshtein::Damerau.
205
206=item -X
207
208Dump 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
240There are several components in CPAN.pm that use environment variables.
241The build tools, L<ExtUtils::MakeMaker> and L<Module::Build> use some,
242while others matter to the levels above them. Some of these are specified
243by the Perl Toolchain Gang:
244
245Lancaster Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>
246
247Oslo 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
253Assume no one is paying attention and skips prompts for distributions
254that do that correctly. C<cpan(1)> sets this to C<1> unless it already
255has a value (even if that value is false).
256
257=item PERL_MM_USE_DEFAULT
258
259Use the default answer for a prompted questions. C<cpan(1)> sets this
260to C<1> unless it already has a value (even if that value is false).
261
262=item CPAN_OPTS
263
264As with C<PERL5OPTS>, a string of additional C<cpan(1)> options to
265add to those you specify on the command line.
266
267=item CPANSCRIPT_LOGLEVEL
268
269The log level to use, with either the embedded, minimal logger or
270L<Log::Log4perl> if it is installed. Possible values are the same as
271the C<Log::Log4perl> levels: C<TRACE>, C<DEBUG>, C<INFO>, C<WARN>,
272C<ERROR>, and C<FATAL>. The default is C<INFO>.
273
274=item GIT_COMMAND
275
276The path to the C<git> binary to use for the Git features. The default
277is C</usr/local/bin/git>.
278
279=back
280
281=head2 Methods
282
283=over 4
284
285=cut
286
287use autouse Carp => qw(carp croak cluck);
288use CPAN 1.80 (); # needs no test
289use Config;
290use autouse Cwd => qw(cwd);
291use autouse 'Data::Dumper' => qw(Dumper);
292use File::Spec::Functions;
293use File::Basename;
294use Getopt::Std;
295
296# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
297# Internal constants
298use constant TRUE => 1;
299use constant FALSE => 0;
300
301
302# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
303# The return values
304use constant HEY_IT_WORKED => 0;
305use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001
306use constant ITS_NOT_MY_FAULT => 2;
307use constant THE_PROGRAMMERS_AN_IDIOT => 4;
308use constant A_MODULE_FAILED_TO_INSTALL => 8;
309
310
311# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
312# set up the order of options that we layer over CPAN::Shell
313BEGIN { # most of this should be in methods
314use 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
340sub NO_ARGS () { 0 }
341sub ARGS () { 1 }
342sub 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
401sub _stupid_interface_hack_for_non_rtfmers
402
# spent 4µs within App::Cpan::_stupid_interface_hack_for_non_rtfmers which was called: # once (4µs+0s) by App::Cpan::run at line 508
{
403 no warnings 'uninitialized';
40419µs shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
405 }
406
407sub _process_options
408
# spent 119s (35µs+119) within App::Cpan::_process_options which was called: # once (35µs+119s) by App::Cpan::run at line 511
{
40911µs my %options;
410
41116µs push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || '';
412
413 # if no arguments, just drop into the shell
4143104µs1119s if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
# spent 119s making 1 call to CPAN::shell
415 else
416 {
417 Getopt::Std::getopts(
418 join( '', @option_order ), \%options );
419 \%options;
420 }
421 }
422
423sub _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
476sub _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
487Just do it.
488
489The C<run> method returns 0 on success and a positive number on
490failure. See the section on EXIT CODES for details on the values.
491
492=cut
493
494my $logger;
495
496sub run
497
# spent 119s (112µs+119) within App::Cpan::run which was called: # once (112µs+119s) by main::RUNTIME at line 13 of /Users/brian/bin/perls/cpan5.26.1
{
49811µs my $class = shift;
499
50011µs my $return_value = HEY_IT_WORKED; # assume that things will work
501
50214µs1579µs $logger = $class->_init_logger;
# spent 579µs making 1 call to App::Cpan::_init_logger
503120µs12µs $logger->debug( "Using logger from @{[ref $logger]}" );
# spent 2µs making 1 call to Local::Null::Logger::AUTOLOAD
504
50513µs174µs $class->_hook_into_CPANpm_report;
# spent 74µs making 1 call to App::Cpan::_hook_into_CPANpm_report
50617µs11µs $logger->debug( "Hooked into output" );
# spent 1µs making 1 call to Local::Null::Logger::AUTOLOAD
507
50814µs14µs $class->_stupid_interface_hack_for_non_rtfmers;
# spent 4µs making 1 call to App::Cpan::_stupid_interface_hack_for_non_rtfmers
50915µs12µs $logger->debug( "Patched cargo culting" );
# spent 2µs making 1 call to Local::Null::Logger::AUTOLOAD
510
51114µs1119s my $options = $class->_process_options;
# spent 119s making 1 call to App::Cpan::_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{
544package
545 Local::Null::Logger; # hide from PAUSE
546
547128µs
# spent 18µs within Local::Null::Logger::new which was called: # once (18µs+0s) by App::Cpan::_init_logger at line 570
sub new { bless \ my $x, $_[0] }
548318µs
# spent 5µs within Local::Null::Logger::AUTOLOAD which was called 3 times, avg 2µs/call: # once (2µs+0s) by App::Cpan::run at line 509 # once (2µs+0s) by App::Cpan::run at line 503 # once (1µs+0s) by App::Cpan::run at line 506
sub AUTOLOAD { 1 }
549sub DESTROY { 1 }
550}
551
552# load a module without searching the default entry for the current
553# directory
554
# spent 462µs within App::Cpan::_safe_load_module which was called: # once (462µs+0s) by App::Cpan::_init_logger at line 565
sub _safe_load_module {
55511µs my $name = shift;
556
55713µs local @INC = @INC;
55812µs pop @INC if $INC[-1] eq '.';
559
560151µs eval "require $name; 1";
# spent 436µs executing statements in string eval
561}
562
563sub _init_logger
564
# spent 579µs (69+510) within App::Cpan::_init_logger which was called: # once (69µs+510µs) by App::Cpan::run at line 502
{
56516µs1462µs my $log4perl_loaded = _safe_load_module("Log::Log4perl");
# spent 462µs making 1 call to App::Cpan::_safe_load_module
566
56711µs unless( $log4perl_loaded )
568 {
569140µs130µs print STDERR "Loading internal null logger. Install Log::Log4perl for logging messages\n";
# spent 30µs making 1 call to App::Cpan::CORE:print
57017µs118µs $logger = Local::Null::Logger->new;
# spent 18µs making 1 call to Local::Null::Logger::new
57118µs return $logger;
572 }
573
574 my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';
575
576 Log::Log4perl::init( \ <<"HERE" );
577log4perl.rootLogger=$LEVEL, A1
578log4perl.appender.A1=Log::Log4perl::Appender::Screen
579log4perl.appender.A1.layout=PatternLayout
580log4perl.appender.A1.layout.ConversionPattern=%m%n
581HERE
582
583 $logger = Log::Log4perl->get_logger( 'App::Cpan' );
584 }
585
586# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
587 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
588# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
589
590sub _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
654CPAN.pm sends all the good stuff either to STDOUT, or to a temp
655file if $CPAN::Be_Silent is set. I have to intercept that output
656so I can find out what happened.
657
658=cut
659
660BEGIN {
661my $scalar = '';
662
663sub _hook_into_CPANpm_report
664
# spent 74µs within App::Cpan::_hook_into_CPANpm_report which was called: # once (74µs+0s) by App::Cpan::run at line 505
{
665 no warnings 'redefine';
666
667
# spent 81.8ms (11.6+70.2) within App::Cpan::__ANON__[/usr/local/perls/perl-5.26.1/lib/5.26.1/App/Cpan.pm:673] which was called 804 times, avg 102µs/call: # 612 times (9.98ms+63.4ms) by CPAN::CacheMgr::tidyup at line 41 of CPAN/CacheMgr.pm, avg 120µs/call # 76 times (546µs+2.21ms) by CPAN::CacheMgr::scan_cache at line 240 of CPAN/CacheMgr.pm, avg 36µs/call # 63 times (499µs+2.05ms) by CPAN::HandleConfig::prettyprint at line 267 of CPAN/HandleConfig.pm, avg 40µs/call # 23 times (180µs+746µs) by CPAN::HandleConfig::prettyprint at line 269 of CPAN/HandleConfig.pm, avg 40µs/call # 6 times (80µs+647µs) by CPAN::Shell::optprint at line 1574 of CPAN/Shell.pm, avg 121µs/call # 4 times (43µs+146µs) by CPAN::Shell::o at line 386 of CPAN/Shell.pm, avg 47µs/call # 3 times (44µs+116µs) by CPAN::shell at line 422 of CPAN.pm, avg 53µs/call # 2 times (41µs+169µs) by CPAN::Shell::myprintonce at line 1564 of CPAN/Shell.pm, avg 105µs/call # once (35µs+105µs) by CPAN::Distribution::look at line 1295 of CPAN/Distribution.pm # once (25µs+70µs) by CPAN::shell at line 315 of CPAN.pm # once (15µs+57µs) by CPAN::Index::read_metadata_cache at line 621 of CPAN/Index.pm # once (13µs+46µs) by CPAN::Shell::o at line 453 of CPAN/Shell.pm # once (10µs+43µs) by CPAN::Distribution::CHECKSUM_check_file at line 1541 of CPAN/Distribution.pm # once (17µs+35µs) by CPAN::Shell::o at line 382 of CPAN/Shell.pm # once (13µs+36µs) by CPAN::Shell::o at line 393 of CPAN/Shell.pm # once (9µs+40µs) by CPAN::CacheMgr::scan_cache at line 225 of CPAN/CacheMgr.pm # once (13µs+35µs) by CPAN::cleanup at line 1301 of CPAN.pm # once (9µs+39µs) by CPAN::Index::read_metadata_cache at line 573 of CPAN/Index.pm # once (8µs+38µs) by CPAN::CacheMgr::scan_cache at line 245 of CPAN/CacheMgr.pm # once (10µs+35µs) by CPAN::Module::rematein at line 431 of CPAN/Module.pm # once (11µs+33µs) by CPAN::Shell::o at line 388 of CPAN/Shell.pm # once (7µs+36µs) by CPAN::HandleConfig::prettyprint at line 256 of CPAN/HandleConfig.pm # once (8µs+30µs) by CPAN::Distribution::look at line 1272 of CPAN/Distribution.pm
*CPAN::Shell::myprint = sub {
668804904µs my($self,$what) = @_;
669804995µs $scalar .= $what;
670 $self->print_ornamented($what,
6718048.03ms80470.2ms $CPAN::Config->{colorize_print}||'bold blue on_white',
# spent 70.2ms making 804 calls to CPAN::Shell::print_ornamented, avg 87µs/call
672 );
673146µs };
674
675
# spent 194µs (62+132) within App::Cpan::__ANON__[/usr/local/perls/perl-5.26.1/lib/5.26.1/App/Cpan.pm:681] which was called 2 times, avg 97µs/call: # once (49µs+94µs) by CPAN::shell at line 287 of CPAN.pm # once (13µs+38µs) by CPAN::savehist at line 1333 of CPAN.pm
*CPAN::Shell::mywarn = sub {
67627µs my($self,$what) = @_;
67725µs $scalar .= $what;
678 $self->print_ornamented($what,
679233µs2132µs $CPAN::Config->{colorize_warn}||'bold red on_white'
# spent 132µs making 2 calls to CPAN::Shell::print_ornamented, avg 66µs/call
680 );
681135µs };
682
683 }
684
685sub _clear_cpanpm_output { $scalar = '' }
686
687sub _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
692my @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
705sub _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
738BEGIN {
739my $epic_fail_words = join '|',
740 qw( Error stop(?:ping)? problems force not unsupported
741 fail(?:ed)? Cannot\s+install );
742
743sub _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
754sub _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
762sub _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# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
772sub _turn_on_warnings {
773 carp "Warnings are implemented yet";
774 return HEY_IT_WORKED;
775 }
776
777sub _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# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
784sub _print_help
785 {
786 $logger->info( "Use perldoc to read the documentation" );
787 exec "perldoc $0";
788 }
789
790sub _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
798sub _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');
818We failed to get a copy of the mirror list from the Internet.
819You will need to provide CPAN mirror URLs yourself.
820HERE
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
839sub _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
879sub _split_paths
880 {
881 [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
882 }
883
884
885=pod
886
887Stolen from File::Path::Expand
888
889=cut
890
891sub _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
902sub _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
910sub _get_default_inc
911 {
912 require Config;
913
914 [ @Config::Config{ _vars() }, '.' ];
915 }
916
917sub _vars {
918 qw(
919 installarchlib
920 installprivlib
921 installsitearch
922 installsitelib
923 );
924 }
925
926sub _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
939sub _is_pingable_scheme {
940 my( $uri ) = @_;
941
942 $uri->scheme eq 'file'
943 }
944
945sub _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
960sub _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
980sub _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
989sub _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
1001sub _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
1030sub _load_local_lib # -I
1031 {
1032 $logger->debug( "Loading local::lib" );
1033
1034 my $rc = _safe_load_module("local::lib");
1035 unless( $rc ) {
1036 $logger->logdie( "Could not load local::lib" );
1037 }
1038
1039 local::lib->import;
1040
1041 return HEY_IT_WORKED;
1042 }
1043
1044sub _use_these_mirrors # -M
1045 {
1046 $logger->debug( "Setting per session mirrors" );
1047 unless( $_[0] ) {
1048 $logger->logdie( "The -M switch requires a comma-separated list of mirrors" );
1049 }
1050
1051 $CPAN::Config->{urllist} = [ split /,/, $_[0] ];
1052
1053 $logger->debug( "Mirrors are @{$CPAN::Config->{urllist}}" );
1054
1055 }
1056
1057sub _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
1067sub _recompile
1068 {
1069 $logger->info( "Recompiling dynamically-loaded extensions" );
1070
1071 CPAN::Shell->recompile;
1072
1073 return HEY_IT_WORKED;
1074 }
1075
1076sub _upgrade
1077 {
1078 $logger->info( "Upgrading all modules" );
1079
1080 CPAN::Shell->upgrade();
1081
1082 return HEY_IT_WORKED;
1083 }
1084
1085sub _shell
1086 {
1087 $logger->info( "Dropping into shell" );
1088
1089 CPAN::shell();
1090
1091 return HEY_IT_WORKED;
1092 }
1093
1094sub _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
1116sub _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
1134sub _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
1144sub _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
1168sub _make_path { join "/", qw(authors id), $_[0] }
1169
1170sub _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
1192sub _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
1229sub _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
1256sub _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
1279sub _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
1304sub _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
1332BEGIN {
1333my $modules;
1334sub _get_all_namespaces
1335 {
1336 return $modules if $modules;
1337 $modules = [ map { $_->id } CPAN::Shell->expand( "Module", "/./" ) ];
1338 }
1339}
1340
1341sub _show_out_of_date
1342 {
1343 my $modules = _get_all_namespaces();
1344
1345 printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
1346 print "-" x 73, "\n";
1347
1348 foreach my $module ( @$modules )
1349 {
1350 next unless $module = _expand_module($module);
1351 next unless $module->inst_file;
1352 next if $module->uptodate;
1353 printf "%-40s %.4f %.4f\n",
1354 $module->id,
1355 $module->inst_version ? $module->inst_version : '',
1356 $module->cpan_version;
1357 }
1358
1359 return HEY_IT_WORKED;
1360 }
1361
1362sub _show_author_mods
1363 {
1364 my $args = shift;
1365
1366 my %hash = map { lc $_, 1 } @$args;
1367
1368 my $modules = _get_all_namespaces();
1369
1370 foreach my $module ( @$modules ) {
1371 next unless exists $hash{ lc $module->userid };
1372 print $module->id, "\n";
1373 }
1374
1375 return HEY_IT_WORKED;
1376 }
1377
1378sub _list_all_mods # -l
1379 {
1380 require File::Find;
1381
1382 my $args = shift;
1383
1384
1385 my $fh = \*STDOUT;
1386
1387 INC: foreach my $inc ( @INC )
1388 {
1389 my( $wanted, $reporter ) = _generator();
1390 File::Find::find( { wanted => $wanted }, $inc );
1391
1392 my $count = 0;
1393 FILE: foreach my $file ( @{ $reporter->() } )
1394 {
1395 my $version = _parse_version_safely( $file );
1396
1397 my $module_name = _path_to_module( $inc, $file );
1398 next FILE unless defined $module_name;
1399
1400 print $fh "$module_name\t$version\n";
1401
1402 #last if $count++ > 5;
1403 }
1404 }
1405
1406 return HEY_IT_WORKED;
1407 }
1408
1409sub _generator
1410 {
1411 my @files = ();
1412
1413 sub { push @files,
1414 File::Spec->canonpath( $File::Find::name )
1415 if m/\A\w+\.pm\z/ },
1416 sub { \@files },
1417 }
1418
1419sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
1420 {
1421 my( $file ) = @_;
1422
1423 local $/ = "\n";
1424 local $_; # don't mess with the $_ in the map calling this
1425
1426 return unless open FILE, "<$file";
1427
1428 my $in_pod = 0;
1429 my $version;
1430 while( <FILE> )
1431 {
1432 chomp;
1433 $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
1434 next if $in_pod || /^\s*#/;
1435
1436 next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
1437 my( $sigil, $var ) = ( $1, $2 );
1438
1439 $version = _eval_version( $_, $sigil, $var );
1440 last;
1441 }
1442 close FILE;
1443
1444 return 'undef' unless defined $version;
1445
1446 return $version;
1447 }
1448
1449sub _eval_version
1450 {
1451 my( $line, $sigil, $var ) = @_;
1452
1453 # split package line to hide from PAUSE
1454 my $eval = qq{
1455 package
1456 ExtUtils::MakeMaker::_version;
1457
1458 local $sigil$var;
1459 \$$var=undef; do {
1460 $line
1461 }; \$$var
1462 };
1463
1464 my $version = do {
1465 local $^W = 0;
1466 no strict;
1467 eval( $eval );
1468 };
1469
1470 return $version;
1471 }
1472
1473sub _path_to_module
1474 {
1475 my( $inc, $path ) = @_;
1476 return if length $path < length $inc;
1477
1478 my $module_path = substr( $path, length $inc );
1479 $module_path =~ s/\.pm\z//;
1480
1481 # XXX: this is cheating and doesn't handle everything right
1482 my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
1483 shift @dirs;
1484
1485 my $module_name = join "::", @dirs;
1486
1487 return $module_name;
1488 }
1489
1490
1491sub _expand_module
1492 {
1493 my( $module ) = @_;
1494
1495 my $expanded = CPAN::Shell->expandany( $module );
1496 return $expanded if $expanded;
1497 $expanded = CPAN::Shell->expand( "Module", $module );
1498 unless( defined $expanded ) {
1499 $logger->error( "Could not expand [$module]. Check the module name." );
1500 my $threshold = (
1501 grep { int }
1502 sort { length $a <=> length $b }
1503 length($module)/4, 4
1504 )[0];
1505
1506 my $guesses = _guess_at_module_name( $module, $threshold );
1507 if( defined $guesses and @$guesses ) {
1508 $logger->info( "Perhaps you meant one of these:" );
1509 foreach my $guess ( @$guesses ) {
1510 $logger->info( "\t$guess" );
1511 }
1512 }
1513 return;
1514 }
1515
1516 return $expanded;
1517 }
1518
1519my $guessers = [
1520 [ qw( Text::Levenshtein::XS distance 7 ) ],
1521 [ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 ) ],
1522
1523 [ qw( Text::Levenshtein distance 7 ) ],
1524 [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 ) ],
1525
1526 ];
1527
1528# for -x
1529sub _guess_namespace
1530 {
1531 my $args = shift;
1532
1533 foreach my $arg ( @$args )
1534 {
1535 $logger->debug( "Checking $arg" );
1536 my $guesses = _guess_at_module_name( $arg );
1537
1538 foreach my $guess ( @$guesses ) {
1539 print $guess, "\n";
1540 }
1541 }
1542
1543 return HEY_IT_WORKED;
1544 }
1545
1546sub _list_all_namespaces {
1547 my $modules = _get_all_namespaces();
1548
1549 foreach my $module ( @$modules ) {
1550 print $module, "\n";
1551 }
1552 }
1553
1554BEGIN {
1555my $distance;
1556sub _guess_at_module_name
1557 {
1558 my( $target, $threshold ) = @_;
1559
1560 unless( defined $distance ) {
1561 foreach my $try ( @$guessers ) {
1562 my $can_guess = eval "require $try->[0]; 1" or next;
1563
1564 no strict 'refs';
1565 $distance = \&{ join "::", @$try[0,1] };
1566 $threshold ||= $try->[2];
1567 }
1568 }
1569
1570 unless( $distance ) {
1571 my $modules = join ", ", map { $_->[0] } @$guessers;
1572 substr $modules, rindex( $modules, ',' ), 1, ', and';
1573
1574 $logger->info( "I can suggest names if you install one of $modules" );
1575 return;
1576 }
1577
1578 my $modules = _get_all_namespaces();
1579 $logger->info( "Checking " . @$modules . " namespaces for close match suggestions" );
1580
1581 my %guesses;
1582 foreach my $guess ( @$modules ) {
1583 my $distance = $distance->( $target, $guess );
1584 next if $distance > $threshold;
1585 $guesses{$guess} = $distance;
1586 }
1587
1588 my @guesses = sort { $guesses{$a} <=> $guesses{$b} } keys %guesses;
1589 return [ grep { defined } @guesses[0..9] ];
1590 }
1591}
1592
15931;
1594
1595=back
1596
1597=head1 EXIT VALUES
1598
1599The script exits with zero if it thinks that everything worked, or a
1600positive number if it thinks that something failed. Note, however, that
1601in some cases it has to divine a failure by the output of things it does
1602not control. For now, the exit codes are vague:
1603
1604 1 An unknown error
1605
1606 2 The was an external problem
1607
1608 4 There was an internal problem with the script
1609
1610 8 A module failed to install
1611
1612=head1 TO DO
1613
1614* There is initial support for Log4perl if it is available, but I
1615haven't gone through everything to make the NullLogger work out
1616correctly if Log4perl is not installed.
1617
1618* When I capture CPAN.pm output, I need to check for errors and
1619report them to the user.
1620
1621* Warnings switch
1622
1623* Check then exit
1624
1625=head1 BUGS
1626
1627* none noted
1628
1629=head1 SEE ALSO
1630
1631L<CPAN>, L<App::cpanminus>
1632
1633=head1 SOURCE AVAILABILITY
1634
1635This code is in Github in the CPAN.pm repository:
1636
1637 https://github.com/andk/cpanpm
1638
1639The source used to be tracked separately in another GitHub repo,
1640but the canonical source is now in the above repo.
1641
1642=head1 CREDITS
1643
1644Japheth Cleaver added the bits to allow a forced install (C<-f>).
1645
1646Jim Brandt suggest and provided the initial implementation for the
1647up-to-date and Changes features.
1648
1649Adam Kennedy pointed out that C<exit()> causes problems on Windows
1650where this script ends up with a .bat extension
1651
1652David Golden helps integrate this into the C<CPAN.pm> repos.
1653
1654=head1 AUTHOR
1655
1656brian d foy, C<< <[email protected]> >>
1657
1658=head1 COPYRIGHT
1659
1660Copyright (c) 2001-2015, brian d foy, All Rights Reserved.
1661
1662You may redistribute this under the same terms as Perl itself.
1663
1664=cut
 
# spent 30µs within App::Cpan::CORE:print which was called: # once (30µs+0s) by App::Cpan::_init_logger at line 569
sub App::Cpan::CORE:print; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.