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