cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm

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