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