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