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