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