Commit | Line | Data |
0124e695 |
1 | package App::Cpan; |
2 | use strict; |
3 | use warnings; |
4 | use vars qw($VERSION); |
5 | |
d1f5653b |
6 | $VERSION = '1.5701'; |
0124e695 |
7 | |
8 | =head1 NAME |
9 | |
10 | App::Cpan - easily interact with CPAN from the command line |
11 | |
12 | =head1 SYNOPSIS |
13 | |
14 | # with arguments and no switches, installs specified modules |
15 | cpan module_name [ module_name ... ] |
16 | |
17 | # with switches, installs modules with extra behavior |
18 | cpan [-cfFimt] module_name [ module_name ... ] |
19 | |
20 | # use local::lib |
21 | cpan -l module_name [ module_name ... ] |
22 | |
23 | # with just the dot, install from the distribution in the |
24 | # current directory |
25 | cpan . |
26 | |
27 | # without arguments, starts CPAN.pm shell |
28 | cpan |
29 | |
30 | # without arguments, but some switches |
31 | cpan [-ahruvACDLO] |
32 | |
33 | =head1 DESCRIPTION |
34 | |
35 | This script provides a command interface (not a shell) to CPAN. At the |
36 | moment it uses CPAN.pm to do the work, but it is not a one-shot command |
37 | runner for CPAN.pm. |
38 | |
39 | =head2 Options |
40 | |
41 | =over 4 |
42 | |
43 | =item -a |
44 | |
45 | Creates a CPAN.pm autobundle with CPAN::Shell->autobundle. |
46 | |
47 | =item -A module [ module ... ] |
48 | |
49 | Shows the primary maintainers for the specified modules. |
50 | |
51 | =item -c module |
52 | |
53 | Runs a `make clean` in the specified module's directories. |
54 | |
55 | =item -C module [ module ... ] |
56 | |
57 | Show the F<Changes> files for the specified modules |
58 | |
59 | =item -D module [ module ... ] |
60 | |
61 | Show the module details. This prints one line for each out-of-date module |
62 | (meaning, modules locally installed but have newer versions on CPAN). |
63 | Each line has three columns: module name, local version, and CPAN |
64 | version. |
65 | |
66 | =item -f |
67 | |
68 | Force the specified action, when it normally would have failed. Use this |
69 | to install a module even if its tests fail. When you use this option, |
70 | -i is not optional for installing a module when you need to force it: |
71 | |
72 | % cpan -f -i Module::Foo |
73 | |
74 | =item -F |
75 | |
76 | Turn off CPAN.pm's attempts to lock anything. You should be careful with |
77 | this since you might end up with multiple scripts trying to muck in the |
78 | same directory. This isn't so much of a concern if you're loading a special |
79 | config with C<-j>, and that config sets up its own work directories. |
80 | |
81 | =item -g module [ module ... ] |
82 | |
83 | Downloads to the current directory the latest distribution of the module. |
84 | |
85 | =item -G module [ module ... ] |
86 | |
87 | UNIMPLEMENTED |
88 | |
89 | Download to the current directory the latest distribution of the |
90 | modules, unpack each distribution, and create a git repository for each |
91 | distribution. |
92 | |
93 | If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch> |
94 | distribution. |
95 | |
96 | =item -h |
97 | |
98 | Print a help message and exit. When you specify C<-h>, it ignores all |
99 | of the other options and arguments. |
100 | |
101 | =item -i |
102 | |
103 | Install the specified modules. |
104 | |
105 | =item -j Config.pm |
106 | |
107 | Load the file that has the CPAN configuration data. This should have the |
108 | same format as the standard F<CPAN/Config.pm> file, which defines |
109 | C<$CPAN::Config> as an anonymous hash. |
110 | |
111 | =item -J |
112 | |
113 | Dump the configuration in the same format that CPAN.pm uses. This is useful |
114 | for checking the configuration as well as using the dump as a starting point |
115 | for a new, custom configuration. |
116 | |
117 | =item -l |
118 | |
119 | Use C<local::lib>. |
120 | |
121 | =item -L author [ author ... ] |
122 | |
123 | List the modules by the specified authors. |
124 | |
125 | =item -m |
126 | |
127 | Make the specified modules. |
128 | |
129 | =item -O |
130 | |
131 | Show the out-of-date modules. |
132 | |
133 | =item -t |
134 | |
135 | Run a `make test` on the specified modules. |
136 | |
137 | =item -r |
138 | |
139 | Recompiles dynamically loaded modules with CPAN::Shell->recompile. |
140 | |
141 | =item -u |
142 | |
143 | Upgrade all installed modules. Blindly doing this can really break things, |
144 | so keep a backup. |
145 | |
146 | =item -v |
147 | |
148 | Print the script version and CPAN.pm version then exit. |
149 | |
150 | =back |
151 | |
152 | =head2 Examples |
153 | |
154 | # print a help message |
155 | cpan -h |
156 | |
157 | # print the version numbers |
158 | cpan -v |
159 | |
160 | # create an autobundle |
161 | cpan -a |
162 | |
163 | # recompile modules |
164 | cpan -r |
165 | |
166 | # upgrade all installed modules |
167 | cpan -u |
168 | |
169 | # install modules ( sole -i is optional ) |
170 | cpan -i Netscape::Booksmarks Business::ISBN |
171 | |
172 | # force install modules ( must use -i ) |
173 | cpan -fi CGI::Minimal URI |
174 | |
175 | |
176 | =head2 Methods |
177 | |
178 | =over 4 |
179 | |
180 | =cut |
181 | |
182 | use autouse Carp => qw(carp croak cluck); |
183 | use CPAN (); |
184 | use autouse Cwd => qw(cwd); |
185 | use autouse 'Data::Dumper' => qw(Dumper); |
186 | use File::Spec::Functions; |
187 | use File::Basename; |
188 | |
189 | use Getopt::Std; |
190 | |
191 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
192 | # Internal constants |
193 | use constant TRUE => 1; |
194 | use constant FALSE => 0; |
195 | |
196 | |
197 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
198 | # The return values |
199 | use constant HEY_IT_WORKED => 0; |
200 | use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001 |
201 | use constant ITS_NOT_MY_FAULT => 2; |
202 | use constant THE_PROGRAMMERS_AN_IDIOT => 4; |
203 | use constant A_MODULE_FAILED_TO_INSTALL => 8; |
204 | |
205 | |
206 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
207 | # set up the order of options that we layer over CPAN::Shell |
208 | BEGIN { # most of this should be in methods |
209 | use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order |
210 | %Method_table %Method_table_index ); |
211 | |
212 | @META_OPTIONS = qw( h v g G C A D O l L a r j: J ); |
213 | |
214 | $Default = 'default'; |
215 | |
216 | %CPAN_METHODS = ( # map switches to method names in CPAN::Shell |
217 | $Default => 'install', |
218 | 'c' => 'clean', |
219 | 'f' => 'force', |
220 | 'i' => 'install', |
221 | 'm' => 'make', |
222 | 't' => 'test', |
223 | 'u' => 'upgrade', |
224 | ); |
225 | @CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS; |
226 | |
227 | @option_order = ( @META_OPTIONS, @CPAN_OPTIONS ); |
228 | |
229 | |
230 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
231 | # map switches to the subroutines in this script, along with other information. |
232 | # use this stuff instead of hard-coded indices and values |
233 | sub NO_ARGS () { 0 } |
234 | sub ARGS () { 1 } |
235 | sub GOOD_EXIT () { 0 } |
236 | |
237 | %Method_table = ( |
238 | # key => [ sub ref, takes args?, exit value, description ] |
239 | |
240 | # options that do their thing first, then exit |
241 | h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ], |
242 | v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ], |
243 | |
244 | # options that affect other options |
245 | j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ], |
246 | J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ], |
247 | F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ], |
248 | |
249 | # options that do their one thing |
250 | g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ], |
251 | G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ], |
252 | |
253 | C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ], |
254 | A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ], |
255 | D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ], |
256 | O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ], |
257 | |
258 | l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ], |
259 | |
260 | L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ], |
261 | a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ], |
262 | r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ], |
263 | u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ], |
264 | |
265 | c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ], |
266 | f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ], |
267 | i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ], |
268 | 'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ], |
269 | t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ], |
270 | |
271 | ); |
272 | |
273 | %Method_table_index = ( |
274 | code => 0, |
275 | takes_args => 1, |
276 | exit_value => 2, |
277 | description => 3, |
278 | ); |
279 | } |
280 | |
281 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
282 | # finally, do some argument processing |
283 | |
284 | sub _stupid_interface_hack_for_non_rtfmers |
285 | { |
286 | no warnings 'uninitialized'; |
287 | shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 ) |
288 | } |
289 | |
290 | sub _process_options |
291 | { |
292 | my %options; |
293 | |
294 | # if no arguments, just drop into the shell |
295 | if( 0 == @ARGV ) { CPAN::shell(); exit 0 } |
296 | else |
297 | { |
298 | Getopt::Std::getopts( |
299 | join( '', @option_order ), \%options ); |
300 | \%options; |
301 | } |
302 | } |
303 | |
304 | sub _process_setup_options |
305 | { |
306 | my( $class, $options ) = @_; |
307 | |
308 | if( $options->{j} ) |
309 | { |
310 | $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} ); |
311 | delete $options->{j}; |
312 | } |
313 | else |
314 | { |
315 | # this is what CPAN.pm would do otherwise |
316 | CPAN::HandleConfig->load( |
d1f5653b |
317 | # be_silent => 1, # candidate to be ripped out forever |
0124e695 |
318 | write_file => 0, |
319 | ); |
320 | } |
321 | |
322 | if( $options->{F} ) |
323 | { |
324 | $Method_table{F}[ $Method_table_index{code} ]->( $options->{F} ); |
325 | delete $options->{F}; |
326 | } |
327 | |
328 | my $option_count = grep { $options->{$_} } @option_order; |
329 | no warnings 'uninitialized'; |
330 | $option_count -= $options->{'f'}; # don't count force |
331 | |
332 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
333 | # if there are no options, set -i (this line fixes RT ticket 16915) |
334 | $options->{i}++ unless $option_count; |
335 | } |
336 | |
337 | |
338 | =item run() |
339 | |
340 | Just do it. |
341 | |
342 | The C<run> method returns 0 on success and a postive number on |
343 | failure. See the section on EXIT CODES for details on the values. |
344 | |
345 | =cut |
346 | |
347 | my $logger; |
348 | |
349 | sub run |
350 | { |
351 | my $class = shift; |
352 | |
353 | my $return_value = HEY_IT_WORKED; # assume that things will work |
354 | |
355 | $logger = $class->_init_logger; |
356 | $logger->debug( "Using logger from @{[ref $logger]}" ); |
357 | |
358 | $class->_hook_into_CPANpm_report; |
359 | $logger->debug( "Hooked into output" ); |
360 | |
361 | $class->_stupid_interface_hack_for_non_rtfmers; |
362 | $logger->debug( "Patched cargo culting" ); |
363 | |
364 | my $options = $class->_process_options; |
365 | $logger->debug( "Options are @{[Dumper($options)]}" ); |
366 | |
367 | $class->_process_setup_options( $options ); |
368 | |
369 | OPTION: foreach my $option ( @option_order ) |
370 | { |
371 | next unless $options->{$option}; |
372 | |
373 | my( $sub, $takes_args, $description ) = |
374 | map { $Method_table{$option}[ $Method_table_index{$_} ] } |
375 | qw( code takes_args ); |
376 | |
377 | unless( ref $sub eq ref sub {} ) |
378 | { |
379 | $return_value = THE_PROGRAMMERS_AN_IDIOT; |
380 | last OPTION; |
381 | } |
382 | |
383 | $logger->info( "$description -- ignoring other arguments" ) |
384 | if( @ARGV && ! $takes_args ); |
385 | |
386 | $return_value = $sub->( \ @ARGV, $options ); |
387 | |
388 | last; |
389 | } |
390 | |
391 | return $return_value; |
392 | } |
393 | |
394 | { |
395 | package Local::Null::Logger; |
396 | |
397 | sub new { bless \ my $x, $_[0] } |
295f7fb3 |
398 | sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ if $ENV{CPAN_NULL_LOGGER} } |
0124e695 |
399 | sub DESTROY { 1 } |
400 | } |
401 | |
402 | sub _init_logger |
403 | { |
404 | my $log4perl_loaded = eval "require Log::Log4perl; 1"; |
405 | |
406 | unless( $log4perl_loaded ) |
407 | { |
408 | $logger = Local::Null::Logger->new; |
409 | return $logger; |
410 | } |
411 | |
412 | my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO'; |
413 | |
414 | Log::Log4perl::init( \ <<"HERE" ); |
415 | log4perl.rootLogger=$LEVEL, A1 |
416 | log4perl.appender.A1=Log::Log4perl::Appender::Screen |
417 | log4perl.appender.A1.layout=PatternLayout |
418 | log4perl.appender.A1.layout.ConversionPattern=%m%n |
419 | HERE |
420 | |
421 | $logger = Log::Log4perl->get_logger( 'App::Cpan' ); |
422 | } |
423 | |
424 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
425 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
426 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
427 | |
428 | sub _default |
429 | { |
430 | my( $args, $options ) = @_; |
431 | |
432 | my $switch = ''; |
433 | |
434 | # choose the option that we're going to use |
435 | # we'll deal with 'f' (force) later, so skip it |
436 | foreach my $option ( @CPAN_OPTIONS ) |
437 | { |
438 | next if $option eq 'f'; |
439 | next unless $options->{$option}; |
440 | $switch = $option; |
441 | last; |
442 | } |
443 | |
444 | # 1. with no switches, but arguments, use the default switch (install) |
445 | # 2. with no switches and no args, start the shell |
446 | # 3. With a switch but no args, die! These switches need arguments. |
447 | if( not $switch and @$args ) { $switch = $Default; } |
448 | elsif( not $switch and not @$args ) { return CPAN::shell() } |
449 | elsif( $switch and not @$args ) |
450 | { die "Nothing to $CPAN_METHODS{$switch}!\n"; } |
451 | |
452 | # Get and check the method from CPAN::Shell |
453 | my $method = $CPAN_METHODS{$switch}; |
454 | die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method ); |
455 | |
456 | # call the CPAN::Shell method, with force if specified |
457 | my $action = do { |
458 | if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } } |
459 | else { sub { CPAN::Shell->$method( @_ ) } } |
460 | }; |
461 | |
462 | # How do I handle exit codes for multiple arguments? |
463 | my $errors = 0; |
464 | |
465 | foreach my $arg ( @$args ) |
466 | { |
467 | _clear_cpanpm_output(); |
468 | $action->( $arg ); |
469 | |
470 | $errors += defined _cpanpm_output_indicates_failure(); |
471 | } |
472 | |
473 | $errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED; |
474 | } |
475 | |
476 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
477 | |
478 | =for comment |
479 | |
d1f5653b |
480 | CPAN.pm sends all the good stuff either to STDOUT. I have to intercept |
481 | that output so I can find out what happened. |
0124e695 |
482 | |
483 | =cut |
484 | |
485 | { |
486 | my $scalar = ''; |
487 | |
488 | sub _hook_into_CPANpm_report |
489 | { |
490 | no warnings 'redefine'; |
491 | |
492 | *CPAN::Shell::myprint = sub { |
493 | my($self,$what) = @_; |
295f7fb3 |
494 | $scalar .= $what if defined $what; |
0124e695 |
495 | $self->print_ornamented($what, |
496 | $CPAN::Config->{colorize_print}||'bold blue on_white', |
497 | ); |
498 | }; |
499 | |
500 | *CPAN::Shell::mywarn = sub { |
501 | my($self,$what) = @_; |
295f7fb3 |
502 | $scalar .= $what if defined $what; |
0124e695 |
503 | $self->print_ornamented($what, |
504 | $CPAN::Config->{colorize_warn}||'bold red on_white' |
505 | ); |
506 | }; |
507 | |
508 | } |
509 | |
510 | sub _clear_cpanpm_output { $scalar = '' } |
511 | |
512 | sub _get_cpanpm_output { $scalar } |
513 | |
514 | BEGIN { |
515 | my @skip_lines = ( |
516 | qr/^\QWarning \(usually harmless\)/, |
517 | qr/\bwill not store persistent state\b/, |
518 | qr(//hint//), |
519 | qr/^\s+reports\s+/, |
520 | ); |
521 | |
522 | sub _get_cpanpm_last_line |
523 | { |
524 | open my($fh), "<", \ $scalar; |
525 | |
526 | my @lines = <$fh>; |
527 | |
528 | # This is a bit ugly. Once we examine a line, we have to |
529 | # examine the line before it and go through all of the same |
530 | # regexes. I could do something fancy, but this works. |
531 | REGEXES: { |
532 | foreach my $regex ( @skip_lines ) |
533 | { |
534 | if( $lines[-1] =~ m/$regex/ ) |
535 | { |
536 | pop @lines; |
537 | redo REGEXES; # we have to go through all of them for every line! |
538 | } |
539 | } |
540 | } |
541 | |
542 | $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" ); |
543 | |
544 | $lines[-1]; |
545 | } |
546 | } |
547 | |
548 | BEGIN { |
549 | my $epic_fail_words = join '|', |
550 | qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? ); |
551 | |
552 | sub _cpanpm_output_indicates_failure |
553 | { |
554 | my $last_line = _get_cpanpm_last_line(); |
555 | |
556 | my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i; |
557 | $result || (); |
558 | } |
559 | } |
560 | |
561 | sub _cpanpm_output_indicates_success |
562 | { |
563 | my $last_line = _get_cpanpm_last_line(); |
564 | |
565 | my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/; |
566 | $result || (); |
567 | } |
568 | |
569 | sub _cpanpm_output_is_vague |
570 | { |
571 | return FALSE if |
572 | _cpanpm_output_indicates_failure() || |
573 | _cpanpm_output_indicates_success(); |
574 | |
575 | return TRUE; |
576 | } |
577 | |
578 | } |
579 | |
580 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
581 | sub _print_help |
582 | { |
583 | $logger->info( "Use perldoc to read the documentation" ); |
584 | exec "perldoc $0"; |
585 | } |
586 | |
587 | sub _print_version |
588 | { |
589 | $logger->info( |
590 | "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION ); |
591 | |
592 | return HEY_IT_WORKED; |
593 | } |
594 | |
595 | sub _create_autobundle |
596 | { |
597 | $logger->info( |
598 | "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" ); |
599 | |
600 | CPAN::Shell->autobundle; |
601 | |
602 | return HEY_IT_WORKED; |
603 | } |
604 | |
605 | sub _recompile |
606 | { |
607 | $logger->info( "Recompiling dynamically-loaded extensions" ); |
608 | |
609 | CPAN::Shell->recompile; |
610 | |
611 | return HEY_IT_WORKED; |
612 | } |
613 | |
614 | sub _upgrade |
615 | { |
616 | $logger->info( "Upgrading all modules" ); |
617 | |
618 | CPAN::Shell->upgrade(); |
619 | |
620 | return HEY_IT_WORKED; |
621 | } |
622 | |
623 | sub _load_config # -j |
624 | { |
625 | my $file = shift || ''; |
626 | |
627 | # should I clear out any existing config here? |
628 | $CPAN::Config = {}; |
629 | delete $INC{'CPAN/Config.pm'}; |
630 | croak( "Config file [$file] does not exist!\n" ) unless -e $file; |
631 | |
632 | my $rc = eval "require '$file'"; |
633 | |
634 | # CPAN::HandleConfig::require_myconfig_or_config looks for this |
635 | $INC{'CPAN/MyConfig.pm'} = 'fake out!'; |
636 | |
637 | # CPAN::HandleConfig::load looks for this |
638 | $CPAN::Config_loaded = 'fake out'; |
639 | |
640 | croak( "Could not load [$file]: $@\n") unless $rc; |
641 | |
642 | return HEY_IT_WORKED; |
643 | } |
644 | |
645 | sub _dump_config |
646 | { |
647 | my $args = shift; |
648 | require Data::Dumper; |
649 | |
650 | my $fh = $args->[0] || \*STDOUT; |
651 | |
652 | my $dd = Data::Dumper->new( |
653 | [$CPAN::Config], |
654 | ['$CPAN::Config'] |
655 | ); |
656 | |
657 | print $fh $dd->Dump, "\n1;\n__END__\n"; |
658 | |
659 | return HEY_IT_WORKED; |
660 | } |
661 | |
662 | sub _lock_lobotomy |
663 | { |
664 | no warnings 'redefine'; |
665 | |
666 | *CPAN::_flock = sub { 1 }; |
667 | *CPAN::checklock = sub { 1 }; |
668 | |
669 | return HEY_IT_WORKED; |
670 | } |
671 | |
672 | sub _download |
673 | { |
674 | my $args = shift; |
675 | |
676 | local $CPAN::DEBUG = 1; |
677 | |
678 | my %paths; |
679 | |
680 | foreach my $module ( @$args ) |
681 | { |
682 | $logger->info( "Checking $module" ); |
683 | my $path = CPAN::Shell->expand( "Module", $module )->cpan_file; |
684 | |
685 | $logger->debug( "Inst file would be $path\n" ); |
686 | |
687 | $paths{$module} = _get_file( _make_path( $path ) ); |
688 | } |
689 | |
690 | return \%paths; |
691 | } |
692 | |
693 | sub _make_path { join "/", qw(authors id), $_[0] } |
694 | |
695 | sub _get_file |
696 | { |
697 | my $path = shift; |
698 | |
699 | my $loaded = eval "require LWP::Simple; 1;"; |
700 | croak "You need LWP::Simple to use features that fetch files from CPAN\n" |
701 | unless $loaded; |
702 | |
703 | my $file = substr $path, rindex( $path, '/' ) + 1; |
704 | my $store_path = catfile( cwd(), $file ); |
705 | $logger->debug( "Store path is $store_path" ); |
706 | |
707 | foreach my $site ( @{ $CPAN::Config->{urllist} } ) |
708 | { |
709 | my $fetch_path = join "/", $site, $path; |
710 | $logger->debug( "Trying $fetch_path" ); |
711 | last if LWP::Simple::getstore( $fetch_path, $store_path ); |
712 | } |
713 | |
714 | return $store_path; |
715 | } |
716 | |
717 | sub _gitify |
718 | { |
719 | my $args = shift; |
720 | |
721 | my $loaded = eval "require Archive::Extract; 1;"; |
722 | croak "You need Archive::Extract to use features that gitify distributions\n" |
723 | unless $loaded; |
724 | |
725 | my $starting_dir = cwd(); |
726 | |
727 | foreach my $module ( @$args ) |
728 | { |
729 | $logger->info( "Checking $module" ); |
730 | my $path = CPAN::Shell->expand( "Module", $module )->cpan_file; |
731 | |
732 | my $store_paths = _download( [ $module ] ); |
733 | $logger->debug( "gitify Store path is $store_paths->{$module}" ); |
734 | my $dirname = dirname( $store_paths->{$module} ); |
735 | |
736 | my $ae = Archive::Extract->new( archive => $store_paths->{$module} ); |
737 | $ae->extract( to => $dirname ); |
738 | |
739 | chdir $ae->extract_path; |
740 | |
741 | my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git'; |
742 | croak "Could not find $git" unless -e $git; |
743 | croak "$git is not executable" unless -x $git; |
744 | |
745 | # can we do this in Pure Perl? |
746 | system( $git, 'init' ); |
747 | system( $git, qw( add . ) ); |
748 | system( $git, qw( commit -a -m ), 'initial import' ); |
749 | } |
750 | |
751 | chdir $starting_dir; |
752 | |
753 | return HEY_IT_WORKED; |
754 | } |
755 | |
756 | sub _show_Changes |
757 | { |
758 | my $args = shift; |
759 | |
760 | foreach my $arg ( @$args ) |
761 | { |
762 | $logger->info( "Checking $arg\n" ); |
763 | |
764 | my $module = eval { CPAN::Shell->expand( "Module", $arg ) }; |
765 | my $out = _get_cpanpm_output(); |
766 | |
767 | next unless eval { $module->inst_file }; |
768 | #next if $module->uptodate; |
769 | |
770 | ( my $id = $module->id() ) =~ s/::/\-/; |
771 | |
772 | my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" . |
773 | $id . "-" . $module->cpan_version() . "/"; |
774 | |
775 | #print "URL: $url\n"; |
776 | _get_changes_file($url); |
777 | } |
778 | |
779 | return HEY_IT_WORKED; |
780 | } |
781 | |
782 | sub _get_changes_file |
783 | { |
784 | croak "Reading Changes files requires LWP::Simple and URI\n" |
785 | unless eval "require LWP::Simple; require URI; 1"; |
786 | |
787 | my $url = shift; |
788 | |
789 | my $content = LWP::Simple::get( $url ); |
790 | $logger->info( "Got $url ..." ) if defined $content; |
791 | #print $content; |
792 | |
793 | my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi; |
794 | |
795 | my $changes_url = URI->new_abs( $change_link, $url ); |
796 | $logger->debug( "Change link is: $changes_url" ); |
797 | |
798 | my $changes = LWP::Simple::get( $changes_url ); |
799 | |
800 | print $changes; |
801 | |
802 | return HEY_IT_WORKED; |
803 | } |
804 | |
805 | sub _show_Author |
806 | { |
807 | my $args = shift; |
808 | |
809 | foreach my $arg ( @$args ) |
810 | { |
811 | my $module = CPAN::Shell->expand( "Module", $arg ); |
812 | unless( $module ) |
813 | { |
814 | $logger->info( "Didn't find a $arg module, so no author!" ); |
815 | next; |
816 | } |
817 | |
818 | my $author = CPAN::Shell->expand( "Author", $module->userid ); |
819 | |
820 | next unless $module->userid; |
821 | |
822 | printf "%-25s %-8s %-25s %s\n", |
823 | $arg, $module->userid, $author->email, $author->fullname; |
824 | } |
825 | |
826 | return HEY_IT_WORKED; |
827 | } |
828 | |
829 | sub _show_Details |
830 | { |
831 | my $args = shift; |
832 | |
833 | foreach my $arg ( @$args ) |
834 | { |
835 | my $module = CPAN::Shell->expand( "Module", $arg ); |
836 | my $author = CPAN::Shell->expand( "Author", $module->userid ); |
837 | |
838 | next unless $module->userid; |
839 | |
840 | print "$arg\n", "-" x 73, "\n\t"; |
841 | print join "\n\t", |
842 | $module->description ? $module->description : "(no description)", |
843 | $module->cpan_file, |
844 | $module->inst_file, |
845 | 'Installed: ' . $module->inst_version, |
846 | 'CPAN: ' . $module->cpan_version . ' ' . |
847 | ($module->uptodate ? "" : "Not ") . "up to date", |
848 | $author->fullname . " (" . $module->userid . ")", |
849 | $author->email; |
850 | print "\n\n"; |
851 | |
852 | } |
853 | |
854 | return HEY_IT_WORKED; |
855 | } |
856 | |
857 | sub _show_out_of_date |
858 | { |
859 | my @modules = CPAN::Shell->expand( "Module", "/./" ); |
860 | |
861 | printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN"; |
862 | print "-" x 73, "\n"; |
863 | |
864 | foreach my $module ( @modules ) |
865 | { |
866 | next unless $module->inst_file; |
867 | next if $module->uptodate; |
868 | printf "%-40s %.4f %.4f\n", |
869 | $module->id, |
870 | $module->inst_version ? $module->inst_version : '', |
871 | $module->cpan_version; |
872 | } |
873 | |
874 | return HEY_IT_WORKED; |
875 | } |
876 | |
877 | sub _show_author_mods |
878 | { |
879 | my $args = shift; |
880 | |
881 | my %hash = map { lc $_, 1 } @$args; |
882 | |
883 | my @modules = CPAN::Shell->expand( "Module", "/./" ); |
884 | |
885 | foreach my $module ( @modules ) |
886 | { |
887 | next unless exists $hash{ lc $module->userid }; |
888 | print $module->id, "\n"; |
889 | } |
890 | |
891 | return HEY_IT_WORKED; |
892 | } |
893 | |
894 | sub _list_all_mods |
895 | { |
896 | require File::Find; |
897 | |
898 | my $args = shift; |
899 | |
900 | |
901 | my $fh = \*STDOUT; |
902 | |
903 | INC: foreach my $inc ( @INC ) |
904 | { |
905 | my( $wanted, $reporter ) = _generator(); |
906 | File::Find::find( { wanted => $wanted }, $inc ); |
907 | |
908 | my $count = 0; |
909 | FILE: foreach my $file ( @{ $reporter->() } ) |
910 | { |
911 | my $version = _parse_version_safely( $file ); |
912 | |
913 | my $module_name = _path_to_module( $inc, $file ); |
914 | next FILE unless defined $module_name; |
915 | |
916 | print $fh "$module_name\t$version\n"; |
917 | |
918 | #last if $count++ > 5; |
919 | } |
920 | } |
921 | |
922 | return HEY_IT_WORKED; |
923 | } |
924 | |
925 | sub _generator |
926 | { |
927 | my @files = (); |
928 | |
929 | sub { push @files, |
930 | File::Spec->canonpath( $File::Find::name ) |
931 | if m/\A\w+\.pm\z/ }, |
932 | sub { \@files }, |
933 | } |
934 | |
935 | sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored |
936 | { |
937 | my( $file ) = @_; |
938 | |
939 | local $/ = "\n"; |
940 | local $_; # don't mess with the $_ in the map calling this |
941 | |
942 | return unless open FILE, "<$file"; |
943 | |
944 | my $in_pod = 0; |
945 | my $version; |
946 | while( <FILE> ) |
947 | { |
948 | chomp; |
949 | $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod; |
950 | next if $in_pod || /^\s*#/; |
951 | |
952 | next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; |
953 | my( $sigil, $var ) = ( $1, $2 ); |
954 | |
955 | $version = _eval_version( $_, $sigil, $var ); |
956 | last; |
957 | } |
958 | close FILE; |
959 | |
960 | return 'undef' unless defined $version; |
961 | |
962 | return $version; |
963 | } |
964 | |
965 | sub _eval_version |
966 | { |
967 | my( $line, $sigil, $var ) = @_; |
968 | |
969 | my $eval = qq{ |
970 | package ExtUtils::MakeMaker::_version; |
971 | |
972 | local $sigil$var; |
973 | \$$var=undef; do { |
974 | $line |
975 | }; \$$var |
976 | }; |
977 | |
978 | my $version = do { |
979 | local $^W = 0; |
980 | no strict; |
981 | eval( $eval ); |
982 | }; |
983 | |
984 | return $version; |
985 | } |
986 | |
987 | sub _path_to_module |
988 | { |
989 | my( $inc, $path ) = @_; |
990 | return if length $path< length $inc; |
991 | |
992 | my $module_path = substr( $path, length $inc ); |
993 | $module_path =~ s/\.pm\z//; |
994 | |
995 | # XXX: this is cheating and doesn't handle everything right |
996 | my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path ); |
997 | shift @dirs; |
998 | |
999 | my $module_name = join "::", @dirs; |
1000 | |
1001 | return $module_name; |
1002 | } |
1003 | |
1004 | 1; |
1005 | |
1006 | =back |
1007 | |
1008 | =head1 EXIT VALUES |
1009 | |
1010 | The script exits with zero if it thinks that everything worked, or a |
1011 | positive number if it thinks that something failed. Note, however, that |
1012 | in some cases it has to divine a failure by the output of things it does |
1013 | not control. For now, the exit codes are vague: |
1014 | |
1015 | 1 An unknown error |
1016 | |
1017 | 2 The was an external problem |
1018 | |
1019 | 4 There was an internal problem with the script |
1020 | |
1021 | 8 A module failed to install |
1022 | |
1023 | =head1 TO DO |
1024 | |
1025 | * There is initial support for Log4perl if it is available, but I |
1026 | haven't gone through everything to make the NullLogger work out |
1027 | correctly if Log4perl is not installed. |
1028 | |
1029 | * When I capture CPAN.pm output, I need to check for errors and |
1030 | report them to the user. |
1031 | |
1032 | =head1 BUGS |
1033 | |
1034 | * none noted |
1035 | |
1036 | =head1 SEE ALSO |
1037 | |
1038 | Most behaviour, including environment variables and configuration, |
1039 | comes directly from CPAN.pm. |
1040 | |
1041 | =head1 SOURCE AVAILABILITY |
1042 | |
1043 | This code is in Github: |
1044 | |
1045 | git://github.com/briandfoy/cpan_script.git |
1046 | |
1047 | =head1 CREDITS |
1048 | |
1049 | Japheth Cleaver added the bits to allow a forced install (-f). |
1050 | |
1051 | Jim Brandt suggest and provided the initial implementation for the |
1052 | up-to-date and Changes features. |
1053 | |
1054 | Adam Kennedy pointed out that exit() causes problems on Windows |
1055 | where this script ends up with a .bat extension |
1056 | |
1057 | =head1 AUTHOR |
1058 | |
1059 | brian d foy, C<< <bdfoy@cpan.org> >> |
1060 | |
1061 | =head1 COPYRIGHT |
1062 | |
1063 | Copyright (c) 2001-2009, brian d foy, All Rights Reserved. |
1064 | |
1065 | You may redistribute this under the same terms as Perl itself. |
1066 | |
1067 | =cut |