summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm1978
1 files changed, 0 insertions, 1978 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm
deleted file mode 100644
index 4c9991d529b..00000000000
--- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm
+++ /dev/null
@@ -1,1978 +0,0 @@
-package CPANPLUS::Shell::Default;
-use deprecate;
-
-use strict;
-
-
-use CPANPLUS::Error;
-use CPANPLUS::Backend;
-use CPANPLUS::Configure::Setup;
-use CPANPLUS::Internals::Constants;
-use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL];
-
-use Cwd;
-use IPC::Cmd;
-use Term::UI;
-use Data::Dumper;
-use Term::ReadLine;
-
-use Module::Load qw[load];
-use Params::Check qw[check];
-use Module::Load::Conditional qw[can_load check_install];
-use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
-
-local $Params::Check::VERBOSE = 1;
-local $Data::Dumper::Indent = 1; # for dumpering from !
-
-BEGIN {
- use vars qw[ $VERSION @ISA ];
- @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ];
- $VERSION = "0.9135";
-}
-
-load CPANPLUS::Shell;
-
-
-my $map = {
- 'm' => '_search_module',
- 'a' => '_search_author',
- '!' => '_bang',
- '?' => '_help',
- 'h' => '_help',
- 'q' => '_quit',
- 'r' => '_readme',
- 'v' => '_show_banner',
- 'w' => '__display_results',
- 'd' => '_fetch',
- 'z' => '_shell',
- 'f' => '_distributions',
- 'x' => '_reload_indices',
- 'i' => '_install',
- 't' => '_install',
- 'l' => '_details',
- 'p' => '_print',
- 's' => '_set_conf',
- 'o' => '_uptodate',
- 'b' => '_autobundle',
- 'u' => '_uninstall',
- '/' => '_meta', # undocumented for now
- 'c' => '_reports',
- 'e' => '_reload_shell',
-};
-### free letters: e g j k n y ###
-
-
-### will be filled if you have a .default-shell.rc and
-### Config::Auto installed
-my $rc = {};
-
-### the shell object, scoped to the file ###
-my $Shell;
-my $Brand = loc('CPAN Terminal');
-my $Prompt = $Brand . '> ';
-
-=pod
-
-=head1 NAME
-
-CPANPLUS::Shell::Default - the default CPANPLUS shell
-
-=head1 SYNOPSIS
-
- ### loading the shell:
- $ cpanp # run 'cpanp' from the command line
- $ perl -MCPANPLUS -eshell # load the shell from the command line
-
-
- use CPANPLUS::Shell qw[Default]; # load this shell via the API
- # always done via CPANPLUS::Shell
-
- my $ui = CPANPLUS::Shell->new;
- $ui->shell; # run the shell
- $ui->dispatch_on_input( input => 'x'); # update the source using the
- # dispatch method
-
- ### when in the shell:
- ### Note that all commands can also take options.
- ### Look at their underlying CPANPLUS::Backend methods to see
- ### what options those are.
- cpanp> h # show help messages
- cpanp> ? # show help messages
-
- cpanp> m Acme # find acme modules, allows regexes
- cpanp> a KANE # find modules by kane, allows regexes
- cpanp> f Acme::Foo # get a list of all releases of Acme::Foo
-
- cpanp> i Acme::Foo # install Acme::Foo
- cpanp> i Acme-Foo-1.3 # install version 1.3 of Acme::Foo
- cpanp> i <URI> # install from URI, like ftp://foo.com/X.tgz
- cpanp> i <DIR> # install from an absolute or relative directory
- cpanp> i 1 3..5 # install search results 1, 3, 4 and 5
- cpanp> i * # install all search results
- cpanp> a KANE; i *; # find modules by kane, install all results
- cpanp> t Acme::Foo # test Acme::Foo, without installing it
- cpanp> u Acme::Foo # uninstall Acme::Foo
- cpanp> d Acme::Foo # download Acme::Foo
- cpanp> z Acme::Foo # download & extract Acme::Foo, then open a
- # shell in the extraction directory
-
- cpanp> c Acme::Foo # get a list of test results for Acme::Foo
- cpanp> l Acme::Foo # view details about the Acme::Foo package
- cpanp> r Acme::Foo # view Acme::Foo's README file
- cpanp> o # get a list of all installed modules that
- # are out of date
- cpanp> o 1..3 # list uptodateness from a previous search
-
- cpanp> s conf # show config settings
- cpanp> s conf md5 1 # enable md5 checks
- cpanp> s program # show program settings
- cpanp> s edit # edit config file
- cpanp> s reconfigure # go through initial configuration again
- cpanp> s selfupdate # update your CPANPLUS install
- cpanp> s save # save config to disk
- cpanp> s mirrors # show currently selected mirrors
-
- cpanp> ! [PERL CODE] # execute the following perl code
-
- cpanp> b # create an autobundle for this computers
- # perl installation
- cpanp> x # reload index files (purges cache)
- cpanp> x --update_source # reload index files, get fresh source files
- cpanp> p [FILE] # print error stack (to a file)
- cpanp> v # show the banner
- cpanp> w # show last search results again
-
- cpanp> q # quit the shell
- cpanp> e # exit the shell and reload
-
- cpanp> /plugins # list available plugins
- cpanp> /? PLUGIN # list help test of <PLUGIN>
-
- ### common options:
- cpanp> i ... --skiptest # skip tests
- cpanp> i ... --force # force all operations
- cpanp> i ... --verbose # run in verbose mode
-
-=head1 DESCRIPTION
-
-This module provides the default user interface to C<CPANPLUS>. You
-can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>.
-
-=cut
-
-sub new {
- my $class = shift;
-
- my $cb = CPANPLUS::Backend->new( @_ );
- my $self = $class->SUPER::_init(
- brand => $Brand,
- term => Term::ReadLine->new( $Brand ),
- prompt => $Prompt,
- backend => $cb,
- format => "%4s %-55s %8s %-10s\n",
- dist_format => "%4s %-42s %-12s %8s %-10s\n",
- );
- ### make it available package wide ###
- $Shell = $self;
-
- my $rc_file = File::Spec->catfile(
- $cb->configure_object->get_conf('base'),
- DOT_SHELL_DEFAULT_RC,
- );
-
-
- if( -e $rc_file && -r _ ) {
- $rc = $self->_read_configuration_from_rc( $rc_file );
- }
-
- ### register install callback ###
- $cb->_register_callback(
- name => 'install_prerequisite',
- code => \&__ask_about_install,
- );
-
- ### execute any login commands specified ###
- $self->dispatch_on_input( input => $rc->{'login'} )
- if defined $rc->{'login'};
-
- ### register test report callbacks ###
- $cb->_register_callback(
- name => 'edit_test_report',
- code => \&__ask_about_edit_test_report,
- );
-
- $cb->_register_callback(
- name => 'send_test_report',
- code => \&__ask_about_send_test_report,
- );
-
- $cb->_register_callback(
- name => 'proceed_on_test_failure',
- code => \&__ask_about_test_failure,
- );
-
- ### load all the plugins
- $self->_plugins_init;
-
- if (my $histfile = $cb->configure_object->get_conf( 'histfile' )) {
- my $term = $self->term;
- if ($term->can('AddHistory')) {
- if (open my $fh, '<', $histfile) {
- local $/ = "\n";
- while (my $line = <$fh>) {
- chomp($line);
- $term->AddHistory($line);
- }
- close($fh);
- }
- }
- }
-
- return $self;
-}
-
-sub shell {
- my $self = shift;
- my $term = $self->term;
- my $conf = $self->backend->configure_object;
-
- $self->_show_banner;
- $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner?
- $self->_show_random_tip if $conf->get_conf('show_startup_tip');
- $self->_input_loop && $self->__print( "\n" );
- $self->_quit;
-}
-
-sub _input_loop {
- my $self = shift;
- my $term = $self->term;
- my $cb = $self->backend;
-
- my $normal_quit = 0;
- while (
- defined (my $input = eval { $term->readline($self->prompt) } )
- or $self->_signals->{INT}{count} == 1
- ) {
- ### re-initiate all signal handlers
- while (my ($sig, $entry) = each %{$self->_signals} ) {
- $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
- }
-
- $self->__print( "\n" );
- last if $self->dispatch_on_input( input => $input );
-
- ### flush the lib cache ###
- $cb->_flush( list => [qw|lib load|] );
-
- } continue {
- ### clear the sigint count
- $self->_signals->{INT}{count}--
- if $self->_signals->{INT}{count};
-
- ### reset the 'install prereq?' cached answer
- $self->settings->{'install_all_prereqs'} = undef;
-
- }
-
- return 1;
-}
-
-### return 1 to quit ###
-sub dispatch_on_input {
- my $self = shift;
- my $conf = $self->backend->configure_object();
- my $term = $self->term;
- my %hash = @_;
-
- my($string, $noninteractive);
- my $tmpl = {
- input => { required => 1, store => \$string },
- noninteractive => { required => 0, store => \$noninteractive },
- };
-
- check( $tmpl, \%hash ) or return;
-
- ### indicates whether or not the user will receive a shell
- ### prompt after the command has finished.
- $self->noninteractive($noninteractive) if defined $noninteractive;
-
- my $rv = 1;
-
- my @cmds = split ';', $string;
- while( my $input = shift @cmds ) {
-
- ### to send over the socket ###
- my $org_input = $input;
-
- my $key; my $options;
- { ### make whitespace not count when using special chars
- { $input =~ s|^\s*([!?/])|$1 |; }
-
- ### get the first letter of the input
- $input =~ s|^\s*([\w\?\!/])\w*||;
-
- chomp $input;
- $key = lc($1);
-
- ### we figured out what the command was...
- ### if we have more input, that DOES NOT start with a white
- ### space char, we misparsed.. like 'Test::Foo::Bar', which
- ### would turn into 't', '::Foo::Bar'...
- if( $input and $input !~ s/^\s+// ) {
- $self->__print( loc("Could not understand command: %1\n".
- "Possibly missing command before argument(s)?\n",
- $org_input) );
- return;
- }
-
- ### allow overrides from the config file ###
- if( defined $rc->{$key} ) {
- $input = $rc->{$key} . $input;
- }
-
- ### grab command line options like --no-force and --verbose ###
- ($options,$input) = $term->parse_options($input)
- unless $key eq '!';
- }
-
- ### emtpy line? ###
- return unless $key;
-
- ### time to quit ###
- return 1 if $key eq 'q';
-
- my $method = $map->{$key};
-
- ### dispatch meta locally at all times ###
- if( $key eq '/' ) {
- ### keep track of failures
- $rv *= length $self->$method(input => $input, options => $options);
- next;
- }
-
- ### flush unless we're trying to print the stack
- CPANPLUS::Error->flush unless $key eq 'p';
-
- ### connected over a socket? ###
- if( $self->remote ) {
-
- ### unsupported commands ###
- if( $key eq 'z' or
- ($key eq 's' and $input =~ /^\s*edit/)
- ) {
- $self->__print( "\n",
- loc( "Command '%1' not supported over remote connection",
- join ' ', $key, $input
- ), "\n\n" );
-
- } else {
- my($status,$buff) = $self->__send_remote_command($org_input);
-
- $self->__print( "\n", loc("Command failed!"), "\n\n" )
- unless $status;
-
- ### keep track of failures
- $rv *= length $status;
-
- $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount;
- $self->__print( $buff );
- $self->_pager_close;
- }
-
- ### or just a plain local shell? ###
- } else {
-
- unless( $self->can($method) ) {
- $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n");
- $self->_help;
-
- } else {
-
- ### some methods don't need modules ###
- my @mods;
- @mods = $self->_select_modules($input)
- unless grep {$key eq $_} qw[! m a v w x p s b / ? h];
-
- ### keep track of failures
- $rv *= defined eval { $self->$method(
- modules => \@mods,
- options => $options,
- input => $input,
- choice => $key )
- };
- error( $@ ) if $@;
- }
- }
- }
-
- ### outside the shell loop, we can return the actual return value;
- return $rv if $self->noninteractive;
-
- return;
-}
-
-sub _select_modules {
- my $self = shift;
- my $input = shift or return;
- my $cache = $self->cache;
- my $cb = $self->backend;
-
- ### expand .. in $input
- $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b}
- {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg;
-
- $input = join(' ', 1 .. $#{$cache}) if $input eq '*';
- $input =~ s/'/::/g; # perl 4 convention
-
- my @rv;
- for my $mod (split /\s+/, $input) {
-
- ### it's a cache look up ###
- if( $mod =~ /^\d+/ and $mod > 0 ) {
- unless( scalar @$cache ) {
- $self->__print( loc("No search was done yet!"), "\n" );
-
- } elsif ( my $obj = $cache->[$mod] ) {
- push @rv, $obj;
-
- } else {
- $self->__print( loc("No such module: %1", $mod), "\n" );
- }
-
- } else {
- my $obj = $cb->parse_module( module => $mod );
-
- unless( $obj ) {
- $self->__print( loc("No such module: %1", $mod), "\n" );
-
- } else {
- push @rv, $obj;
- }
- }
- }
-
- unless( scalar @rv ) {
- $self->__print( loc("No modules found to operate on!\n") );
- return;
- } else {
- return @rv;
- }
-}
-
-sub _format_version {
- my $self = shift;
- my $version = shift || 0;
-
- ### fudge $version into the 'optimal' format
- $version = 0 if $version eq 'undef';
- $version =~ s/_//g; # everything after gets stripped off otherwise
-
- ### allow 6 digits after the dot, as that's how perl stringifies
- ### x.y.z numbers.
- $version = sprintf('%3.6f', $version);
- $version = '' if $version == '0.00';
- $version =~ s/(00{0,3})$/' ' x (length $1)/e;
-
- return $version;
-}
-
-sub __display_results {
- my $self = shift;
- my $cache = $self->cache;
-
- my @rv = @$cache;
-
- if( scalar @rv ) {
-
- $self->_pager_open if $#{$cache} >= $self->_term_rowcount;
-
- my $i = 1;
- for my $mod (@rv) {
- next unless $mod; # first one is undef
- # humans start counting at 1
-
- ### for dists only -- we have checksum info
- if( $mod->mtime ) {
- $self->__printf(
- $self->dist_format,
- $i,
- $mod->module,
- $mod->mtime,
- $self->_format_version( $mod->version ),
- $mod->author->cpanid
- );
-
- } else {
- $self->__printf(
- $self->format,
- $i,
- $mod->module,
- $self->_format_version( $mod->version ),
- $mod->author->cpanid
- );
- }
- $i++;
- }
-
- $self->_pager_close;
-
- } else {
- $self->__print( loc("No results to display"), "\n" );
- }
-
- return 1;
-}
-
-
-sub _quit {
- my $self = shift;
- my $term = $self->term;
-
- $self->dispatch_on_input( input => $rc->{'logout'} )
- if defined $rc->{'logout'};
-
- if ($term->can('GetHistory')) {
- my @history = $term->GetHistory;
-
- my $histfile = $self->backend->configure_object->get_conf('histfile');
-
- if (open my $fh, '>', $histfile) {
- foreach my $line (@history) {
- print {$fh} "$line\n";
- }
- close($fh);
- }
- else {
- warn "Cannot open history file '$histfile' - $!";
- }
- }
-
- $self->__print( loc("Exiting CPANPLUS shell"), "\n" );
-
- return 1;
-}
-
-###########################
-### actual command subs ###
-###########################
-
-
-### print out the help message ###
-### perhaps, '?' should be a slightly different version ###
-{ my @help;
- sub _help {
- my $self = shift;
- my %hash = @_;
-
- my $input;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- input => { required => 0, store => \$input }
- };
-
- my $args = check( $tmpl, \%hash ) or return;
- }
-
- @help = (
-loc('[General]' ),
-loc(' h | ? # display help' ),
-loc(' q # exit' ),
-loc(' e # exit and reload' ),
-loc(' v # version information' ),
-loc('[Search]' ),
-loc(' a AUTHOR ... # search by author(s)' ),
-loc(' m MODULE ... # search by module(s)' ),
-loc(' f MODULE ... # list all releases of a module' ),
-loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ),
-loc(' w # display the result of your last search again' ),
-loc('[Operations]' ),
-loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ),
-loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ),
-loc(' i DIR | ... # install module(s), by path (ie ./Module-1.0)' ),
-loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ),
-loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ),
-loc(' d MODULE | NUMBER ... # download module(s)' ),
-loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ),
-loc(' r MODULE | NUMBER ... # display README files of module(s)' ),
-loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ),
-loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ),
-loc('[Local Administration]' ),
-loc(' b # write a bundle file for your configuration' ),
-loc(' s program [OPT VALUE] # set program locations for this session' ),
-loc(' s conf [OPT VALUE] # set config options for this session' ),
-loc(' s mirrors # show currently selected mirrors' ),
-loc(' s reconfigure # reconfigure settings ' ),
-loc(' s selfupdate # update your CPANPLUS install '),
-loc(' s save [user|system] # save settings for this user or systemwide' ),
-loc(' s edit [user|system] # open configuration file in editor and reload' ),
-loc(' ! EXPR # evaluate a perl statement' ),
-loc(' p [FILE] # print the error stack (optionally to a file)' ),
-loc(' x # reload CPAN indices (purges cache)' ),
-loc(' x --update_source # reload CPAN indices, get fresh source files' ),
-loc('[Common Options]' ),
-loc(' i ... --skiptest # skip tests' ),
-loc(' i ... --force # force all operations' ),
-loc(' i ... --verbose # run in verbose mode' ),
-loc('[Plugins]' ),
-loc(' /plugins # list available plugins' ),
-loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ),
-
- ) unless @help;
-
- $self->_pager_open if (@help >= $self->_term_rowcount);
- ### XXX: functional placeholder for actual 'detailed' help.
- $self->__print( "Detailed help for the command '$input' is " .
- "not available.\n\n" ) if length $input;
- $self->__print( map {"$_\n"} @help );
- $self->__print( $/ );
- $self->_pager_close;
-
- return 1;
- }
-}
-
-### eval some code ###
-sub _bang {
- my $self = shift;
- my $cb = $self->backend;
- my %hash = @_;
-
-
- my $input;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- input => { required => 1, store => \$input }
- };
-
- my $args = check( $tmpl, \%hash ) or return;
- }
-
- local $Data::Dumper::Indent = 1; # for dumpering from !
- eval $input;
- error( $@ ) if $@;
- $self->__print( "\n" );
-
- return if $@;
- return 1;
-}
-
-sub _search_module {
- my $self = shift;
- my $cb = $self->backend;
- my %hash = @_;
-
- my $args;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- input => { required => 1, },
- options => { default => { } },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
-
- ### XXX this is rather slow, because (probably)
- ### of the many method calls
- ### XXX need to profile to speed it up =/
-
- ### find the modules ###
- my @rv = sort { $a->module cmp $b->module }
- $cb->search(
- %{$args->{'options'}},
- type => 'module',
- allow => \@regexes,
- );
-
- ### store the result in the cache ###
- $self->cache([undef,@rv]);
-
- $self->__display_results;
-
- return 1;
-}
-
-sub _search_author {
- my $self = shift;
- my $cb = $self->backend;
- my %hash = @_;
-
- my $args;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- input => { required => 1, },
- options => { default => { } },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
-
- my @rv;
- for my $type (qw[author cpanid]) {
- push @rv, $cb->search(
- %{$args->{'options'}},
- type => $type,
- allow => \@regexes,
- );
- }
-
- my %seen;
- my @list = sort { $a->module cmp $b->module }
- grep { defined }
- map { $_->modules }
- grep { not $seen{$_}++ } @rv;
-
- $self->cache([undef,@list]);
-
- $self->__display_results;
- return 1;
-}
-
-sub _readme {
- my $self = shift;
- my $cb = $self->backend;
- my %hash = @_;
-
- my $args; my $mods; my $opts;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- modules => { required => 1, store => \$mods },
- options => { default => { }, store => \$opts },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- return unless scalar @$mods;
-
- $self->_pager_open;
- for my $mod ( @$mods ) {
- $self->__print( $mod->readme( %$opts ) );
- }
-
- $self->_pager_close;
-
- return 1;
-}
-
-sub _fetch {
- my $self = shift;
- my $cb = $self->backend;
- my %hash = @_;
-
- my $args; my $mods; my $opts;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- modules => { required => 1, store => \$mods },
- options => { default => { }, store => \$opts },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- $self->_pager_open if @$mods >= $self->_term_rowcount;
- my $rv = 1;
- for my $mod (@$mods) {
- my $where = $mod->fetch( %$opts );
-
- $rv *= length $where;
-
- $self->__print(
- $where
- ? loc("Successfully fetched '%1' to '%2'",
- $mod->module, $where )
- : loc("Failed to fetch '%1'", $mod->module)
- );
- $self->__print( "\n" );
- }
- $self->_pager_close;
-
- return 1 if $rv;
- return;
-}
-
-sub _shell {
- my $self = shift;
- my $cb = $self->backend;
- my $conf = $cb->configure_object;
- my %hash = @_;
-
- my $shell = $conf->get_program('shell');
- unless( $shell ) {
- $self->__print(
- loc("Your config does not specify a subshell!"), "\n",
- loc("Perhaps you need to re-run your setup?"), "\n"
- );
- return;
- }
-
- my $args; my $mods; my $opts;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- modules => { required => 1, store => \$mods },
- options => { default => { }, store => \$opts },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- my $cwd = Cwd::cwd();
- for my $mod (@$mods) {
- $mod->fetch( %$opts ) or next;
- $mod->extract( %$opts ) or next;
-
- $cb->_chdir( dir => $mod->status->extract() ) or next;
-
- #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
-
- if( system($shell) and $! ) {
- $self->__print(
- loc("Error executing your subshell '%1': %2",
- $shell, $!),"\n"
- );
- next;
- }
- }
- $cb->_chdir( dir => $cwd );
-
- return 1;
-}
-
-sub _distributions {
- my $self = shift;
- my $cb = $self->backend;
- my $conf = $cb->configure_object;
- my %hash = @_;
-
- my $args; my $mods; my $opts;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- modules => { required => 1, store => \$mods },
- options => { default => { }, store => \$opts },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- my @list;
- for my $mod (@$mods) {
- push @list, sort { $a->version <=> $b->version }
- grep { defined } $mod->distributions( %$opts );
- }
-
- my @rv = sort { $a->module cmp $b->module } @list;
-
- $self->cache([undef,@rv]);
- $self->__display_results;
-
- return 1;
-}
-
-sub _reload_indices {
- my $self = shift;
- my $cb = $self->backend;
- my %hash = @_;
-
- my $args; my $opts;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- my $rv = $cb->reload_indices( %$opts );
-
- ### so the update failed, but you didnt give it any options either
- if( !$rv and !(keys %$opts) ) {
- $self->__print(
- "\nFailure may be due to corrupt source files\n" .
- "Try this:\n\tx --update_source\n\n" );
- }
-
- return $rv;
-
-}
-
-sub _install {
- my $self = shift;
- my $cb = $self->backend;
- my $conf = $cb->configure_object;
- my %hash = @_;
-
- my $args; my $mods; my $opts; my $choice;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- modules => { required => 1, store => \$mods },
- options => { default => { }, store => \$opts },
- choice => { required => 1, store => \$choice,
- allow => [qw|i t|] },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- unless( scalar @$mods ) {
- $self->__print( loc("Nothing done\n") );
- return;
- }
-
- my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE;
- my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing ');
- my $action = $choice eq 'i' ? 'install' : 'test';
-
- my $status = {};
- ### first loop over the mods to install them ###
- for my $mod (@$mods) {
- $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" );
-
- my $log_length = length CPANPLUS::Error->stack_as_string;
-
- ### store the status for look up when we're done with all
- ### install calls
- $status->{$mod} = $mod->install( %$opts, target => $target );
-
- ### would you like a log file of what happened?
- if( $conf->get_conf('write_install_logs') ) {
-
- if ( ON_WIN32 and !check_install(
- module => 'IPC::Run', version => 0.55 )
- ) {
- error(loc("IPC::Run version '%1' is required on MSWin32"
- . " in order to capture buffers."
- . " The logfile generated may not contain"
- . " any useful data, until it is installed", 0.55));
- }
-
- my $dir = File::Spec->catdir(
- $conf->get_conf('base'),
- $conf->_get_build('install_log_dir'),
- );
- ### create the dir if it doesn't exit yet
- $cb->_mkdir( dir => $dir ) unless -d $dir;
-
- my $file = File::Spec->catfile(
- $dir,
- INSTALL_LOG_FILE->( $mod )
- );
- if ( open my $fh, ">$file" ) {
- my $stack = CPANPLUS::Error->stack_as_string;
- ### remove everything in the log that was there *before*
- ### we started this install
- substr( $stack, 0, $log_length, '' );
-
- print $fh $stack;
- close $fh;
-
- $self->__print(
- loc("*** Install log written to:\n %1\n\n", $file)
- );
- } else {
- warn "Could not open '$file': $!\n";
- next;
- }
- }
- }
-
- my $flag;
- ### then report whether all this went ok or not ###
- for my $mod (@$mods) {
- # if( $mod->status->installed ) {
- if( $status->{$mod} ) {
- $self->__print(
- loc("Module '%1' %tense(%2,past) successfully\n",
- $mod->module, $action)
- );
- } else {
- $flag++;
- $self->__print(
- loc("Error %tense(%1,present) '%2'\n", $action, $mod->module)
- );
- }
- }
-
-
-
- if( !$flag ) {
- $self->__print(
- loc("No errors %tense(%1,present) all modules", $action), "\n"
- );
- } else {
- $self->__print(
- loc("Problem %tense(%1,present) one or more modules", $action)
- );
- $self->__print( "\n" );
-
- $self->__print(
- loc("*** You can view the complete error buffer by pressing ".
- "'%1' ***\n", 'p')
- ) unless $conf->get_conf('verbose') || $self->noninteractive;
- }
- $self->__print( "\n" );
-
- return !$flag;
-}
-
-sub __ask_about_install {
- my $mod = shift or return;
- my $prereq = shift or return;
- my $term = $Shell->term;
-
- $Shell->__print( "\n" );
- $Shell->__print( loc("Module '%1' requires '%2' to be installed",
- $mod->module, $prereq->module ) );
- $Shell->__print( "\n\n" );
-
- ### previously cached answer?
- return $Shell->settings->{'install_all_prereqs'}
- if defined $Shell->settings->{'install_all_prereqs'};
-
-
- $Shell->__print(
- loc( "If you don't wish to see this question anymore\n".
- "you can disable it by entering the following ".
- "commands on the prompt:\n '%1'",
- 's conf prereqs 1; s save' ) );
- $Shell->__print("\n\n");
-
- my $yes = loc("Yes");
- my $no = loc("No");
- my $all = loc("Yes to all (for this module)");
- my $none = loc("No to all (for this module)");
-
- my $reply = $term->get_reply(
- prompt => loc("Should I install this module?"),
- choices => [ $yes, $no, $all, $none ],
- default => $yes,
- );
-
- ### if 'all' or 'none', save this, so we can apply it to
- ### other prereqs in this chain.
- $Shell->settings->{'install_all_prereqs'} =
- $reply eq $all ? 1 :
- $reply eq $none ? 0 :
- undef;
-
- ### if 'yes' or 'all', the user wants it installed
- return $reply eq $all ? 1 :
- $reply eq $yes ? 1 :
- 0;
-}
-
-sub __ask_about_send_test_report {
- my($mod, $grade) = @_;
- return 1 unless $grade eq GRADE_FAIL;
-
- my $term = $Shell->term;
-
- $Shell->__print( "\n" );
- $Shell->__print(
- loc("Test report prepared for module '%1'.\n Would you like to ".
- "send it? (You can edit it if you like)", $mod->module ) );
- $Shell->__print( "\n\n" );
- my $bool = $term->ask_yn(
- prompt => loc("Would you like to send the test report?"),
- default => 'n'
- );
-
- return $bool;
-}
-
-sub __ask_about_edit_test_report {
- my($mod, $grade) = @_;
- return 0 unless $grade eq GRADE_FAIL;
-
- my $term = $Shell->term;
-
- $Shell->__print( "\n" );
- $Shell->__print(
- loc("Test report prepared for module '%1'. You can edit this ".
- "report if you would like", $mod->module ) );
- $Shell->__print("\n\n");
- my $bool = $term->ask_yn(
- prompt => loc("Would you like to edit the test report?"),
- default => 'y'
- );
-
- return $bool;
-}
-
-sub __ask_about_test_failure {
- my $mod = shift;
- my $captured = shift || '';
- my $term = $Shell->term;
-
- $Shell->__print( "\n" );
- $Shell->__print(
- loc( "The tests for '%1' failed. Would you like me to proceed ".
- "anyway or should we abort?", $mod->module ) );
- $Shell->__print( "\n\n" );
-
- my $bool = $term->ask_yn(
- prompt => loc("Proceed anyway?"),
- default => 'n',
- );
-
- return $bool;
-}
-
-
-sub _details {
- my $self = shift;
- my $cb = $self->backend;
- my $conf = $cb->configure_object;
- my %hash = @_;
-
- my $args; my $mods; my $opts;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- modules => { required => 1, store => \$mods },
- options => { default => { }, store => \$opts },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- ### every module has about 10 lines of details
- ### maybe more later with Module::CPANTS etc
- $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount;
-
-
- my $format = "%-24s %-45s\n";
- my $cformat = "%-24s %-45s %-10s\n";
- for my $mod (@$mods) {
- my $href = $mod->details( %$opts );
- my @list = sort { $a->module cmp $b->module } $mod->contains;
-
- unless( $href ) {
- $self->__print(
- loc("No details for %1 - it might be outdated.",
- $mod->module), "\n" );
- next;
-
- } else {
- $self->__print( loc( "Details for '%1'\n", $mod->module ) );
- for my $item ( sort keys %$href ) {
- $self->__printf( $format, $item, $href->{$item} );
- }
-
- my $showed;
- for my $item ( @list ) {
- $self->__printf(
- $cformat, ($showed ? '' : 'Contains:'),
- $item->module, $item->version
- );
- $showed++;
- }
- $self->__print( "\n" );
- }
- }
- $self->_pager_close;
- $self->__print( "\n" );
-
- return 1;
-}
-
-sub _print {
- my $self = shift;
- my %hash = @_;
-
- my $args; my $opts; my $file;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- input => { default => '', store => \$file },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- my $old; my $fh;
- if( $file ) {
- $fh = FileHandle->new( ">$file" )
- or( warn loc("Could not open '%1': '%2'", $file, $!),
- return
- );
- $old = select $fh;
- }
-
-
- $self->_pager_open if !$file;
-
- $self->__print( CPANPLUS::Error->stack_as_string );
-
- $self->_pager_close;
-
- select $old if $old;
- $self->__print( "\n" );
-
- return 1;
-}
-
-sub _set_conf {
- my $self = shift;
- my %hash = @_;
- my $cb = $self->backend;
- my $conf = $cb->configure_object;
-
- ### possible options
- ### XXX hard coded, not optimal :(
- my %types = (
- reconfigure => '',
- save => q([user | system | boxed]),
- edit => '',
- program => q([key => val]),
- conf => q([key => val]),
- mirrors => '',
- selfupdate => '', # XXX add all opts here?
- );
-
-
- my $args; my $opts; my $input;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- input => { default => '', store => \$input },
- };
-
- $args = check( $tmpl, \%hash ) or return;
- }
-
- my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)$/;
- $value =~ s/\s+$//g if $value;
- $type = '' unless defined $type;
- $type = lc $type;
-
- if( $type eq 'reconfigure' ) {
- my $setup = CPANPLUS::Configure::Setup->new(
- configure_object => $conf,
- term => $self->term,
- backend => $cb,
- );
- return $setup->init;
-
- } elsif ( $type eq 'save' ) {
- my $where = {
- user => CONFIG_USER,
- system => CONFIG_SYSTEM,
- boxed => CONFIG_BOXED,
- }->{ $key } || CONFIG_USER;
-
- ### boxed is special, so let's get its value from %INC
- ### so we can tell it where to save
- ### XXX perhaps this logic should be generic for all
- ### types, and put in the ->save() routine
- my $dir;
- if( $where eq CONFIG_BOXED ) {
- my $file = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm';
- my $file_re = quotemeta($file);
-
- my $path = $INC{$file} || '';
- $path =~ s/$file_re$//;
- $dir = $path;
- }
-
- my $rv = $cb->configure_object->save( $where => $dir );
-
- $self->__print(
- $rv
- ? loc("Configuration successfully saved to %1\n (%2)\n",
- $where, $rv)
- : loc("Failed to save configuration\n" )
- );
- return $rv;
-
- } elsif ( $type eq 'edit' ) {
-
- my $editor = $conf->get_program('editor')
- or( print(loc("No editor specified")), return );
-
- my $where = {
- user => CONFIG_USER,
- system => CONFIG_SYSTEM,
- }->{ $key } || CONFIG_USER;
-
- my $file = $conf->_config_pm_to_file( $where );
- system($editor,$file);
-
- ### now reload it
- ### disable warnings for this
- { require Module::Loaded;
- Module::Loaded::mark_as_unloaded( $where );
-
- ### reinitialize the config
- local $^W;
- $conf->init;
- }
-
- return 1;
-
- } elsif ( $type eq 'mirrors' ) {
-
- $self->__print(
- loc("Readonly list of mirrors (in order of preference):\n\n" ) );
-
- my $i;
- for my $host ( @{$conf->get_conf('hosts')} ) {
- my $uri = $cb->_host_to_uri( %$host );
-
- $i++;
- $self->__print( "\t[$i] $uri\n" );
- }
-
- $self->__print(
- loc("\nTo edit this list, please type: '%1'\n", 's edit') );
-
- } elsif ( $type eq 'selfupdate' ) {
- my %valid = map { $_ => $_ }
- $cb->selfupdate_object->list_categories;
-
- unless( $valid{$key} ) {
- $self->__print(
- loc( "To update your current CPANPLUS installation, ".
- "choose one of the these options:\n%1",
- ( join $/, map {
- sprintf "\ts selfupdate %-17s " .
- "[--latest=0] [--dryrun]", $_
- } sort keys %valid )
- )
- );
- } else {
- my %update_args = (
- update => $key,
- latest => 1,
- %$opts
- );
-
-
- my %list = $cb->selfupdate_object
- ->list_modules_to_update( %update_args );
-
- $self->__print(loc("The following updates will take place:"),$/.$/);
-
- for my $feature ( sort keys %list ) {
- my $aref = $list{$feature};
-
- ### is it a 'feature' or a built in?
- $self->__print(
- $valid{$feature}
- ? " " . ucfirst($feature) . ":\n"
- : " Modules for '$feature' support:\n"
- );
-
- ### show what modules would be installed
- $self->__print(
- scalar @$aref
- ? map { sprintf " %-42s %-6s -> %-6s \n",
- $_->name, $_->installed_version, $_->version
- } @$aref
- : " No upgrades required\n"
- );
- $self->__print( $/ );
- }
-
-
- unless( $opts->{'dryrun'} ) {
- $self->__print( loc("Updating your CPANPLUS installation\n") );
- $cb->selfupdate_object->selfupdate( %update_args );
- }
- }
-
- } else {
-
- if ( $type eq 'program' or $type eq 'conf' ) {
-
- my $format = {
- conf => '%-25s %s',
- program => '%-12s %s',
- }->{ $type };
-
- unless( $key ) {
- my @list = grep { $_ ne 'hosts' }
- $conf->options( type => $type );
-
- my $method = 'get_' . $type;
-
- local $Data::Dumper::Indent = 0;
- for my $name ( @list ) {
- my $val = $conf->$method($name) || '';
- ($val) = ref($val)
- ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
- : "'$val'";
-
- $self->__printf( " $format\n", $name, $val );
- }
-
- } elsif ( $key eq 'hosts' or $key eq 'lib' ) {
- $self->__print(
- loc( "Setting %1 is not trivial.\n" .
- "It is suggested you use '%2' and edit the " .
- "configuration file manually", $key, 's edit')
- );
- } else {
- my $method = 'set_' . $type;
- $conf->$method( $key => defined $value ? $value : '' )
- and $self->__print( loc("Key '%1' was set to '%2'", $key,
- defined $value ? $value : 'EMPTY STRING') );
- }
-
- } else {
- $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) );
- $self->__print( $/ );
- $self->__print( loc("Try one of the following:") );
- $self->__print( $/, join $/,
- map { sprintf "\t%-11s %s", $_, $types{$_} }
- sort keys %types );
- }
- }
- $self->__print( "\n" );
- return 1;
-}
-
-sub _uptodate {
- my $self = shift;
- my %hash = @_;
- my $cb = $self->backend;
- my $conf = $cb->configure_object;
-
- my $opts; my $mods;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- modules => { required => 1, store => \$mods },
- };
-
- check( $tmpl, \%hash ) or return;
- }
-
- ### long listing? short is default ###
- my $long = $opts->{'long'} ? 1 : 0;
-
- my @list = scalar @$mods ? @$mods : @{$cb->_all_installed};
-
- my @rv; my %seen;
- for my $mod (@list) {
- ### skip this mod if it's up to date ###
- next if $mod->is_uptodate;
- ### skip this mod if it's core ###
- next if $mod->package_is_perl_core;
-
- if( $long or !$seen{$mod->package}++ ) {
- push @rv, $mod;
- }
- }
-
- @rv = sort { $a->module cmp $b->module } @rv;
-
- $self->cache([undef,@rv]);
-
- $self->_pager_open if scalar @rv >= $self->_term_rowcount;
-
- my $format = "%5s %12s %12s %-36s %-10s\n";
-
- my $i = 1;
- for my $mod ( @rv ) {
- $self->__printf(
- $format,
- $i,
- $self->_format_version($mod->installed_version) || 'Unparsable',
- $self->_format_version( $mod->version ),
- $mod->module,
- $mod->author->cpanid
- );
- $i++;
- }
- $self->_pager_close;
-
- return 1;
-}
-
-sub _autobundle {
- my $self = shift;
- my %hash = @_;
- my $cb = $self->backend;
- my $conf = $cb->configure_object;
-
- my $opts; my $input;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- input => { default => '', store => \$input },
- };
-
- check( $tmpl, \%hash ) or return;
- }
-
- $opts->{'path'} = $input if $input;
-
- my $where = $cb->autobundle( %$opts );
-
- $self->__print(
- $where
- ? loc("Wrote autobundle to '%1'", $where)
- : loc("Could not create autobundle" )
- );
- $self->__print( "\n" );
-
- return $where ? 1 : 0;
-}
-
-sub _uninstall {
- my $self = shift;
- my %hash = @_;
- my $cb = $self->backend;
- my $term = $self->term;
- my $conf = $cb->configure_object;
-
- my $opts; my $mods;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- modules => { default => [], store => \$mods },
- };
-
- check( $tmpl, \%hash ) or return;
- }
-
- my $force = $opts->{'force'} || $conf->get_conf('force');
-
- unless( $force ) {
- my $list = join "\n", map { ' ' . $_->module } @$mods;
-
- $self->__print( loc("
-This will uninstall the following modules:
-%1
-
-Note that if you installed them via a package manager, you probably
-should use the same package manager to uninstall them
-
-", $list) );
-
- return unless $term->ask_yn(
- prompt => loc("Are you sure you want to continue?"),
- default => 'n',
- );
- }
-
- ### first loop over all the modules to uninstall them ###
- for my $mod (@$mods) {
- $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" );
-
- $mod->uninstall( %$opts );
- }
-
- my $flag;
- ### then report whether all this went ok or not ###
- for my $mod (@$mods) {
- if( $mod->status->uninstall ) {
- $self->__print(
- loc("Module '%1' %tense(uninstall,past) successfully\n",
- $mod->module ) );
- } else {
- $flag++;
- $self->__print(
- loc("Error %tense(uninstall,present) '%1'\n", $mod->module) );
- }
- }
-
- if( !$flag ) {
- $self->__print(
- loc("All modules %tense(uninstall,past) successfully"), "\n" );
- } else {
- $self->__print(
- loc("Problem %tense(uninstall,present) one or more modules" ),
- "\n" );
-
- $self->__print(
- loc("*** You can view the complete error buffer by pressing '%1'".
- "***\n", 'p') ) unless $conf->get_conf('verbose');
- }
- $self->__print( "\n" );
-
- return !$flag;
-}
-
-sub _reports {
- my $self = shift;
- my %hash = @_;
- my $cb = $self->backend;
- my $term = $self->term;
- my $conf = $cb->configure_object;
-
- my $opts; my $mods;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- modules => { default => '', store => \$mods },
- };
-
- check( $tmpl, \%hash ) or return;
- }
-
- ### XXX might need to be conditional ###
- $self->_pager_open;
-
- for my $mod (@$mods) {
- my @list = $mod->fetch_report( %$opts )
- or( print(loc("No reports available for this distribution.")),
- next
- );
-
- @list = reverse
- map { $_->[0] }
- sort { $a->[1] cmp $b->[1] }
- map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list;
-
-
-
- ### XXX this may need to be sorted better somehow ###
- my $url;
- my $format = "%8s %s %s\n";
-
- my %seen;
- for my $href (@list ) {
- $self->__print(
- "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n"
- ) unless $seen{ $href->{'dist'} }++;
-
- $self->__printf(
- $format,
- $href->{'grade'},
- $href->{'platform'},
- ($href->{'details'} ? '(*)' : '')
- );
-
- $url ||= $href->{'details'};
- }
-
- $self->__print( "\n==> $url\n" ) if $url;
- $self->__print( "\n" );
- }
- $self->_pager_close;
-
- return 1;
-}
-
-### Load plugins
-{ my @PluginModules;
- my %Dispatch = (
- showtip => [ __PACKAGE__, '_show_random_tip'],
- plugins => [ __PACKAGE__, '_list_plugins' ],
- '?' => [ __PACKAGE__, '_plugins_usage' ],
- );
-
- sub plugin_modules { return @PluginModules }
- sub plugin_table { return %Dispatch }
-
- my $init_done;
- sub _plugins_init {
-
- ### only initialize once
- return if $init_done++;
-
- ### find all plugins first
- if( check_install( module => 'Module::Pluggable', version => '2.4') ) {
- require Module::Pluggable;
-
- my $only_re = __PACKAGE__ . '::Plugins::\w+$';
-
- Module::Pluggable->import(
- sub_name => '_plugins',
- search_path => __PACKAGE__,
- only => qr/$only_re/,
- #except => [ INSTALLER_MM, INSTALLER_SAMPLE ]
- );
-
- push @PluginModules, __PACKAGE__->_plugins;
- }
-
- ### now try to load them
- for my $p ( __PACKAGE__->plugin_modules ) {
- my %map = eval { load $p; $p->import; $p->plugins };
- error(loc("Could not load plugin '$p': $@")), next if $@;
-
- ### register each plugin
- while( my($name, $func) = each %map ) {
-
- if( not length $name or not length $func ) {
- error(loc("Empty plugin name or dispatch function detected"));
- next;
- }
-
- if( exists( $Dispatch{$name} ) ) {
- error(loc("'%1' is already registered by '%2'",
- $name, $Dispatch{$name}->[0]));
- next;
- }
-
- ### register name, package and function
- $Dispatch{$name} = [ $p, $func ];
- }
- }
- }
-
- ### dispatch a plugin command to its function
- sub _meta {
- my $self = shift;
- my %hash = @_;
- my $cb = $self->backend;
- my $term = $self->term;
- my $conf = $cb->configure_object;
-
- my $opts; my $input;
- { local $Params::Check::ALLOW_UNKNOWN = 1;
-
- my $tmpl = {
- options => { default => { }, store => \$opts },
- input => { default => '', store => \$input },
- };
-
- check( $tmpl, \%hash ) or return;
- }
-
- $input =~ s/\s*(\S+)\s*//;
- my $cmd = $1;
-
- ### look up the command, or go to the default
- my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ];
-
- my($pkg,$func) = @$aref;
-
- my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) };
-
- error( $@ ) if $@;
-
- ### return $rv instead, so input loop can be terminated?
- return 1;
- }
-
- sub _plugin_default { error(loc("No such plugin command")) }
-}
-
-### plugin commands
-{ my $help_format = " /%-21s # %s\n";
-
- sub _list_plugins {
- my $self = shift;
-
- $self->__print( loc("Available plugins:\n") );
- $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) );
- $self->__print( $/ );
-
- my %table = __PACKAGE__->plugin_table;
- for my $name( sort keys %table ) {
- my $pkg = $table{$name}->[0];
- my $this = __PACKAGE__;
-
- my $who = $pkg eq $this
- ? "Standard Plugin"
- : do { my $v = $self->_format_version($pkg->VERSION) || '';
- $pkg =~ s/^$this/../;
- sprintf "Provided by: %-30s %-10s", $pkg, $v;
- };
-
- $self->__printf( $help_format, $name, $who );
- }
-
- $self->__print( $/.$/ );
-
- $self->__print(
- " Write your own plugins? Read the documentation of:\n" .
- " CPANPLUS::Shell::Default::Plugins::HOWTO\n" );
-
- $self->__print( $/ );
- }
-
- sub _list_plugins_help {
- return sprintf $help_format, 'plugins', loc("lists available plugins");
- }
-
- ### registered as a plugin too
- sub _show_random_tip_help {
- return sprintf $help_format, 'showtip', loc("show usage tips" );
- }
-
- sub _plugins_usage {
- my $self = shift;
- my $shell = shift;
- my $cb = shift;
- my $cmd = shift;
- my $input = shift;
- my %table = $self->plugin_table;
-
- my @list = length $input ? split /\s+/, $input : sort keys %table;
-
- for my $name( @list ) {
-
- ### no such plugin? skip
- error(loc("No such plugin '$name'")), next unless $table{$name};
-
- my $pkg = $table{$name}->[0];
- my $func = $table{$name}->[1] . '_help';
-
- if ( my $sub = $pkg->can( $func ) ) {
- eval { $self->__print( $sub->() ) };
- error( $@ ) if $@;
-
- } else {
- $self->__print(" No usage for '$name' -- try perldoc $pkg");
- }
-
- $self->__print( $/ );
- }
-
- $self->__print( $/.$/ );
- }
-
- sub _plugins_usage_help {
- return sprintf $help_format, '? [NAME ...]',
- loc("show usage for plugins");
- }
-}
-
-### send a command to a remote host, retrieve the answer;
-sub __send_remote_command {
- my $self = shift;
- my $cmd = shift;
- my $remote = $self->remote or return;
- my $user = $remote->{'username'};
- my $pass = $remote->{'password'};
- my $conn = $remote->{'connection'};
- my $end = "\015\012";
- my $answer;
-
- my $send = join "\0", $user, $pass, $cmd;
-
- print $conn $send . $end;
-
- ### XXX why doesn't something like this just work?
- #1 while recv($conn, $answer, 1024, 0);
- while(1) {
- my $buff;
- $conn->recv( $buff, 1024, 0 );
- $answer .= $buff;
- last if $buff =~ /$end$/;
- }
-
- my($status,$buffer) = split "\0", $answer;
-
- return ($status, $buffer);
-}
-
-
-sub _read_configuration_from_rc {
- my $self = shift;
- my $rc_file = shift;
-
- my $href;
- if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) {
- $Config::Auto::DisablePerl = 1;
-
- eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) };
-
- $self->__print(
- loc( "Unable to read in config file '%1': %2", $rc_file, $@ )
- ) if $@;
- }
-
- return $href || {};
-}
-
-{ my @tips = (
- loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ),
- loc( "You can install modules by URL using '%1'", 'i URL' ),
- loc( "You can turn off these tips using '%1'",
- 's conf show_startup_tip 0' ),
- loc( "You can use wildcards like '%1' and '%2' on search results",
- '*', '2..5' ) ,
- loc( "You can use plugins. Type '%1' to list available plugins",
- '/plugins' ),
- loc( "You can show all your out of date modules using '%1'", 'o' ),
- loc( "Many operations take options, like '%1', '%2' or '%3'",
- '--verbose', '--force', '--skiptest' ),
- loc( "The documentation in %1 and %2 is very useful",
- "CPANPLUS::Module", "CPANPLUS::Backend" ),
- loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ),
- loc( "You can run an interactive setup using '%1'", 's reconfigure' ),
- loc( "You can add custom sources to your index. See '%1' for details",
- '/cs --help' ),
- loc( "CPANPLUS now has an experimental SQLite backend. You can enable ".
- "it via: '%1'. Update dependencies via '%2'",
- 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save',
- 's selfupdate enabled_features ' ),
- );
-
- sub _show_random_tip {
- my $self = shift;
- $self->__print( $/, "Did you know...\n ",
- $tips[ int rand scalar @tips ], $/ );
- return 1;
- }
-}
-
-sub _reload_shell {
- { exec ($^X, '-MCPANPLUS', '-e', 'shell') }; print STDERR "couldn't exec foo: $!";
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 BUG REPORTS
-
-Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
-
-=head1 AUTHOR
-
-This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
-
-=head1 COPYRIGHT
-
-The CPAN++ interface (of which this module is a part of) is copyright (c)
-2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
-
-This library is free software; you may redistribute and/or modify it
-under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp>
-
-=cut
-
-# Local variables:
-# c-indentation-style: bsd
-# c-basic-offset: 4
-# indent-tabs-mode: nil
-# End:
-# vim: expandtab shiftwidth=4:
-
-__END__
-
-TODO:
- e => "_expand_inc", # scratch it, imho -- not used enough
-
-### free letters: g j k n y ###