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