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