package CPANPLUS::Shell::Default; 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.84"; } 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', }; ### 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 =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 # install from URI, like ftp://foo.com/X.tgz 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> /plugins # list avialable plugins cpanp> /? PLUGIN # list help test of ### 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. You can start it via the C binary, or as detailed in the L. =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; 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 { $self->_signals->{INT}{count}-- if $self->_signals->{INT}{count}; # clear the sigint count } 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 @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 ### $self->$method(input => $input, options => $options), next if $key eq '/'; ### 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; $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]; eval { $self->$method( modules => \@mods, options => $options, input => $input, choice => $key ) }; error( $@ ) if $@; } } } 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; ### 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" ); } } sub _quit { my $self = shift; $self->dispatch_on_input( input => $rc->{'logout'} ) if defined $rc->{'logout'}; $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); } ########################### ### 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(' 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(' 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; } } ### 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; } 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; for my $mod (@$mods) { my $where = $mod->fetch( %$opts ); $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; } 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') ) { 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" ); $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 $bool = $term->ask_yn( prompt => loc("Should I install this module?"), default => 'y' ); return $bool; } 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 = "%-30s %-30s\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( $format, ($showed ? '' : 'Contains:'), $item->module ); $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*(.*?)\s*$/; $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 it's 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( $_ ) for $conf->configs; ### 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" ); } } 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' ) { $self->__print( loc( "Setting hosts is not trivial.\n" . "It is suggested you use '%1' and edit the " . "configuration file manually", '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(uninstalling,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 it's 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 { $pkg =~ s/^$this/../; "Provided by: $pkg" }; $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' ), ); sub _show_random_tip { my $self = shift; $self->__print( $/, "Did you know...\n ", $tips[ int rand scalar @tips ], $/ ); return 1; } } 1; __END__ =pod =head1 BUG REPORTS Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. =head1 AUTHOR This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L =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 ###