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