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