projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Update CPANPLUS to 0.85_06
[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / Shell / Default.pm
CommitLineData
6aaee015 1package CPANPLUS::Shell::Default;
2
3use strict;
4
5
6use CPANPLUS::Error;
7use CPANPLUS::Backend;
8use CPANPLUS::Configure::Setup;
9use CPANPLUS::Internals::Constants;
10use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL];
11
12use Cwd;
13use IPC::Cmd;
14use Term::UI;
15use Data::Dumper;
16use Term::ReadLine;
17
18use Module::Load qw[load];
19use Params::Check qw[check];
20use Module::Load::Conditional qw[can_load check_install];
21use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
22
23local $Params::Check::VERBOSE = 1;
24local $Data::Dumper::Indent = 1; # for dumpering from !
25
26BEGIN {
27 use vars qw[ $VERSION @ISA ];
28 @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ];
4443dd53 29 $VERSION = "0.86_06";
6aaee015 30}
31
32load CPANPLUS::Shell;
33
34
35my $map = {
36 'm' => '_search_module',
37 'a' => '_search_author',
38 '!' => '_bang',
39 '?' => '_help',
40 'h' => '_help',
41 'q' => '_quit',
42 'r' => '_readme',
43 'v' => '_show_banner',
44 'w' => '__display_results',
45 'd' => '_fetch',
46 'z' => '_shell',
47 'f' => '_distributions',
48 'x' => '_reload_indices',
49 'i' => '_install',
50 't' => '_install',
51 'l' => '_details',
52 'p' => '_print',
53 's' => '_set_conf',
54 'o' => '_uptodate',
55 'b' => '_autobundle',
56 'u' => '_uninstall',
57 '/' => '_meta', # undocumented for now
58 'c' => '_reports',
59};
60### free letters: e g j k n y ###
61
62
63### will be filled if you have a .default-shell.rc and
64### Config::Auto installed
65my $rc = {};
66
67### the shell object, scoped to the file ###
68my $Shell;
69my $Brand = loc('CPAN Terminal');
70my $Prompt = $Brand . '> ';
71
72=pod
73
74=head1 NAME
75
76CPANPLUS::Shell::Default
77
78=head1 SYNOPSIS
79
80 ### loading the shell:
81 $ cpanp # run 'cpanp' from the command line
82 $ perl -MCPANPLUS -eshell # load the shell from the command line
83
84
85 use CPANPLUS::Shell qw[Default]; # load this shell via the API
86 # always done via CPANPLUS::Shell
87
88 my $ui = CPANPLUS::Shell->new;
89 $ui->shell; # run the shell
90 $ui->dispatch_on_input( input => 'x'); # update the source using the
91 # dispatch method
92
93 ### when in the shell:
94 ### Note that all commands can also take options.
95 ### Look at their underlying CPANPLUS::Backend methods to see
96 ### what options those are.
97 cpanp> h # show help messages
98 cpanp> ? # show help messages
99
100 cpanp> m Acme # find acme modules, allows regexes
101 cpanp> a KANE # find modules by kane, allows regexes
102 cpanp> f Acme::Foo # get a list of all releases of Acme::Foo
103
104 cpanp> i Acme::Foo # install Acme::Foo
105 cpanp> i Acme-Foo-1.3 # install version 1.3 of Acme::Foo
106 cpanp> i <URI> # install from URI, like ftp://foo.com/X.tgz
107 cpanp> i 1 3..5 # install search results 1, 3, 4 and 5
108 cpanp> i * # install all search results
109 cpanp> a KANE; i *; # find modules by kane, install all results
110 cpanp> t Acme::Foo # test Acme::Foo, without installing it
111 cpanp> u Acme::Foo # uninstall Acme::Foo
112 cpanp> d Acme::Foo # download Acme::Foo
113 cpanp> z Acme::Foo # download & extract Acme::Foo, then open a
114 # shell in the extraction directory
115
116 cpanp> c Acme::Foo # get a list of test results for Acme::Foo
117 cpanp> l Acme::Foo # view details about the Acme::Foo package
118 cpanp> r Acme::Foo # view Acme::Foo's README file
119 cpanp> o # get a list of all installed modules that
120 # are out of date
121 cpanp> o 1..3 # list uptodateness from a previous search
122
123 cpanp> s conf # show config settings
124 cpanp> s conf md5 1 # enable md5 checks
125 cpanp> s program # show program settings
126 cpanp> s edit # edit config file
127 cpanp> s reconfigure # go through initial configuration again
128 cpanp> s selfupdate # update your CPANPLUS install
129 cpanp> s save # save config to disk
130 cpanp> s mirrors # show currently selected mirrors
131
132 cpanp> ! [PERL CODE] # execute the following perl code
133
134 cpanp> b # create an autobundle for this computers
135 # perl installation
136 cpanp> x # reload index files (purges cache)
137 cpanp> x --update_source # reload index files, get fresh source files
138 cpanp> p [FILE] # print error stack (to a file)
139 cpanp> v # show the banner
140 cpanp> w # show last search results again
141
142 cpanp> q # quit the shell
143
144 cpanp> /plugins # list avialable plugins
145 cpanp> /? PLUGIN # list help test of <PLUGIN>
146
147 ### common options:
148 cpanp> i ... --skiptest # skip tests
149 cpanp> i ... --force # force all operations
150 cpanp> i ... --verbose # run in verbose mode
151
152=head1 DESCRIPTION
153
154This module provides the default user interface to C<CPANPLUS>. You
155can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>.
156
157=cut
158
159sub new {
160 my $class = shift;
161
5bc5f6dc 162 my $cb = CPANPLUS::Backend->new( @_ );
6aaee015 163 my $self = $class->SUPER::_init(
164 brand => $Brand,
165 term => Term::ReadLine->new( $Brand ),
166 prompt => $Prompt,
167 backend => $cb,
168 format => "%4s %-55s %8s %-10s\n",
169 dist_format => "%4s %-42s %-12s %8s %-10s\n",
170 );
171 ### make it available package wide ###
172 $Shell = $self;
173
174 my $rc_file = File::Spec->catfile(
175 $cb->configure_object->get_conf('base'),
176 DOT_SHELL_DEFAULT_RC,
177 );
178
179
180 if( -e $rc_file && -r _ ) {
5bc5f6dc 181 $rc = $self->_read_configuration_from_rc( $rc_file );
6aaee015 182 }
183
184 ### register install callback ###
185 $cb->_register_callback(
186 name => 'install_prerequisite',
187 code => \&__ask_about_install,
188 );
189
190 ### execute any login commands specified ###
191 $self->dispatch_on_input( input => $rc->{'login'} )
192 if defined $rc->{'login'};
193
194 ### register test report callbacks ###
195 $cb->_register_callback(
196 name => 'edit_test_report',
197 code => \&__ask_about_edit_test_report,
198 );
199
200 $cb->_register_callback(
201 name => 'send_test_report',
202 code => \&__ask_about_send_test_report,
203 );
204
622d31ac 205 $cb->_register_callback(
206 name => 'proceed_on_test_failure',
207 code => \&__ask_about_test_failure,
208 );
209
5bc5f6dc 210 ### load all the plugins
211 $self->_plugins_init;
6aaee015 212
213 return $self;
214}
215
216sub shell {
217 my $self = shift;
218 my $term = $self->term;
219 my $conf = $self->backend->configure_object;
220
221 $self->_show_banner;
5bc5f6dc 222 $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner?
6aaee015 223 $self->_show_random_tip if $conf->get_conf('show_startup_tip');
5bc5f6dc 224 $self->_input_loop && $self->__print( "\n" );
6aaee015 225 $self->_quit;
226}
227
228sub _input_loop {
229 my $self = shift;
230 my $term = $self->term;
231 my $cb = $self->backend;
232
233 my $normal_quit = 0;
234 while (
235 defined (my $input = eval { $term->readline($self->prompt) } )
236 or $self->_signals->{INT}{count} == 1
237 ) {
238 ### re-initiate all signal handlers
239 while (my ($sig, $entry) = each %{$self->_signals} ) {
240 $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
241 }
242
5bc5f6dc 243 $self->__print( "\n" );
6aaee015 244 last if $self->dispatch_on_input( input => $input );
245
246 ### flush the lib cache ###
247 $cb->_flush( list => [qw|lib load|] );
248
249 } continue {
4443dd53 250 ### clear the sigint count
6aaee015 251 $self->_signals->{INT}{count}--
4443dd53 252 if $self->_signals->{INT}{count};
253
254 ### reset the 'install prereq?' cached answer
255 $self->settings->{'install_all_prereqs'} = undef;
256
6aaee015 257 }
258
259 return 1;
260}
261
262### return 1 to quit ###
263sub dispatch_on_input {
264 my $self = shift;
265 my $conf = $self->backend->configure_object();
266 my $term = $self->term;
267 my %hash = @_;
268
269 my($string, $noninteractive);
270 my $tmpl = {
271 input => { required => 1, store => \$string },
272 noninteractive => { required => 0, store => \$noninteractive },
273 };
274
275 check( $tmpl, \%hash ) or return;
276
277 ### indicates whether or not the user will receive a shell
278 ### prompt after the command has finished.
279 $self->noninteractive($noninteractive) if defined $noninteractive;
280
281 my @cmds = split ';', $string;
282 while( my $input = shift @cmds ) {
283
284 ### to send over the socket ###
285 my $org_input = $input;
286
287 my $key; my $options;
288 { ### make whitespace not count when using special chars
289 { $input =~ s|^\s*([!?/])|$1 |; }
290
291 ### get the first letter of the input
292 $input =~ s|^\s*([\w\?\!/])\w*||;
293
294 chomp $input;
295 $key = lc($1);
296
297 ### we figured out what the command was...
298 ### if we have more input, that DOES NOT start with a white
299 ### space char, we misparsed.. like 'Test::Foo::Bar', which
300 ### would turn into 't', '::Foo::Bar'...
301 if( $input and $input !~ s/^\s+// ) {
5bc5f6dc 302 $self->__print( loc("Could not understand command: %1\n".
6aaee015 303 "Possibly missing command before argument(s)?\n",
5bc5f6dc 304 $org_input) );
6aaee015 305 return;
306 }
307
308 ### allow overrides from the config file ###
309 if( defined $rc->{$key} ) {
310 $input = $rc->{$key} . $input;
311 }
312
313 ### grab command line options like --no-force and --verbose ###
314 ($options,$input) = $term->parse_options($input)
315 unless $key eq '!';
316 }
317
318 ### emtpy line? ###
319 return unless $key;
320
321 ### time to quit ###
322 return 1 if $key eq 'q';
323
324 my $method = $map->{$key};
325
326 ### dispatch meta locally at all times ###
327 $self->$method(input => $input, options => $options), next
328 if $key eq '/';
329
330 ### flush unless we're trying to print the stack
331 CPANPLUS::Error->flush unless $key eq 'p';
332
333 ### connected over a socket? ###
334 if( $self->remote ) {
335
336 ### unsupported commands ###
337 if( $key eq 'z' or
338 ($key eq 's' and $input =~ /^\s*edit/)
339 ) {
5bc5f6dc 340 $self->__print( "\n",
d0baa00e 341 loc( "Command '%1' not supported over remote connection",
342 join ' ', $key, $input
5bc5f6dc 343 ), "\n\n" );
6aaee015 344
345 } else {
346 my($status,$buff) = $self->__send_remote_command($org_input);
347
5bc5f6dc 348 $self->__print( "\n", loc("Command failed!"), "\n\n" )
349 unless $status;
6aaee015 350
351 $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount;
5bc5f6dc 352 $self->__print( $buff );
6aaee015 353 $self->_pager_close;
354 }
355
356 ### or just a plain local shell? ###
357 } else {
358
359 unless( $self->can($method) ) {
5bc5f6dc 360 $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n");
6aaee015 361 $self->_help;
362
363 } else {
364
365 ### some methods don't need modules ###
366 my @mods;
367 @mods = $self->_select_modules($input)
368 unless grep {$key eq $_} qw[! m a v w x p s b / ? h];
369
370 eval { $self->$method( modules => \@mods,
371 options => $options,
372 input => $input,
373 choice => $key )
374 };
375 error( $@ ) if $@;
376 }
377 }
378 }
379
380 return;
381}
382
383sub _select_modules {
384 my $self = shift;
385 my $input = shift or return;
386 my $cache = $self->cache;
387 my $cb = $self->backend;
388
389 ### expand .. in $input
390 $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b}
391 {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg;
392
393 $input = join(' ', 1 .. $#{$cache}) if $input eq '*';
394 $input =~ s/'/::/g; # perl 4 convention
395
396 my @rv;
397 for my $mod (split /\s+/, $input) {
398
399 ### it's a cache look up ###
400 if( $mod =~ /^\d+/ and $mod > 0 ) {
401 unless( scalar @$cache ) {
5bc5f6dc 402 $self->__print( loc("No search was done yet!"), "\n" );
6aaee015 403
404 } elsif ( my $obj = $cache->[$mod] ) {
405 push @rv, $obj;
406
407 } else {
5bc5f6dc 408 $self->__print( loc("No such module: %1", $mod), "\n" );
6aaee015 409 }
410
411 } else {
412 my $obj = $cb->parse_module( module => $mod );
413
414 unless( $obj ) {
5bc5f6dc 415 $self->__print( loc("No such module: %1", $mod), "\n" );
6aaee015 416
417 } else {
418 push @rv, $obj;
419 }
420 }
421 }
422
423 unless( scalar @rv ) {
5bc5f6dc 424 $self->__print( loc("No modules found to operate on!\n") );
6aaee015 425 return;
426 } else {
427 return @rv;
428 }
429}
430
431sub _format_version {
432 my $self = shift;
4443dd53 433 my $version = shift || 0;
6aaee015 434
435 ### fudge $version into the 'optimal' format
436 $version = 0 if $version eq 'undef';
437 $version =~ s/_//g; # everything after gets stripped off otherwise
438
439 ### allow 6 digits after the dot, as that's how perl stringifies
440 ### x.y.z numbers.
441 $version = sprintf('%3.6f', $version);
442 $version = '' if $version == '0.00';
443 $version =~ s/(00{0,3})$/' ' x (length $1)/e;
444
445 return $version;
446}
447
448sub __display_results {
449 my $self = shift;
450 my $cache = $self->cache;
451
452 my @rv = @$cache;
453
454 if( scalar @rv ) {
455
456 $self->_pager_open if $#{$cache} >= $self->_term_rowcount;
457
458 my $i = 1;
459 for my $mod (@rv) {
460 next unless $mod; # first one is undef
461 # humans start counting at 1
462
463 ### for dists only -- we have checksum info
464 if( $mod->mtime ) {
5bc5f6dc 465 $self->__printf(
466 $self->dist_format,
467 $i,
468 $mod->module,
469 $mod->mtime,
470 $self->_format_version( $mod->version ),
471 $mod->author->cpanid
472 );
6aaee015 473
474 } else {
5bc5f6dc 475 $self->__printf(
476 $self->format,
477 $i,
478 $mod->module,
479 $self->_format_version( $mod->version ),
480 $mod->author->cpanid
481 );
6aaee015 482 }
483 $i++;
484 }
485
486 $self->_pager_close;
487
488 } else {
5bc5f6dc 489 $self->__print( loc("No results to display"), "\n" );
6aaee015 490 }
491}
492
493
494sub _quit {
495 my $self = shift;
496
497 $self->dispatch_on_input( input => $rc->{'logout'} )
498 if defined $rc->{'logout'};
499
5bc5f6dc 500 $self->__print( loc("Exiting CPANPLUS shell"), "\n" );
6aaee015 501}
502
503###########################
504### actual command subs ###
505###########################
506
507
508### print out the help message ###
509### perhaps, '?' should be a slightly different version ###
502c7995 510{ my @help;
511 sub _help {
512 my $self = shift;
513 my %hash = @_;
514
515 my $input;
516 { local $Params::Check::ALLOW_UNKNOWN = 1;
517
518 my $tmpl = {
519 input => { required => 0, store => \$input }
520 };
521
522 my $args = check( $tmpl, \%hash ) or return;
523 }
524
525 @help = (
6aaee015 526loc('[General]' ),
527loc(' h | ? # display help' ),
528loc(' q # exit' ),
529loc(' v # version information' ),
530loc('[Search]' ),
531loc(' a AUTHOR ... # search by author(s)' ),
532loc(' m MODULE ... # search by module(s)' ),
533loc(' f MODULE ... # list all releases of a module' ),
534loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ),
535loc(' w # display the result of your last search again' ),
536loc('[Operations]' ),
537loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ),
538loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ),
539loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ),
540loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ),
541loc(' d MODULE | NUMBER ... # download module(s)' ),
542loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ),
543loc(' r MODULE | NUMBER ... # display README files of module(s)' ),
544loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ),
545loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ),
546loc('[Local Administration]' ),
547loc(' b # write a bundle file for your configuration' ),
548loc(' s program [OPT VALUE] # set program locations for this session' ),
549loc(' s conf [OPT VALUE] # set config options for this session' ),
550loc(' s mirrors # show currently selected mirrors' ),
551loc(' s reconfigure # reconfigure settings ' ),
552loc(' s selfupdate # update your CPANPLUS install '),
553loc(' s save [user|system] # save settings for this user or systemwide' ),
554loc(' s edit [user|system] # open configuration file in editor and reload' ),
555loc(' ! EXPR # evaluate a perl statement' ),
556loc(' p [FILE] # print the error stack (optionally to a file)' ),
557loc(' x # reload CPAN indices (purges cache)' ),
502c7995 558loc(' x --update_source # reload CPAN indices, get fresh source files' ),
559loc('[Common Options]' ),
560loc(' i ... --skiptest # skip tests' ),
561loc(' i ... --force # force all operations' ),
562loc(' i ... --verbose # run in verbose mode' ),
6aaee015 563loc('[Plugins]' ),
564loc(' /plugins # list available plugins' ),
565loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ),
566
502c7995 567 ) unless @help;
568
569 $self->_pager_open if (@help >= $self->_term_rowcount);
570 ### XXX: functional placeholder for actual 'detailed' help.
5bc5f6dc 571 $self->__print( "Detailed help for the command '$input' is " .
572 "not available.\n\n" ) if length $input;
573 $self->__print( map {"$_\n"} @help );
574 $self->__print( $/ );
502c7995 575 $self->_pager_close;
576 }
6aaee015 577}
578
579### eval some code ###
580sub _bang {
581 my $self = shift;
582 my $cb = $self->backend;
583 my %hash = @_;
584
585
586 my $input;
587 { local $Params::Check::ALLOW_UNKNOWN = 1;
588
589 my $tmpl = {
590 input => { required => 1, store => \$input }
591 };
592
593 my $args = check( $tmpl, \%hash ) or return;
594 }
595
596 local $Data::Dumper::Indent = 1; # for dumpering from !
597 eval $input;
598 error( $@ ) if $@;
5bc5f6dc 599 $self->__print( "\n" );
6aaee015 600 return;
601}
602
603sub _search_module {
604 my $self = shift;
605 my $cb = $self->backend;
606 my %hash = @_;
607
608 my $args;
609 { local $Params::Check::ALLOW_UNKNOWN = 1;
610
611 my $tmpl = {
612 input => { required => 1, },
613 options => { default => { } },
614 };
615
616 $args = check( $tmpl, \%hash ) or return;
617 }
618
619 my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
620
621 ### XXX this is rather slow, because (probably)
622 ### of the many method calls
623 ### XXX need to profile to speed it up =/
624
625 ### find the modules ###
626 my @rv = sort { $a->module cmp $b->module }
627 $cb->search(
628 %{$args->{'options'}},
629 type => 'module',
630 allow => \@regexes,
631 );
632
633 ### store the result in the cache ###
634 $self->cache([undef,@rv]);
635
636 $self->__display_results;
637
638 return 1;
639}
640
641sub _search_author {
642 my $self = shift;
643 my $cb = $self->backend;
644 my %hash = @_;
645
646 my $args;
647 { local $Params::Check::ALLOW_UNKNOWN = 1;
648
649 my $tmpl = {
650 input => { required => 1, },
651 options => { default => { } },
652 };
653
654 $args = check( $tmpl, \%hash ) or return;
655 }
656
657 my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
658
659 my @rv;
660 for my $type (qw[author cpanid]) {
661 push @rv, $cb->search(
662 %{$args->{'options'}},
663 type => $type,
664 allow => \@regexes,
665 );
666 }
667
668 my %seen;
669 my @list = sort { $a->module cmp $b->module }
670 grep { defined }
671 map { $_->modules }
672 grep { not $seen{$_}++ } @rv;
673
674 $self->cache([undef,@list]);
675
676 $self->__display_results;
677 return 1;
678}
679
680sub _readme {
681 my $self = shift;
682 my $cb = $self->backend;
683 my %hash = @_;
684
685 my $args; my $mods; my $opts;
686 { local $Params::Check::ALLOW_UNKNOWN = 1;
687
688 my $tmpl = {
689 modules => { required => 1, store => \$mods },
690 options => { default => { }, store => \$opts },
691 };
692
693 $args = check( $tmpl, \%hash ) or return;
694 }
695
696 return unless scalar @$mods;
697
698 $self->_pager_open;
699 for my $mod ( @$mods ) {
5bc5f6dc 700 $self->__print( $mod->readme( %$opts ) );
6aaee015 701 }
702
703 $self->_pager_close;
704
705 return 1;
706}
707
708sub _fetch {
709 my $self = shift;
710 my $cb = $self->backend;
711 my %hash = @_;
712
713 my $args; my $mods; my $opts;
714 { local $Params::Check::ALLOW_UNKNOWN = 1;
715
716 my $tmpl = {
717 modules => { required => 1, store => \$mods },
718 options => { default => { }, store => \$opts },
719 };
720
721 $args = check( $tmpl, \%hash ) or return;
722 }
723
724 $self->_pager_open if @$mods >= $self->_term_rowcount;
725 for my $mod (@$mods) {
726 my $where = $mod->fetch( %$opts );
727
5bc5f6dc 728 $self->__print(
729 $where
6aaee015 730 ? loc("Successfully fetched '%1' to '%2'",
731 $mod->module, $where )
5bc5f6dc 732 : loc("Failed to fetch '%1'", $mod->module)
733 );
734 $self->__print( "\n" );
6aaee015 735 }
736 $self->_pager_close;
737
738}
739
740sub _shell {
741 my $self = shift;
742 my $cb = $self->backend;
743 my $conf = $cb->configure_object;
744 my %hash = @_;
745
746 my $shell = $conf->get_program('shell');
747 unless( $shell ) {
5bc5f6dc 748 $self->__print(
749 loc("Your config does not specify a subshell!"), "\n",
750 loc("Perhaps you need to re-run your setup?"), "\n"
751 );
6aaee015 752 return;
753 }
754
755 my $args; my $mods; my $opts;
756 { local $Params::Check::ALLOW_UNKNOWN = 1;
757
758 my $tmpl = {
759 modules => { required => 1, store => \$mods },
760 options => { default => { }, store => \$opts },
761 };
762
763 $args = check( $tmpl, \%hash ) or return;
764 }
765
766 my $cwd = Cwd::cwd();
767 for my $mod (@$mods) {
768 $mod->fetch( %$opts ) or next;
769 $mod->extract( %$opts ) or next;
770
771 $cb->_chdir( dir => $mod->status->extract() ) or next;
772
773 #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
774
775 if( system($shell) and $! ) {
5bc5f6dc 776 $self->__print(
777 loc("Error executing your subshell '%1': %2",
778 $shell, $!),"\n"
779 );
6aaee015 780 next;
781 }
782 }
783 $cb->_chdir( dir => $cwd );
784
785 return 1;
786}
787
788sub _distributions {
789 my $self = shift;
790 my $cb = $self->backend;
791 my $conf = $cb->configure_object;
792 my %hash = @_;
793
794 my $args; my $mods; my $opts;
795 { local $Params::Check::ALLOW_UNKNOWN = 1;
796
797 my $tmpl = {
798 modules => { required => 1, store => \$mods },
799 options => { default => { }, store => \$opts },
800 };
801
802 $args = check( $tmpl, \%hash ) or return;
803 }
804
805 my @list;
806 for my $mod (@$mods) {
807 push @list, sort { $a->version <=> $b->version }
808 grep { defined } $mod->distributions( %$opts );
809 }
810
811 my @rv = sort { $a->module cmp $b->module } @list;
812
813 $self->cache([undef,@rv]);
814 $self->__display_results;
815
816 return; 1;
817}
818
819sub _reload_indices {
820 my $self = shift;
821 my $cb = $self->backend;
822 my %hash = @_;
823
824 my $args; my $opts;
825 { local $Params::Check::ALLOW_UNKNOWN = 1;
826
827 my $tmpl = {
828 options => { default => { }, store => \$opts },
829 };
830
831 $args = check( $tmpl, \%hash ) or return;
832 }
833
834 my $rv = $cb->reload_indices( %$opts );
835
836 ### so the update failed, but you didnt give it any options either
837 if( !$rv and !(keys %$opts) ) {
5bc5f6dc 838 $self->__print(
839 "\nFailure may be due to corrupt source files\n" .
840 "Try this:\n\tx --update_source\n\n" );
6aaee015 841 }
842
843 return $rv;
844
845}
846
847sub _install {
848 my $self = shift;
849 my $cb = $self->backend;
850 my $conf = $cb->configure_object;
851 my %hash = @_;
852
853 my $args; my $mods; my $opts; my $choice;
854 { local $Params::Check::ALLOW_UNKNOWN = 1;
855
856 my $tmpl = {
857 modules => { required => 1, store => \$mods },
858 options => { default => { }, store => \$opts },
859 choice => { required => 1, store => \$choice,
860 allow => [qw|i t|] },
861 };
862
863 $args = check( $tmpl, \%hash ) or return;
864 }
865
866 unless( scalar @$mods ) {
5bc5f6dc 867 $self->__print( loc("Nothing done\n") );
6aaee015 868 return;
869 }
870
871 my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE;
872 my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing ');
873 my $action = $choice eq 'i' ? 'install' : 'test';
874
875 my $status = {};
876 ### first loop over the mods to install them ###
877 for my $mod (@$mods) {
5bc5f6dc 878 $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" );
6aaee015 879
880 my $log_length = length CPANPLUS::Error->stack_as_string;
881
882 ### store the status for look up when we're done with all
883 ### install calls
884 $status->{$mod} = $mod->install( %$opts, target => $target );
885
886 ### would you like a log file of what happened?
887 if( $conf->get_conf('write_install_logs') ) {
888
889 my $dir = File::Spec->catdir(
890 $conf->get_conf('base'),
891 $conf->_get_build('install_log_dir'),
892 );
893 ### create the dir if it doesn't exit yet
894 $cb->_mkdir( dir => $dir ) unless -d $dir;
895
896 my $file = File::Spec->catfile(
897 $dir,
898 INSTALL_LOG_FILE->( $mod )
899 );
900 if ( open my $fh, ">$file" ) {
901 my $stack = CPANPLUS::Error->stack_as_string;
902 ### remove everything in the log that was there *before*
903 ### we started this install
904 substr( $stack, 0, $log_length, '' );
905
906 print $fh $stack;
907 close $fh;
908
5bc5f6dc 909 $self->__print(
910 loc("*** Install log written to:\n %1\n\n", $file)
911 );
6aaee015 912 } else {
913 warn "Could not open '$file': $!\n";
914 next;
915 }
916 }
917 }
918
919 my $flag;
920 ### then report whether all this went ok or not ###
921 for my $mod (@$mods) {
922 # if( $mod->status->installed ) {
923 if( $status->{$mod} ) {
5bc5f6dc 924 $self->__print(
925 loc("Module '%1' %tense(%2,past) successfully\n",
926 $mod->module, $action)
927 );
6aaee015 928 } else {
929 $flag++;
5bc5f6dc 930 $self->__print(
931 loc("Error %tense(%1,present) '%2'\n", $action, $mod->module)
932 );
6aaee015 933 }
934 }
935
936
937
938 if( !$flag ) {
5bc5f6dc 939 $self->__print(
940 loc("No errors %tense(%1,present) all modules", $action), "\n"
941 );
6aaee015 942 } else {
5bc5f6dc 943 $self->__print(
944 loc("Problem %tense(%1,present) one or more modules", $action)
945 );
946 $self->__print( "\n" );
947
948 $self->__print(
949 loc("*** You can view the complete error buffer by pressing ".
950 "'%1' ***\n", 'p')
951 ) unless $conf->get_conf('verbose') || $self->noninteractive;
6aaee015 952 }
5bc5f6dc 953 $self->__print( "\n" );
6aaee015 954
955 return !$flag;
956}
957
958sub __ask_about_install {
959 my $mod = shift or return;
960 my $prereq = shift or return;
961 my $term = $Shell->term;
962
5bc5f6dc 963 $Shell->__print( "\n" );
964 $Shell->__print( loc("Module '%1' requires '%2' to be installed",
965 $mod->module, $prereq->module ) );
966 $Shell->__print( "\n\n" );
4443dd53 967
968 ### previously cached answer?
969 return $Shell->settings->{'install_all_prereqs'}
970 if defined $Shell->settings->{'install_all_prereqs'};
971
972
5bc5f6dc 973 $Shell->__print(
974 loc( "If you don't wish to see this question anymore\n".
6aaee015 975 "you can disable it by entering the following ".
976 "commands on the prompt:\n '%1'",
5bc5f6dc 977 's conf prereqs 1; s save' ) );
978 $Shell->__print("\n\n");
6aaee015 979
4443dd53 980 my $yes = loc("Yes");
981 my $no = loc("No");
982 my $all = loc("Yes to all (for this module)");
983 my $none = loc("No to all (for this module)");
984
985 my $reply = $term->get_reply(
6aaee015 986 prompt => loc("Should I install this module?"),
4443dd53 987 choices => [ $yes, $no, $all, $none ],
988 default => $yes,
6aaee015 989 );
990
4443dd53 991 ### if 'all' or 'none', save this, so we can apply it to
992 ### other prereqs in this chain.
993 $Shell->settings->{'install_all_prereqs'} =
994 $reply eq $all ? 1 :
995 $reply eq $none ? 0 :
996 undef;
997
998 ### if 'yes' or 'all', the user wants it installed
999 return $reply eq $all ? 1 :
1000 $reply eq $yes ? 1 :
1001 0;
6aaee015 1002}
1003
1004sub __ask_about_send_test_report {
1005 my($mod, $grade) = @_;
1006 return 1 unless $grade eq GRADE_FAIL;
1007
1008 my $term = $Shell->term;
1009
5bc5f6dc 1010 $Shell->__print( "\n" );
1011 $Shell->__print(
1012 loc("Test report prepared for module '%1'.\n Would you like to ".
1013 "send it? (You can edit it if you like)", $mod->module ) );
1014 $Shell->__print( "\n\n" );
6aaee015 1015 my $bool = $term->ask_yn(
1016 prompt => loc("Would you like to send the test report?"),
1017 default => 'n'
1018 );
1019
1020 return $bool;
1021}
1022
1023sub __ask_about_edit_test_report {
1024 my($mod, $grade) = @_;
1025 return 0 unless $grade eq GRADE_FAIL;
1026
1027 my $term = $Shell->term;
1028
5bc5f6dc 1029 $Shell->__print( "\n" );
1030 $Shell->__print(
1031 loc("Test report prepared for module '%1'. You can edit this ".
1032 "report if you would like", $mod->module ) );
1033 $Shell->__print("\n\n");
6aaee015 1034 my $bool = $term->ask_yn(
1035 prompt => loc("Would you like to edit the test report?"),
1036 default => 'y'
1037 );
1038
1039 return $bool;
1040}
1041
622d31ac 1042sub __ask_about_test_failure {
1043 my $mod = shift;
1044 my $captured = shift || '';
1045 my $term = $Shell->term;
1046
5bc5f6dc 1047 $Shell->__print( "\n" );
1048 $Shell->__print(
1049 loc( "The tests for '%1' failed. Would you like me to proceed ".
1050 "anyway or should we abort?", $mod->module ) );
1051 $Shell->__print( "\n\n" );
622d31ac 1052
1053 my $bool = $term->ask_yn(
1054 prompt => loc("Proceed anyway?"),
1055 default => 'n',
1056 );
1057
1058 return $bool;
1059}
6aaee015 1060
1061
1062sub _details {
1063 my $self = shift;
1064 my $cb = $self->backend;
1065 my $conf = $cb->configure_object;
1066 my %hash = @_;
1067
1068 my $args; my $mods; my $opts;
1069 { local $Params::Check::ALLOW_UNKNOWN = 1;
1070
1071 my $tmpl = {
1072 modules => { required => 1, store => \$mods },
1073 options => { default => { }, store => \$opts },
1074 };
1075
1076 $args = check( $tmpl, \%hash ) or return;
1077 }
1078
1079 ### every module has about 10 lines of details
1080 ### maybe more later with Module::CPANTS etc
1081 $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount;
1082
1083
4443dd53 1084 my $format = "%-24s %-45s\n";
1085 my $cformat = "%-24s %-45s %-10s\n";
6aaee015 1086 for my $mod (@$mods) {
1087 my $href = $mod->details( %$opts );
1088 my @list = sort { $a->module cmp $b->module } $mod->contains;
1089
1090 unless( $href ) {
5bc5f6dc 1091 $self->__print(
1092 loc("No details for %1 - it might be outdated.",
1093 $mod->module), "\n" );
6aaee015 1094 next;
1095
1096 } else {
5bc5f6dc 1097 $self->__print( loc( "Details for '%1'\n", $mod->module ) );
6aaee015 1098 for my $item ( sort keys %$href ) {
5bc5f6dc 1099 $self->__printf( $format, $item, $href->{$item} );
6aaee015 1100 }
1101
1102 my $showed;
1103 for my $item ( @list ) {
5bc5f6dc 1104 $self->__printf(
4443dd53 1105 $cformat, ($showed ? '' : 'Contains:'),
1106 $item->module, $item->version
5bc5f6dc 1107 );
6aaee015 1108 $showed++;
1109 }
5bc5f6dc 1110 $self->__print( "\n" );
6aaee015 1111 }
1112 }
1113 $self->_pager_close;
5bc5f6dc 1114 $self->__print( "\n" );
6aaee015 1115
1116 return 1;
1117}
1118
1119sub _print {
1120 my $self = shift;
1121 my %hash = @_;
1122
1123 my $args; my $opts; my $file;
1124 { local $Params::Check::ALLOW_UNKNOWN = 1;
1125
1126 my $tmpl = {
1127 options => { default => { }, store => \$opts },
1128 input => { default => '', store => \$file },
1129 };
1130
1131 $args = check( $tmpl, \%hash ) or return;
1132 }
1133
1134 my $old; my $fh;
1135 if( $file ) {
1136 $fh = FileHandle->new( ">$file" )
1137 or( warn loc("Could not open '%1': '%2'", $file, $!),
1138 return
1139 );
1140 $old = select $fh;
1141 }
1142
1143
1144 $self->_pager_open if !$file;
1145
5bc5f6dc 1146 $self->__print( CPANPLUS::Error->stack_as_string );
6aaee015 1147
1148 $self->_pager_close;
1149
1150 select $old if $old;
5bc5f6dc 1151 $self->__print( "\n" );
6aaee015 1152
1153 return 1;
1154}
1155
1156sub _set_conf {
1157 my $self = shift;
1158 my %hash = @_;
1159 my $cb = $self->backend;
1160 my $conf = $cb->configure_object;
1161
1162 ### possible options
1163 ### XXX hard coded, not optimal :(
622d31ac 1164 my %types = (
1165 reconfigure => '',
1166 save => q([user | system | boxed]),
1167 edit => '',
1168 program => q([key => val]),
1169 conf => q([key => val]),
1170 mirrors => '',
1171 selfupdate => '', # XXX add all opts here?
1172 );
6aaee015 1173
1174
1175 my $args; my $opts; my $input;
1176 { local $Params::Check::ALLOW_UNKNOWN = 1;
1177
1178 my $tmpl = {
1179 options => { default => { }, store => \$opts },
1180 input => { default => '', store => \$input },
1181 };
1182
1183 $args = check( $tmpl, \%hash ) or return;
1184 }
1185
1186 my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)\s*$/;
1187 $type = lc $type;
1188
1189 if( $type eq 'reconfigure' ) {
1190 my $setup = CPANPLUS::Configure::Setup->new(
1191 configure_object => $conf,
1192 term => $self->term,
1193 backend => $cb,
1194 );
1195 return $setup->init;
1196
1197 } elsif ( $type eq 'save' ) {
1198 my $where = {
1199 user => CONFIG_USER,
1200 system => CONFIG_SYSTEM,
622d31ac 1201 boxed => CONFIG_BOXED,
6aaee015 1202 }->{ $key } || CONFIG_USER;
1203
4443dd53 1204 ### boxed is special, so let's get its value from %INC
622d31ac 1205 ### so we can tell it where to save
1206 ### XXX perhaps this logic should be generic for all
1207 ### types, and put in the ->save() routine
1208 my $dir;
1209 if( $where eq CONFIG_BOXED ) {
1210 my $file = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm';
1211 my $file_re = quotemeta($file);
1212
1213 my $path = $INC{$file} || '';
1214 $path =~ s/$file_re$//;
1215 $dir = $path;
1216 }
1217
1218 my $rv = $cb->configure_object->save( $where => $dir );
6aaee015 1219
5bc5f6dc 1220 $self->__print(
1221 $rv
622d31ac 1222 ? loc("Configuration successfully saved to %1\n (%2)\n",
1223 $where, $rv)
5bc5f6dc 1224 : loc("Failed to save configuration\n" )
1225 );
6aaee015 1226 return $rv;
1227
1228 } elsif ( $type eq 'edit' ) {
1229
1230 my $editor = $conf->get_program('editor')
1231 or( print(loc("No editor specified")), return );
1232
1233 my $where = {
1234 user => CONFIG_USER,
1235 system => CONFIG_SYSTEM,
1236 }->{ $key } || CONFIG_USER;
4443dd53 1237
6aaee015 1238 my $file = $conf->_config_pm_to_file( $where );
1239 system("$editor $file");
1240
1241 ### now reload it
1242 ### disable warnings for this
1243 { require Module::Loaded;
4443dd53 1244 Module::Loaded::mark_as_unloaded( $where );
6aaee015 1245
1246 ### reinitialize the config
1247 local $^W;
1248 $conf->init;
1249 }
1250
1251 return 1;
1252
1253 } elsif ( $type eq 'mirrors' ) {
1254
5bc5f6dc 1255 $self->__print(
1256 loc("Readonly list of mirrors (in order of preference):\n\n" ) );
6aaee015 1257
1258 my $i;
1259 for my $host ( @{$conf->get_conf('hosts')} ) {
1260 my $uri = $cb->_host_to_uri( %$host );
1261
1262 $i++;
5bc5f6dc 1263 $self->__print( "\t[$i] $uri\n" );
6aaee015 1264 }
4443dd53 1265
1266 $self->__print(
1267 loc("\nTo edit this list, please type: '%1'\n", 's edit') );
6aaee015 1268
1269 } elsif ( $type eq 'selfupdate' ) {
1270 my %valid = map { $_ => $_ }
622d31ac 1271 $cb->selfupdate_object->list_categories;
6aaee015 1272
1273 unless( $valid{$key} ) {
5bc5f6dc 1274 $self->__print(
1275 loc( "To update your current CPANPLUS installation, ".
6aaee015 1276 "choose one of the these options:\n%1",
e3b7d412 1277 ( join $/, map {
622d31ac 1278 sprintf "\ts selfupdate %-17s " .
1279 "[--latest=0] [--dryrun]", $_
e3b7d412 1280 } sort keys %valid )
5bc5f6dc 1281 )
1282 );
6aaee015 1283 } else {
622d31ac 1284 my %update_args = (
1285 update => $key,
1286 latest => 1,
1287 %$opts
1288 );
1289
1290
1291 my %list = $cb->selfupdate_object
1292 ->list_modules_to_update( %update_args );
1293
5bc5f6dc 1294 $self->__print(loc("The following updates will take place:"),$/.$/);
622d31ac 1295
1296 for my $feature ( sort keys %list ) {
1297 my $aref = $list{$feature};
1298
1299 ### is it a 'feature' or a built in?
5bc5f6dc 1300 $self->__print(
1301 $valid{$feature}
1302 ? " " . ucfirst($feature) . ":\n"
1303 : " Modules for '$feature' support:\n"
1304 );
622d31ac 1305
1306 ### show what modules would be installed
5bc5f6dc 1307 $self->__print(
1308 scalar @$aref
1309 ? map { sprintf " %-42s %-6s -> %-6s \n",
1310 $_->name, $_->installed_version, $_->version
1311 } @$aref
1312 : " No upgrades required\n"
1313 );
1314 $self->__print( $/ );
622d31ac 1315 }
1316
1317
1318 unless( $opts->{'dryrun'} ) {
5bc5f6dc 1319 $self->__print( loc("Updating your CPANPLUS installation\n") );
622d31ac 1320 $cb->selfupdate_object->selfupdate( %update_args );
1321 }
6aaee015 1322 }
1323
1324 } else {
1325
1326 if ( $type eq 'program' or $type eq 'conf' ) {
1327
1328 my $format = {
1329 conf => '%-25s %s',
1330 program => '%-12s %s',
1331 }->{ $type };
1332
1333 unless( $key ) {
1334 my @list = grep { $_ ne 'hosts' }
1335 $conf->options( type => $type );
1336
1337 my $method = 'get_' . $type;
1338
1339 local $Data::Dumper::Indent = 0;
1340 for my $name ( @list ) {
1341 my $val = $conf->$method($name) || '';
1342 ($val) = ref($val)
1343 ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
1344 : "'$val'";
5bc5f6dc 1345
1346 $self->__printf( " $format\n", $name, $val );
6aaee015 1347 }
1348
4443dd53 1349 } elsif ( $key eq 'hosts' or $key eq 'lib' ) {
5bc5f6dc 1350 $self->__print(
4443dd53 1351 loc( "Setting %1 is not trivial.\n" .
1352 "It is suggested you use '%2' and edit the " .
1353 "configuration file manually", $key, 's edit')
5bc5f6dc 1354 );
6aaee015 1355 } else {
1356 my $method = 'set_' . $type;
1357 $conf->$method( $key => defined $value ? $value : '' )
5bc5f6dc 1358 and $self->__print( loc("Key '%1' was set to '%2'", $key,
1359 defined $value ? $value : 'EMPTY STRING') );
6aaee015 1360 }
1361
1362 } else {
5bc5f6dc 1363 $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) );
1364 $self->__print( $/ );
1365 $self->__print( loc("Try one of the following:") );
1366 $self->__print( $/, join $/,
622d31ac 1367 map { sprintf "\t%-11s %s", $_, $types{$_} }
5bc5f6dc 1368 sort keys %types );
6aaee015 1369 }
1370 }
5bc5f6dc 1371 $self->__print( "\n" );
6aaee015 1372 return 1;
1373}
1374
1375sub _uptodate {
1376 my $self = shift;
1377 my %hash = @_;
1378 my $cb = $self->backend;
1379 my $conf = $cb->configure_object;
1380
1381 my $opts; my $mods;
1382 { local $Params::Check::ALLOW_UNKNOWN = 1;
1383
1384 my $tmpl = {
1385 options => { default => { }, store => \$opts },
1386 modules => { required => 1, store => \$mods },
1387 };
1388
1389 check( $tmpl, \%hash ) or return;
1390 }
1391
1392 ### long listing? short is default ###
1393 my $long = $opts->{'long'} ? 1 : 0;
1394
1395 my @list = scalar @$mods ? @$mods : @{$cb->_all_installed};
1396
1397 my @rv; my %seen;
1398 for my $mod (@list) {
1399 ### skip this mod if it's up to date ###
1400 next if $mod->is_uptodate;
1401 ### skip this mod if it's core ###
1402 next if $mod->package_is_perl_core;
1403
1404 if( $long or !$seen{$mod->package}++ ) {
1405 push @rv, $mod;
1406 }
1407 }
1408
1409 @rv = sort { $a->module cmp $b->module } @rv;
1410
1411 $self->cache([undef,@rv]);
1412
1413 $self->_pager_open if scalar @rv >= $self->_term_rowcount;
1414
1415 my $format = "%5s %12s %12s %-36s %-10s\n";
1416
1417 my $i = 1;
1418 for my $mod ( @rv ) {
5bc5f6dc 1419 $self->__printf(
1420 $format,
1421 $i,
1422 $self->_format_version($mod->installed_version) || 'Unparsable',
1423 $self->_format_version( $mod->version ),
1424 $mod->module,
1425 $mod->author->cpanid
1426 );
6aaee015 1427 $i++;
1428 }
1429 $self->_pager_close;
1430
1431 return 1;
1432}
1433
1434sub _autobundle {
1435 my $self = shift;
1436 my %hash = @_;
1437 my $cb = $self->backend;
1438 my $conf = $cb->configure_object;
1439
1440 my $opts; my $input;
1441 { local $Params::Check::ALLOW_UNKNOWN = 1;
1442
1443 my $tmpl = {
1444 options => { default => { }, store => \$opts },
1445 input => { default => '', store => \$input },
1446 };
1447
1448 check( $tmpl, \%hash ) or return;
1449 }
1450
1451 $opts->{'path'} = $input if $input;
1452
1453 my $where = $cb->autobundle( %$opts );
1454
5bc5f6dc 1455 $self->__print(
1456 $where
6aaee015 1457 ? loc("Wrote autobundle to '%1'", $where)
5bc5f6dc 1458 : loc("Could not create autobundle" )
1459 );
1460 $self->__print( "\n" );
6aaee015 1461
1462 return $where ? 1 : 0;
1463}
1464
1465sub _uninstall {
1466 my $self = shift;
1467 my %hash = @_;
1468 my $cb = $self->backend;
1469 my $term = $self->term;
1470 my $conf = $cb->configure_object;
1471
1472 my $opts; my $mods;
1473 { local $Params::Check::ALLOW_UNKNOWN = 1;
1474
1475 my $tmpl = {
1476 options => { default => { }, store => \$opts },
1477 modules => { default => [], store => \$mods },
1478 };
1479
1480 check( $tmpl, \%hash ) or return;
1481 }
1482
1483 my $force = $opts->{'force'} || $conf->get_conf('force');
1484
1485 unless( $force ) {
1486 my $list = join "\n", map { ' ' . $_->module } @$mods;
1487
5bc5f6dc 1488 $self->__print( loc("
6aaee015 1489This will uninstall the following modules:
1490%1
1491
1492Note that if you installed them via a package manager, you probably
1493should use the same package manager to uninstall them
1494
5bc5f6dc 1495", $list) );
6aaee015 1496
1497 return unless $term->ask_yn(
1498 prompt => loc("Are you sure you want to continue?"),
1499 default => 'n',
1500 );
1501 }
1502
1503 ### first loop over all the modules to uninstall them ###
1504 for my $mod (@$mods) {
5bc5f6dc 1505 $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" );
6aaee015 1506
1507 $mod->uninstall( %$opts );
1508 }
1509
1510 my $flag;
1511 ### then report whether all this went ok or not ###
1512 for my $mod (@$mods) {
1513 if( $mod->status->uninstall ) {
5bc5f6dc 1514 $self->__print(
1515 loc("Module '%1' %tense(uninstall,past) successfully\n",
1516 $mod->module ) );
6aaee015 1517 } else {
1518 $flag++;
5bc5f6dc 1519 $self->__print(
1520 loc("Error %tense(uninstall,present) '%1'\n", $mod->module) );
6aaee015 1521 }
1522 }
1523
1524 if( !$flag ) {
5bc5f6dc 1525 $self->__print(
1526 loc("All modules %tense(uninstall,past) successfully"), "\n" );
6aaee015 1527 } else {
5bc5f6dc 1528 $self->__print(
1529 loc("Problem %tense(uninstalling,present) one or more modules" ),
1530 "\n" );
1531
1532 $self->__print(
1533 loc("*** You can view the complete error buffer by pressing '%1'".
1534 "***\n", 'p') ) unless $conf->get_conf('verbose');
6aaee015 1535 }
5bc5f6dc 1536 $self->__print( "\n" );
6aaee015 1537
1538 return !$flag;
1539}
1540
1541sub _reports {
1542 my $self = shift;
1543 my %hash = @_;
1544 my $cb = $self->backend;
1545 my $term = $self->term;
1546 my $conf = $cb->configure_object;
1547
1548 my $opts; my $mods;
1549 { local $Params::Check::ALLOW_UNKNOWN = 1;
1550
1551 my $tmpl = {
1552 options => { default => { }, store => \$opts },
1553 modules => { default => '', store => \$mods },
1554 };
1555
1556 check( $tmpl, \%hash ) or return;
1557 }
1558
1559 ### XXX might need to be conditional ###
1560 $self->_pager_open;
1561
1562 for my $mod (@$mods) {
1563 my @list = $mod->fetch_report( %$opts )
1564 or( print(loc("No reports available for this distribution.")),
1565 next
1566 );
1567
1568 @list = reverse
1569 map { $_->[0] }
1570 sort { $a->[1] cmp $b->[1] }
1571 map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list;
1572
1573
1574
1575 ### XXX this may need to be sorted better somehow ###
1576 my $url;
1577 my $format = "%8s %s %s\n";
1578
1579 my %seen;
1580 for my $href (@list ) {
5bc5f6dc 1581 $self->__print(
1582 "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n"
1583 ) unless $seen{ $href->{'dist'} }++;
1584
1585 $self->__printf(
1586 $format,
1587 $href->{'grade'},
1588 $href->{'platform'},
1589 ($href->{'details'} ? '(*)' : '')
1590 );
6aaee015 1591
1592 $url ||= $href->{'details'};
1593 }
1594
5bc5f6dc 1595 $self->__print( "\n==> $url\n" ) if $url;
1596 $self->__print( "\n" );
6aaee015 1597 }
1598 $self->_pager_close;
1599
1600 return 1;
1601}
1602
1603
1604### Load plugins
1605{ my @PluginModules;
1606 my %Dispatch = (
1607 showtip => [ __PACKAGE__, '_show_random_tip'],
1608 plugins => [ __PACKAGE__, '_list_plugins' ],
1609 '?' => [ __PACKAGE__, '_plugins_usage' ],
1610 );
1611
1612 sub plugin_modules { return @PluginModules }
1613 sub plugin_table { return %Dispatch }
1614
5bc5f6dc 1615 my $init_done;
1616 sub _plugins_init {
1617 ### only initialize once
1618 return if $init_done++;
1619
1620 ### find all plugins first
1621 if( check_install( module => 'Module::Pluggable', version => '2.4') ) {
1622 require Module::Pluggable;
6aaee015 1623
5bc5f6dc 1624 my $only_re = __PACKAGE__ . '::Plugins::\w+$';
6aaee015 1625
5bc5f6dc 1626 Module::Pluggable->import(
1627 sub_name => '_plugins',
1628 search_path => __PACKAGE__,
1629 only => qr/$only_re/,
1630 #except => [ INSTALLER_MM, INSTALLER_SAMPLE ]
1631 );
1632
1633 push @PluginModules, __PACKAGE__->_plugins;
1634 }
1635
1636 ### now try to load them
1637 for my $p ( __PACKAGE__->plugin_modules ) {
1638 my %map = eval { load $p; $p->import; $p->plugins };
1639 error(loc("Could not load plugin '$p': $@")), next if $@;
1640
1641 ### register each plugin
1642 while( my($name, $func) = each %map ) {
1643
1644 if( not length $name or not length $func ) {
1645 error(loc("Empty plugin name or dispatch function detected"));
1646 next;
1647 }
1648
1649 if( exists( $Dispatch{$name} ) ) {
1650 error(loc("'%1' is already registered by '%2'",
1651 $name, $Dispatch{$name}->[0]));
1652 next;
1653 }
1654
1655 ### register name, package and function
1656 $Dispatch{$name} = [ $p, $func ];
1657 }
6aaee015 1658 }
1659 }
5bc5f6dc 1660
4443dd53 1661 ### dispatch a plugin command to its function
6aaee015 1662 sub _meta {
1663 my $self = shift;
1664 my %hash = @_;
1665 my $cb = $self->backend;
1666 my $term = $self->term;
1667 my $conf = $cb->configure_object;
1668
1669 my $opts; my $input;
1670 { local $Params::Check::ALLOW_UNKNOWN = 1;
1671
1672 my $tmpl = {
1673 options => { default => { }, store => \$opts },
1674 input => { default => '', store => \$input },
1675 };
1676
1677 check( $tmpl, \%hash ) or return;
1678 }
1679
1680 $input =~ s/\s*(\S+)\s*//;
1681 my $cmd = $1;
1682
1683 ### look up the command, or go to the default
1684 my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ];
1685
1686 my($pkg,$func) = @$aref;
1687
1688 my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) };
1689
1690 error( $@ ) if $@;
1691
1692 ### return $rv instead, so input loop can be terminated?
1693 return 1;
1694 }
1695
1696 sub _plugin_default { error(loc("No such plugin command")) }
1697}
1698
1699### plugin commands
5bc5f6dc 1700{ my $help_format = " /%-21s # %s\n";
6aaee015 1701
1702 sub _list_plugins {
5bc5f6dc 1703 my $self = shift;
1704
1705 $self->__print( loc("Available plugins:\n") );
1706 $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) );
1707 $self->__print( $/ );
6aaee015 1708
1709 my %table = __PACKAGE__->plugin_table;
1710 for my $name( sort keys %table ) {
1711 my $pkg = $table{$name}->[0];
1712 my $this = __PACKAGE__;
1713
1714 my $who = $pkg eq $this
1715 ? "Standard Plugin"
4443dd53 1716 : do { my $v = $self->_format_version($pkg->VERSION) || '';
1717 $pkg =~ s/^$this/../;
1718 sprintf "Provided by: %-30s %-10s", $pkg, $v;
1719 };
6aaee015 1720
5bc5f6dc 1721 $self->__printf( $help_format, $name, $who );
6aaee015 1722 }
1723
5bc5f6dc 1724 $self->__print( $/.$/ );
6aaee015 1725
5bc5f6dc 1726 $self->__print(
1727 " Write your own plugins? Read the documentation of:\n" .
1728 " CPANPLUS::Shell::Default::Plugins::HOWTO\n" );
6aaee015 1729
5bc5f6dc 1730 $self->__print( $/ );
6aaee015 1731 }
1732
1733 sub _list_plugins_help {
1734 return sprintf $help_format, 'plugins', loc("lists available plugins");
1735 }
1736
1737 ### registered as a plugin too
1738 sub _show_random_tip_help {
1739 return sprintf $help_format, 'showtip', loc("show usage tips" );
1740 }
1741
1742 sub _plugins_usage {
5bc5f6dc 1743 my $self = shift;
6aaee015 1744 my $shell = shift;
1745 my $cb = shift;
1746 my $cmd = shift;
1747 my $input = shift;
5bc5f6dc 1748 my %table = $self->plugin_table;
6aaee015 1749
1750 my @list = length $input ? split /\s+/, $input : sort keys %table;
1751
1752 for my $name( @list ) {
1753
1754 ### no such plugin? skip
1755 error(loc("No such plugin '$name'")), next unless $table{$name};
1756
1757 my $pkg = $table{$name}->[0];
1758 my $func = $table{$name}->[1] . '_help';
1759
1760 if ( my $sub = $pkg->can( $func ) ) {
5bc5f6dc 1761 eval { $self->__print( $sub->() ) };
6aaee015 1762 error( $@ ) if $@;
1763
1764 } else {
5bc5f6dc 1765 $self->__print(" No usage for '$name' -- try perldoc $pkg");
6aaee015 1766 }
1767
5bc5f6dc 1768 $self->__print( $/ );
6aaee015 1769 }
1770
5bc5f6dc 1771 $self->__print( $/.$/ );
6aaee015 1772 }
1773
1774 sub _plugins_usage_help {
1775 return sprintf $help_format, '? [NAME ...]',
1776 loc("show usage for plugins");
1777 }
1778}
1779
1780### send a command to a remote host, retrieve the answer;
1781sub __send_remote_command {
1782 my $self = shift;
1783 my $cmd = shift;
1784 my $remote = $self->remote or return;
1785 my $user = $remote->{'username'};
1786 my $pass = $remote->{'password'};
1787 my $conn = $remote->{'connection'};
1788 my $end = "\015\012";
1789 my $answer;
1790
1791 my $send = join "\0", $user, $pass, $cmd;
1792
1793 print $conn $send . $end;
1794
1795 ### XXX why doesn't something like this just work?
1796 #1 while recv($conn, $answer, 1024, 0);
1797 while(1) {
1798 my $buff;
1799 $conn->recv( $buff, 1024, 0 );
1800 $answer .= $buff;
1801 last if $buff =~ /$end$/;
1802 }
1803
1804 my($status,$buffer) = split "\0", $answer;
1805
1806 return ($status, $buffer);
1807}
1808
1809
1810sub _read_configuration_from_rc {
5bc5f6dc 1811 my $self = shift;
6aaee015 1812 my $rc_file = shift;
1813
1814 my $href;
1815 if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) {
1816 $Config::Auto::DisablePerl = 1;
1817
1818 eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) };
1819
5bc5f6dc 1820 $self->__print(
1821 loc( "Unable to read in config file '%1': %2", $rc_file, $@ )
1822 ) if $@;
6aaee015 1823 }
1824
1825 return $href || {};
1826}
1827
1828{ my @tips = (
1829 loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ),
1830 loc( "You can install modules by URL using '%1'", 'i URL' ),
1831 loc( "You can turn off these tips using '%1'",
1832 's conf show_startup_tip 0' ),
1833 loc( "You can use wildcards like '%1' and '%2' on search results",
622d31ac 1834 '*', '2..5' ) ,
6aaee015 1835 loc( "You can use plugins. Type '%1' to list available plugins",
1836 '/plugins' ),
1837 loc( "You can show all your out of date modules using '%1'", 'o' ),
502c7995 1838 loc( "Many operations take options, like '%1', '%2' or '%3'",
1839 '--verbose', '--force', '--skiptest' ),
6aaee015 1840 loc( "The documentation in %1 and %2 is very useful",
1841 "CPANPLUS::Module", "CPANPLUS::Backend" ),
1842 loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ),
5bc5f6dc 1843 loc( "You can run an interactive setup using '%1'", 's reconfigure' ),
1844 loc( "You can add custom sources to your index. See '%1' for details",
1845 '/cs --help' ),
4443dd53 1846 loc( "CPANPLUS now has an experimental SQLite backend. You can enable ".
1847 "it via: '%1'. Update dependencies via '%2'",
1848 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save',
1849 's selfupdate enabled_features ' ),
6aaee015 1850 );
1851
1852 sub _show_random_tip {
1853 my $self = shift;
5bc5f6dc 1854 $self->__print( $/, "Did you know...\n ",
1855 $tips[ int rand scalar @tips ], $/ );
6aaee015 1856 return 1;
1857 }
1858}
1859
18601;
1861
1862__END__
1863
1864=pod
1865
1866=head1 BUG REPORTS
1867
1868Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1869
1870=head1 AUTHOR
1871
1872This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1873
1874=head1 COPYRIGHT
1875
1876The CPAN++ interface (of which this module is a part of) is copyright (c)
18772001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1878
1879This library is free software; you may redistribute and/or modify it
1880under the same terms as Perl itself.
1881
1882=head1 SEE ALSO
1883
1884L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp>
1885
1886=cut
1887
1888# Local variables:
1889# c-indentation-style: bsd
1890# c-basic-offset: 4
1891# indent-tabs-mode: nil
1892# End:
1893# vim: expandtab shiftwidth=4:
1894
1895__END__
1896
1897TODO:
1898 e => "_expand_inc", # scratch it, imho -- not used enough
1899
1900### free letters: g j k n y ###
Unnamed repository; edit this file to name it for gitweb.