1 package CPANPLUS::Shell::Default;
8 use CPANPLUS::Configure::Setup;
9 use CPANPLUS::Internals::Constants;
10 use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL];
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';
23 local $Params::Check::VERBOSE = 1;
24 local $Data::Dumper::Indent = 1; # for dumpering from !
27 use vars qw[ $VERSION @ISA ];
28 @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ];
36 'm' => '_search_module',
37 'a' => '_search_author',
43 'v' => '_show_banner',
44 'w' => '__display_results',
47 'f' => '_distributions',
48 'x' => '_reload_indices',
57 '/' => '_meta', # undocumented for now
60 ### free letters: e g j k n y ###
63 ### will be filled if you have a .default-shell.rc and
64 ### Config::Auto installed
67 ### the shell object, scoped to the file ###
69 my $Brand = loc('CPAN Terminal');
70 my $Prompt = $Brand . '> ';
76 CPANPLUS::Shell::Default
80 ### loading the shell:
81 $ cpanp # run 'cpanp' from the command line
82 $ perl -MCPANPLUS -eshell # load the shell from the command line
85 use CPANPLUS::Shell qw[Default]; # load this shell via the API
86 # always done via CPANPLUS::Shell
88 my $ui = CPANPLUS::Shell->new;
89 $ui->shell; # run the shell
90 $ui->dispatch_on_input( input => 'x'); # update the source using the
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
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
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 <DIR> # install from an absolute or relative directory
108 cpanp> i 1 3..5 # install search results 1, 3, 4 and 5
109 cpanp> i * # install all search results
110 cpanp> a KANE; i *; # find modules by kane, install all results
111 cpanp> t Acme::Foo # test Acme::Foo, without installing it
112 cpanp> u Acme::Foo # uninstall Acme::Foo
113 cpanp> d Acme::Foo # download Acme::Foo
114 cpanp> z Acme::Foo # download & extract Acme::Foo, then open a
115 # shell in the extraction directory
117 cpanp> c Acme::Foo # get a list of test results for Acme::Foo
118 cpanp> l Acme::Foo # view details about the Acme::Foo package
119 cpanp> r Acme::Foo # view Acme::Foo's README file
120 cpanp> o # get a list of all installed modules that
122 cpanp> o 1..3 # list uptodateness from a previous search
124 cpanp> s conf # show config settings
125 cpanp> s conf md5 1 # enable md5 checks
126 cpanp> s program # show program settings
127 cpanp> s edit # edit config file
128 cpanp> s reconfigure # go through initial configuration again
129 cpanp> s selfupdate # update your CPANPLUS install
130 cpanp> s save # save config to disk
131 cpanp> s mirrors # show currently selected mirrors
133 cpanp> ! [PERL CODE] # execute the following perl code
135 cpanp> b # create an autobundle for this computers
137 cpanp> x # reload index files (purges cache)
138 cpanp> x --update_source # reload index files, get fresh source files
139 cpanp> p [FILE] # print error stack (to a file)
140 cpanp> v # show the banner
141 cpanp> w # show last search results again
143 cpanp> q # quit the shell
145 cpanp> /plugins # list avialable plugins
146 cpanp> /? PLUGIN # list help test of <PLUGIN>
149 cpanp> i ... --skiptest # skip tests
150 cpanp> i ... --force # force all operations
151 cpanp> i ... --verbose # run in verbose mode
155 This module provides the default user interface to C<CPANPLUS>. You
156 can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>.
163 my $cb = CPANPLUS::Backend->new( @_ );
164 my $self = $class->SUPER::_init(
166 term => Term::ReadLine->new( $Brand ),
169 format => "%4s %-55s %8s %-10s\n",
170 dist_format => "%4s %-42s %-12s %8s %-10s\n",
172 ### make it available package wide ###
175 my $rc_file = File::Spec->catfile(
176 $cb->configure_object->get_conf('base'),
177 DOT_SHELL_DEFAULT_RC,
181 if( -e $rc_file && -r _ ) {
182 $rc = $self->_read_configuration_from_rc( $rc_file );
185 ### register install callback ###
186 $cb->_register_callback(
187 name => 'install_prerequisite',
188 code => \&__ask_about_install,
191 ### execute any login commands specified ###
192 $self->dispatch_on_input( input => $rc->{'login'} )
193 if defined $rc->{'login'};
195 ### register test report callbacks ###
196 $cb->_register_callback(
197 name => 'edit_test_report',
198 code => \&__ask_about_edit_test_report,
201 $cb->_register_callback(
202 name => 'send_test_report',
203 code => \&__ask_about_send_test_report,
206 $cb->_register_callback(
207 name => 'proceed_on_test_failure',
208 code => \&__ask_about_test_failure,
211 ### load all the plugins
212 $self->_plugins_init;
219 my $term = $self->term;
220 my $conf = $self->backend->configure_object;
223 $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner?
224 $self->_show_random_tip if $conf->get_conf('show_startup_tip');
225 $self->_input_loop && $self->__print( "\n" );
231 my $term = $self->term;
232 my $cb = $self->backend;
236 defined (my $input = eval { $term->readline($self->prompt) } )
237 or $self->_signals->{INT}{count} == 1
239 ### re-initiate all signal handlers
240 while (my ($sig, $entry) = each %{$self->_signals} ) {
241 $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
244 $self->__print( "\n" );
245 last if $self->dispatch_on_input( input => $input );
247 ### flush the lib cache ###
248 $cb->_flush( list => [qw|lib load|] );
251 ### clear the sigint count
252 $self->_signals->{INT}{count}--
253 if $self->_signals->{INT}{count};
255 ### reset the 'install prereq?' cached answer
256 $self->settings->{'install_all_prereqs'} = undef;
263 ### return 1 to quit ###
264 sub dispatch_on_input {
266 my $conf = $self->backend->configure_object();
267 my $term = $self->term;
270 my($string, $noninteractive);
272 input => { required => 1, store => \$string },
273 noninteractive => { required => 0, store => \$noninteractive },
276 check( $tmpl, \%hash ) or return;
278 ### indicates whether or not the user will receive a shell
279 ### prompt after the command has finished.
280 $self->noninteractive($noninteractive) if defined $noninteractive;
284 my @cmds = split ';', $string;
285 while( my $input = shift @cmds ) {
287 ### to send over the socket ###
288 my $org_input = $input;
290 my $key; my $options;
291 { ### make whitespace not count when using special chars
292 { $input =~ s|^\s*([!?/])|$1 |; }
294 ### get the first letter of the input
295 $input =~ s|^\s*([\w\?\!/])\w*||;
300 ### we figured out what the command was...
301 ### if we have more input, that DOES NOT start with a white
302 ### space char, we misparsed.. like 'Test::Foo::Bar', which
303 ### would turn into 't', '::Foo::Bar'...
304 if( $input and $input !~ s/^\s+// ) {
305 $self->__print( loc("Could not understand command: %1\n".
306 "Possibly missing command before argument(s)?\n",
311 ### allow overrides from the config file ###
312 if( defined $rc->{$key} ) {
313 $input = $rc->{$key} . $input;
316 ### grab command line options like --no-force and --verbose ###
317 ($options,$input) = $term->parse_options($input)
325 return 1 if $key eq 'q';
327 my $method = $map->{$key};
329 ### dispatch meta locally at all times ###
331 ### keep track of failures
332 $rv *= length $self->$method(input => $input, options => $options);
336 ### flush unless we're trying to print the stack
337 CPANPLUS::Error->flush unless $key eq 'p';
339 ### connected over a socket? ###
340 if( $self->remote ) {
342 ### unsupported commands ###
344 ($key eq 's' and $input =~ /^\s*edit/)
346 $self->__print( "\n",
347 loc( "Command '%1' not supported over remote connection",
348 join ' ', $key, $input
352 my($status,$buff) = $self->__send_remote_command($org_input);
354 $self->__print( "\n", loc("Command failed!"), "\n\n" )
357 ### keep track of failures
358 $rv *= length $status;
360 $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount;
361 $self->__print( $buff );
365 ### or just a plain local shell? ###
368 unless( $self->can($method) ) {
369 $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n");
374 ### some methods don't need modules ###
376 @mods = $self->_select_modules($input)
377 unless grep {$key eq $_} qw[! m a v w x p s b / ? h];
379 ### keep track of failures
380 $rv *= defined eval { $self->$method(
391 ### outside the shell loop, we can return the actual return value;
392 return $rv if $self->noninteractive;
397 sub _select_modules {
399 my $input = shift or return;
400 my $cache = $self->cache;
401 my $cb = $self->backend;
403 ### expand .. in $input
404 $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b}
405 {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg;
407 $input = join(' ', 1 .. $#{$cache}) if $input eq '*';
408 $input =~ s/'/::/g; # perl 4 convention
411 for my $mod (split /\s+/, $input) {
413 ### it's a cache look up ###
414 if( $mod =~ /^\d+/ and $mod > 0 ) {
415 unless( scalar @$cache ) {
416 $self->__print( loc("No search was done yet!"), "\n" );
418 } elsif ( my $obj = $cache->[$mod] ) {
422 $self->__print( loc("No such module: %1", $mod), "\n" );
426 my $obj = $cb->parse_module( module => $mod );
429 $self->__print( loc("No such module: %1", $mod), "\n" );
437 unless( scalar @rv ) {
438 $self->__print( loc("No modules found to operate on!\n") );
445 sub _format_version {
447 my $version = shift || 0;
449 ### fudge $version into the 'optimal' format
450 $version = 0 if $version eq 'undef';
451 $version =~ s/_//g; # everything after gets stripped off otherwise
453 ### allow 6 digits after the dot, as that's how perl stringifies
455 $version = sprintf('%3.6f', $version);
456 $version = '' if $version == '0.00';
457 $version =~ s/(00{0,3})$/' ' x (length $1)/e;
462 sub __display_results {
464 my $cache = $self->cache;
470 $self->_pager_open if $#{$cache} >= $self->_term_rowcount;
474 next unless $mod; # first one is undef
475 # humans start counting at 1
477 ### for dists only -- we have checksum info
484 $self->_format_version( $mod->version ),
493 $self->_format_version( $mod->version ),
503 $self->__print( loc("No results to display"), "\n" );
513 $self->dispatch_on_input( input => $rc->{'logout'} )
514 if defined $rc->{'logout'};
516 $self->__print( loc("Exiting CPANPLUS shell"), "\n" );
521 ###########################
522 ### actual command subs ###
523 ###########################
526 ### print out the help message ###
527 ### perhaps, '?' should be a slightly different version ###
534 { local $Params::Check::ALLOW_UNKNOWN = 1;
537 input => { required => 0, store => \$input }
540 my $args = check( $tmpl, \%hash ) or return;
545 loc(' h | ? # display help' ),
547 loc(' v # version information' ),
549 loc(' a AUTHOR ... # search by author(s)' ),
550 loc(' m MODULE ... # search by module(s)' ),
551 loc(' f MODULE ... # list all releases of a module' ),
552 loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ),
553 loc(' w # display the result of your last search again' ),
554 loc('[Operations]' ),
555 loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ),
556 loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ),
557 loc(' i DIR | ... # install module(s), by path (ie ./Module-1.0)' ),
558 loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ),
559 loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ),
560 loc(' d MODULE | NUMBER ... # download module(s)' ),
561 loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ),
562 loc(' r MODULE | NUMBER ... # display README files of module(s)' ),
563 loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ),
564 loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ),
565 loc('[Local Administration]' ),
566 loc(' b # write a bundle file for your configuration' ),
567 loc(' s program [OPT VALUE] # set program locations for this session' ),
568 loc(' s conf [OPT VALUE] # set config options for this session' ),
569 loc(' s mirrors # show currently selected mirrors' ),
570 loc(' s reconfigure # reconfigure settings ' ),
571 loc(' s selfupdate # update your CPANPLUS install '),
572 loc(' s save [user|system] # save settings for this user or systemwide' ),
573 loc(' s edit [user|system] # open configuration file in editor and reload' ),
574 loc(' ! EXPR # evaluate a perl statement' ),
575 loc(' p [FILE] # print the error stack (optionally to a file)' ),
576 loc(' x # reload CPAN indices (purges cache)' ),
577 loc(' x --update_source # reload CPAN indices, get fresh source files' ),
578 loc('[Common Options]' ),
579 loc(' i ... --skiptest # skip tests' ),
580 loc(' i ... --force # force all operations' ),
581 loc(' i ... --verbose # run in verbose mode' ),
583 loc(' /plugins # list available plugins' ),
584 loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ),
588 $self->_pager_open if (@help >= $self->_term_rowcount);
589 ### XXX: functional placeholder for actual 'detailed' help.
590 $self->__print( "Detailed help for the command '$input' is " .
591 "not available.\n\n" ) if length $input;
592 $self->__print( map {"$_\n"} @help );
593 $self->__print( $/ );
600 ### eval some code ###
603 my $cb = $self->backend;
608 { local $Params::Check::ALLOW_UNKNOWN = 1;
611 input => { required => 1, store => \$input }
614 my $args = check( $tmpl, \%hash ) or return;
617 local $Data::Dumper::Indent = 1; # for dumpering from !
620 $self->__print( "\n" );
628 my $cb = $self->backend;
632 { local $Params::Check::ALLOW_UNKNOWN = 1;
635 input => { required => 1, },
636 options => { default => { } },
639 $args = check( $tmpl, \%hash ) or return;
642 my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
644 ### XXX this is rather slow, because (probably)
645 ### of the many method calls
646 ### XXX need to profile to speed it up =/
648 ### find the modules ###
649 my @rv = sort { $a->module cmp $b->module }
651 %{$args->{'options'}},
656 ### store the result in the cache ###
657 $self->cache([undef,@rv]);
659 $self->__display_results;
666 my $cb = $self->backend;
670 { local $Params::Check::ALLOW_UNKNOWN = 1;
673 input => { required => 1, },
674 options => { default => { } },
677 $args = check( $tmpl, \%hash ) or return;
680 my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
683 for my $type (qw[author cpanid]) {
684 push @rv, $cb->search(
685 %{$args->{'options'}},
692 my @list = sort { $a->module cmp $b->module }
695 grep { not $seen{$_}++ } @rv;
697 $self->cache([undef,@list]);
699 $self->__display_results;
705 my $cb = $self->backend;
708 my $args; my $mods; my $opts;
709 { local $Params::Check::ALLOW_UNKNOWN = 1;
712 modules => { required => 1, store => \$mods },
713 options => { default => { }, store => \$opts },
716 $args = check( $tmpl, \%hash ) or return;
719 return unless scalar @$mods;
722 for my $mod ( @$mods ) {
723 $self->__print( $mod->readme( %$opts ) );
733 my $cb = $self->backend;
736 my $args; my $mods; my $opts;
737 { local $Params::Check::ALLOW_UNKNOWN = 1;
740 modules => { required => 1, store => \$mods },
741 options => { default => { }, store => \$opts },
744 $args = check( $tmpl, \%hash ) or return;
747 $self->_pager_open if @$mods >= $self->_term_rowcount;
749 for my $mod (@$mods) {
750 my $where = $mod->fetch( %$opts );
752 $rv *= length $where;
756 ? loc("Successfully fetched '%1' to '%2'",
757 $mod->module, $where )
758 : loc("Failed to fetch '%1'", $mod->module)
760 $self->__print( "\n" );
770 my $cb = $self->backend;
771 my $conf = $cb->configure_object;
774 my $shell = $conf->get_program('shell');
777 loc("Your config does not specify a subshell!"), "\n",
778 loc("Perhaps you need to re-run your setup?"), "\n"
783 my $args; my $mods; my $opts;
784 { local $Params::Check::ALLOW_UNKNOWN = 1;
787 modules => { required => 1, store => \$mods },
788 options => { default => { }, store => \$opts },
791 $args = check( $tmpl, \%hash ) or return;
794 my $cwd = Cwd::cwd();
795 for my $mod (@$mods) {
796 $mod->fetch( %$opts ) or next;
797 $mod->extract( %$opts ) or next;
799 $cb->_chdir( dir => $mod->status->extract() ) or next;
801 #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
803 if( system($shell) and $! ) {
805 loc("Error executing your subshell '%1': %2",
811 $cb->_chdir( dir => $cwd );
818 my $cb = $self->backend;
819 my $conf = $cb->configure_object;
822 my $args; my $mods; my $opts;
823 { local $Params::Check::ALLOW_UNKNOWN = 1;
826 modules => { required => 1, store => \$mods },
827 options => { default => { }, store => \$opts },
830 $args = check( $tmpl, \%hash ) or return;
834 for my $mod (@$mods) {
835 push @list, sort { $a->version <=> $b->version }
836 grep { defined } $mod->distributions( %$opts );
839 my @rv = sort { $a->module cmp $b->module } @list;
841 $self->cache([undef,@rv]);
842 $self->__display_results;
847 sub _reload_indices {
849 my $cb = $self->backend;
853 { local $Params::Check::ALLOW_UNKNOWN = 1;
856 options => { default => { }, store => \$opts },
859 $args = check( $tmpl, \%hash ) or return;
862 my $rv = $cb->reload_indices( %$opts );
864 ### so the update failed, but you didnt give it any options either
865 if( !$rv and !(keys %$opts) ) {
867 "\nFailure may be due to corrupt source files\n" .
868 "Try this:\n\tx --update_source\n\n" );
877 my $cb = $self->backend;
878 my $conf = $cb->configure_object;
881 my $args; my $mods; my $opts; my $choice;
882 { local $Params::Check::ALLOW_UNKNOWN = 1;
885 modules => { required => 1, store => \$mods },
886 options => { default => { }, store => \$opts },
887 choice => { required => 1, store => \$choice,
888 allow => [qw|i t|] },
891 $args = check( $tmpl, \%hash ) or return;
894 unless( scalar @$mods ) {
895 $self->__print( loc("Nothing done\n") );
899 my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE;
900 my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing ');
901 my $action = $choice eq 'i' ? 'install' : 'test';
904 ### first loop over the mods to install them ###
905 for my $mod (@$mods) {
906 $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" );
908 my $log_length = length CPANPLUS::Error->stack_as_string;
910 ### store the status for look up when we're done with all
912 $status->{$mod} = $mod->install( %$opts, target => $target );
914 ### would you like a log file of what happened?
915 if( $conf->get_conf('write_install_logs') ) {
917 my $dir = File::Spec->catdir(
918 $conf->get_conf('base'),
919 $conf->_get_build('install_log_dir'),
921 ### create the dir if it doesn't exit yet
922 $cb->_mkdir( dir => $dir ) unless -d $dir;
924 my $file = File::Spec->catfile(
926 INSTALL_LOG_FILE->( $mod )
928 if ( open my $fh, ">$file" ) {
929 my $stack = CPANPLUS::Error->stack_as_string;
930 ### remove everything in the log that was there *before*
931 ### we started this install
932 substr( $stack, 0, $log_length, '' );
938 loc("*** Install log written to:\n %1\n\n", $file)
941 warn "Could not open '$file': $!\n";
948 ### then report whether all this went ok or not ###
949 for my $mod (@$mods) {
950 # if( $mod->status->installed ) {
951 if( $status->{$mod} ) {
953 loc("Module '%1' %tense(%2,past) successfully\n",
954 $mod->module, $action)
959 loc("Error %tense(%1,present) '%2'\n", $action, $mod->module)
968 loc("No errors %tense(%1,present) all modules", $action), "\n"
972 loc("Problem %tense(%1,present) one or more modules", $action)
974 $self->__print( "\n" );
977 loc("*** You can view the complete error buffer by pressing ".
979 ) unless $conf->get_conf('verbose') || $self->noninteractive;
981 $self->__print( "\n" );
986 sub __ask_about_install {
987 my $mod = shift or return;
988 my $prereq = shift or return;
989 my $term = $Shell->term;
991 $Shell->__print( "\n" );
992 $Shell->__print( loc("Module '%1' requires '%2' to be installed",
993 $mod->module, $prereq->module ) );
994 $Shell->__print( "\n\n" );
996 ### previously cached answer?
997 return $Shell->settings->{'install_all_prereqs'}
998 if defined $Shell->settings->{'install_all_prereqs'};
1002 loc( "If you don't wish to see this question anymore\n".
1003 "you can disable it by entering the following ".
1004 "commands on the prompt:\n '%1'",
1005 's conf prereqs 1; s save' ) );
1006 $Shell->__print("\n\n");
1008 my $yes = loc("Yes");
1010 my $all = loc("Yes to all (for this module)");
1011 my $none = loc("No to all (for this module)");
1013 my $reply = $term->get_reply(
1014 prompt => loc("Should I install this module?"),
1015 choices => [ $yes, $no, $all, $none ],
1019 ### if 'all' or 'none', save this, so we can apply it to
1020 ### other prereqs in this chain.
1021 $Shell->settings->{'install_all_prereqs'} =
1022 $reply eq $all ? 1 :
1023 $reply eq $none ? 0 :
1026 ### if 'yes' or 'all', the user wants it installed
1027 return $reply eq $all ? 1 :
1028 $reply eq $yes ? 1 :
1032 sub __ask_about_send_test_report {
1033 my($mod, $grade) = @_;
1034 return 1 unless $grade eq GRADE_FAIL;
1036 my $term = $Shell->term;
1038 $Shell->__print( "\n" );
1040 loc("Test report prepared for module '%1'.\n Would you like to ".
1041 "send it? (You can edit it if you like)", $mod->module ) );
1042 $Shell->__print( "\n\n" );
1043 my $bool = $term->ask_yn(
1044 prompt => loc("Would you like to send the test report?"),
1051 sub __ask_about_edit_test_report {
1052 my($mod, $grade) = @_;
1053 return 0 unless $grade eq GRADE_FAIL;
1055 my $term = $Shell->term;
1057 $Shell->__print( "\n" );
1059 loc("Test report prepared for module '%1'. You can edit this ".
1060 "report if you would like", $mod->module ) );
1061 $Shell->__print("\n\n");
1062 my $bool = $term->ask_yn(
1063 prompt => loc("Would you like to edit the test report?"),
1070 sub __ask_about_test_failure {
1072 my $captured = shift || '';
1073 my $term = $Shell->term;
1075 $Shell->__print( "\n" );
1077 loc( "The tests for '%1' failed. Would you like me to proceed ".
1078 "anyway or should we abort?", $mod->module ) );
1079 $Shell->__print( "\n\n" );
1081 my $bool = $term->ask_yn(
1082 prompt => loc("Proceed anyway?"),
1092 my $cb = $self->backend;
1093 my $conf = $cb->configure_object;
1096 my $args; my $mods; my $opts;
1097 { local $Params::Check::ALLOW_UNKNOWN = 1;
1100 modules => { required => 1, store => \$mods },
1101 options => { default => { }, store => \$opts },
1104 $args = check( $tmpl, \%hash ) or return;
1107 ### every module has about 10 lines of details
1108 ### maybe more later with Module::CPANTS etc
1109 $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount;
1112 my $format = "%-24s %-45s\n";
1113 my $cformat = "%-24s %-45s %-10s\n";
1114 for my $mod (@$mods) {
1115 my $href = $mod->details( %$opts );
1116 my @list = sort { $a->module cmp $b->module } $mod->contains;
1120 loc("No details for %1 - it might be outdated.",
1121 $mod->module), "\n" );
1125 $self->__print( loc( "Details for '%1'\n", $mod->module ) );
1126 for my $item ( sort keys %$href ) {
1127 $self->__printf( $format, $item, $href->{$item} );
1131 for my $item ( @list ) {
1133 $cformat, ($showed ? '' : 'Contains:'),
1134 $item->module, $item->version
1138 $self->__print( "\n" );
1141 $self->_pager_close;
1142 $self->__print( "\n" );
1151 my $args; my $opts; my $file;
1152 { local $Params::Check::ALLOW_UNKNOWN = 1;
1155 options => { default => { }, store => \$opts },
1156 input => { default => '', store => \$file },
1159 $args = check( $tmpl, \%hash ) or return;
1164 $fh = FileHandle->new( ">$file" )
1165 or( warn loc("Could not open '%1': '%2'", $file, $!),
1172 $self->_pager_open if !$file;
1174 $self->__print( CPANPLUS::Error->stack_as_string );
1176 $self->_pager_close;
1178 select $old if $old;
1179 $self->__print( "\n" );
1187 my $cb = $self->backend;
1188 my $conf = $cb->configure_object;
1190 ### possible options
1191 ### XXX hard coded, not optimal :(
1194 save => q([user | system | boxed]),
1196 program => q([key => val]),
1197 conf => q([key => val]),
1199 selfupdate => '', # XXX add all opts here?
1203 my $args; my $opts; my $input;
1204 { local $Params::Check::ALLOW_UNKNOWN = 1;
1207 options => { default => { }, store => \$opts },
1208 input => { default => '', store => \$input },
1211 $args = check( $tmpl, \%hash ) or return;
1214 my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)\s*$/;
1217 if( $type eq 'reconfigure' ) {
1218 my $setup = CPANPLUS::Configure::Setup->new(
1219 configure_object => $conf,
1220 term => $self->term,
1223 return $setup->init;
1225 } elsif ( $type eq 'save' ) {
1227 user => CONFIG_USER,
1228 system => CONFIG_SYSTEM,
1229 boxed => CONFIG_BOXED,
1230 }->{ $key } || CONFIG_USER;
1232 ### boxed is special, so let's get its value from %INC
1233 ### so we can tell it where to save
1234 ### XXX perhaps this logic should be generic for all
1235 ### types, and put in the ->save() routine
1237 if( $where eq CONFIG_BOXED ) {
1238 my $file = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm';
1239 my $file_re = quotemeta($file);
1241 my $path = $INC{$file} || '';
1242 $path =~ s/$file_re$//;
1246 my $rv = $cb->configure_object->save( $where => $dir );
1250 ? loc("Configuration successfully saved to %1\n (%2)\n",
1252 : loc("Failed to save configuration\n" )
1256 } elsif ( $type eq 'edit' ) {
1258 my $editor = $conf->get_program('editor')
1259 or( print(loc("No editor specified")), return );
1262 user => CONFIG_USER,
1263 system => CONFIG_SYSTEM,
1264 }->{ $key } || CONFIG_USER;
1266 my $file = $conf->_config_pm_to_file( $where );
1267 system("$editor $file");
1270 ### disable warnings for this
1271 { require Module::Loaded;
1272 Module::Loaded::mark_as_unloaded( $where );
1274 ### reinitialize the config
1281 } elsif ( $type eq 'mirrors' ) {
1284 loc("Readonly list of mirrors (in order of preference):\n\n" ) );
1287 for my $host ( @{$conf->get_conf('hosts')} ) {
1288 my $uri = $cb->_host_to_uri( %$host );
1291 $self->__print( "\t[$i] $uri\n" );
1295 loc("\nTo edit this list, please type: '%1'\n", 's edit') );
1297 } elsif ( $type eq 'selfupdate' ) {
1298 my %valid = map { $_ => $_ }
1299 $cb->selfupdate_object->list_categories;
1301 unless( $valid{$key} ) {
1303 loc( "To update your current CPANPLUS installation, ".
1304 "choose one of the these options:\n%1",
1306 sprintf "\ts selfupdate %-17s " .
1307 "[--latest=0] [--dryrun]", $_
1308 } sort keys %valid )
1319 my %list = $cb->selfupdate_object
1320 ->list_modules_to_update( %update_args );
1322 $self->__print(loc("The following updates will take place:"),$/.$/);
1324 for my $feature ( sort keys %list ) {
1325 my $aref = $list{$feature};
1327 ### is it a 'feature' or a built in?
1330 ? " " . ucfirst($feature) . ":\n"
1331 : " Modules for '$feature' support:\n"
1334 ### show what modules would be installed
1337 ? map { sprintf " %-42s %-6s -> %-6s \n",
1338 $_->name, $_->installed_version, $_->version
1340 : " No upgrades required\n"
1342 $self->__print( $/ );
1346 unless( $opts->{'dryrun'} ) {
1347 $self->__print( loc("Updating your CPANPLUS installation\n") );
1348 $cb->selfupdate_object->selfupdate( %update_args );
1354 if ( $type eq 'program' or $type eq 'conf' ) {
1358 program => '%-12s %s',
1362 my @list = grep { $_ ne 'hosts' }
1363 $conf->options( type => $type );
1365 my $method = 'get_' . $type;
1367 local $Data::Dumper::Indent = 0;
1368 for my $name ( @list ) {
1369 my $val = $conf->$method($name) || '';
1371 ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
1374 $self->__printf( " $format\n", $name, $val );
1377 } elsif ( $key eq 'hosts' or $key eq 'lib' ) {
1379 loc( "Setting %1 is not trivial.\n" .
1380 "It is suggested you use '%2' and edit the " .
1381 "configuration file manually", $key, 's edit')
1384 my $method = 'set_' . $type;
1385 $conf->$method( $key => defined $value ? $value : '' )
1386 and $self->__print( loc("Key '%1' was set to '%2'", $key,
1387 defined $value ? $value : 'EMPTY STRING') );
1391 $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) );
1392 $self->__print( $/ );
1393 $self->__print( loc("Try one of the following:") );
1394 $self->__print( $/, join $/,
1395 map { sprintf "\t%-11s %s", $_, $types{$_} }
1399 $self->__print( "\n" );
1406 my $cb = $self->backend;
1407 my $conf = $cb->configure_object;
1410 { local $Params::Check::ALLOW_UNKNOWN = 1;
1413 options => { default => { }, store => \$opts },
1414 modules => { required => 1, store => \$mods },
1417 check( $tmpl, \%hash ) or return;
1420 ### long listing? short is default ###
1421 my $long = $opts->{'long'} ? 1 : 0;
1423 my @list = scalar @$mods ? @$mods : @{$cb->_all_installed};
1426 for my $mod (@list) {
1427 ### skip this mod if it's up to date ###
1428 next if $mod->is_uptodate;
1429 ### skip this mod if it's core ###
1430 next if $mod->package_is_perl_core;
1432 if( $long or !$seen{$mod->package}++ ) {
1437 @rv = sort { $a->module cmp $b->module } @rv;
1439 $self->cache([undef,@rv]);
1441 $self->_pager_open if scalar @rv >= $self->_term_rowcount;
1443 my $format = "%5s %12s %12s %-36s %-10s\n";
1446 for my $mod ( @rv ) {
1450 $self->_format_version($mod->installed_version) || 'Unparsable',
1451 $self->_format_version( $mod->version ),
1453 $mod->author->cpanid
1457 $self->_pager_close;
1465 my $cb = $self->backend;
1466 my $conf = $cb->configure_object;
1468 my $opts; my $input;
1469 { local $Params::Check::ALLOW_UNKNOWN = 1;
1472 options => { default => { }, store => \$opts },
1473 input => { default => '', store => \$input },
1476 check( $tmpl, \%hash ) or return;
1479 $opts->{'path'} = $input if $input;
1481 my $where = $cb->autobundle( %$opts );
1485 ? loc("Wrote autobundle to '%1'", $where)
1486 : loc("Could not create autobundle" )
1488 $self->__print( "\n" );
1490 return $where ? 1 : 0;
1496 my $cb = $self->backend;
1497 my $term = $self->term;
1498 my $conf = $cb->configure_object;
1501 { local $Params::Check::ALLOW_UNKNOWN = 1;
1504 options => { default => { }, store => \$opts },
1505 modules => { default => [], store => \$mods },
1508 check( $tmpl, \%hash ) or return;
1511 my $force = $opts->{'force'} || $conf->get_conf('force');
1514 my $list = join "\n", map { ' ' . $_->module } @$mods;
1516 $self->__print( loc("
1517 This will uninstall the following modules:
1520 Note that if you installed them via a package manager, you probably
1521 should use the same package manager to uninstall them
1525 return unless $term->ask_yn(
1526 prompt => loc("Are you sure you want to continue?"),
1531 ### first loop over all the modules to uninstall them ###
1532 for my $mod (@$mods) {
1533 $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" );
1535 $mod->uninstall( %$opts );
1539 ### then report whether all this went ok or not ###
1540 for my $mod (@$mods) {
1541 if( $mod->status->uninstall ) {
1543 loc("Module '%1' %tense(uninstall,past) successfully\n",
1548 loc("Error %tense(uninstall,present) '%1'\n", $mod->module) );
1554 loc("All modules %tense(uninstall,past) successfully"), "\n" );
1557 loc("Problem %tense(uninstalling,present) one or more modules" ),
1561 loc("*** You can view the complete error buffer by pressing '%1'".
1562 "***\n", 'p') ) unless $conf->get_conf('verbose');
1564 $self->__print( "\n" );
1572 my $cb = $self->backend;
1573 my $term = $self->term;
1574 my $conf = $cb->configure_object;
1577 { local $Params::Check::ALLOW_UNKNOWN = 1;
1580 options => { default => { }, store => \$opts },
1581 modules => { default => '', store => \$mods },
1584 check( $tmpl, \%hash ) or return;
1587 ### XXX might need to be conditional ###
1590 for my $mod (@$mods) {
1591 my @list = $mod->fetch_report( %$opts )
1592 or( print(loc("No reports available for this distribution.")),
1598 sort { $a->[1] cmp $b->[1] }
1599 map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list;
1603 ### XXX this may need to be sorted better somehow ###
1605 my $format = "%8s %s %s\n";
1608 for my $href (@list ) {
1610 "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n"
1611 ) unless $seen{ $href->{'dist'} }++;
1616 $href->{'platform'},
1617 ($href->{'details'} ? '(*)' : '')
1620 $url ||= $href->{'details'};
1623 $self->__print( "\n==> $url\n" ) if $url;
1624 $self->__print( "\n" );
1626 $self->_pager_close;
1632 { my @PluginModules;
1634 showtip => [ __PACKAGE__, '_show_random_tip'],
1635 plugins => [ __PACKAGE__, '_list_plugins' ],
1636 '?' => [ __PACKAGE__, '_plugins_usage' ],
1639 sub plugin_modules { return @PluginModules }
1640 sub plugin_table { return %Dispatch }
1645 ### only initialize once
1646 return if $init_done++;
1648 ### find all plugins first
1649 if( check_install( module => 'Module::Pluggable', version => '2.4') ) {
1650 require Module::Pluggable;
1652 my $only_re = __PACKAGE__ . '::Plugins::\w+$';
1654 Module::Pluggable->import(
1655 sub_name => '_plugins',
1656 search_path => __PACKAGE__,
1657 only => qr/$only_re/,
1658 #except => [ INSTALLER_MM, INSTALLER_SAMPLE ]
1661 push @PluginModules, __PACKAGE__->_plugins;
1664 ### now try to load them
1665 for my $p ( __PACKAGE__->plugin_modules ) {
1666 my %map = eval { load $p; $p->import; $p->plugins };
1667 error(loc("Could not load plugin '$p': $@")), next if $@;
1669 ### register each plugin
1670 while( my($name, $func) = each %map ) {
1672 if( not length $name or not length $func ) {
1673 error(loc("Empty plugin name or dispatch function detected"));
1677 if( exists( $Dispatch{$name} ) ) {
1678 error(loc("'%1' is already registered by '%2'",
1679 $name, $Dispatch{$name}->[0]));
1683 ### register name, package and function
1684 $Dispatch{$name} = [ $p, $func ];
1689 ### dispatch a plugin command to its function
1693 my $cb = $self->backend;
1694 my $term = $self->term;
1695 my $conf = $cb->configure_object;
1697 my $opts; my $input;
1698 { local $Params::Check::ALLOW_UNKNOWN = 1;
1701 options => { default => { }, store => \$opts },
1702 input => { default => '', store => \$input },
1705 check( $tmpl, \%hash ) or return;
1708 $input =~ s/\s*(\S+)\s*//;
1711 ### look up the command, or go to the default
1712 my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ];
1714 my($pkg,$func) = @$aref;
1716 my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) };
1720 ### return $rv instead, so input loop can be terminated?
1724 sub _plugin_default { error(loc("No such plugin command")) }
1728 { my $help_format = " /%-21s # %s\n";
1733 $self->__print( loc("Available plugins:\n") );
1734 $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) );
1735 $self->__print( $/ );
1737 my %table = __PACKAGE__->plugin_table;
1738 for my $name( sort keys %table ) {
1739 my $pkg = $table{$name}->[0];
1740 my $this = __PACKAGE__;
1742 my $who = $pkg eq $this
1744 : do { my $v = $self->_format_version($pkg->VERSION) || '';
1745 $pkg =~ s/^$this/../;
1746 sprintf "Provided by: %-30s %-10s", $pkg, $v;
1749 $self->__printf( $help_format, $name, $who );
1752 $self->__print( $/.$/ );
1755 " Write your own plugins? Read the documentation of:\n" .
1756 " CPANPLUS::Shell::Default::Plugins::HOWTO\n" );
1758 $self->__print( $/ );
1761 sub _list_plugins_help {
1762 return sprintf $help_format, 'plugins', loc("lists available plugins");
1765 ### registered as a plugin too
1766 sub _show_random_tip_help {
1767 return sprintf $help_format, 'showtip', loc("show usage tips" );
1770 sub _plugins_usage {
1776 my %table = $self->plugin_table;
1778 my @list = length $input ? split /\s+/, $input : sort keys %table;
1780 for my $name( @list ) {
1782 ### no such plugin? skip
1783 error(loc("No such plugin '$name'")), next unless $table{$name};
1785 my $pkg = $table{$name}->[0];
1786 my $func = $table{$name}->[1] . '_help';
1788 if ( my $sub = $pkg->can( $func ) ) {
1789 eval { $self->__print( $sub->() ) };
1793 $self->__print(" No usage for '$name' -- try perldoc $pkg");
1796 $self->__print( $/ );
1799 $self->__print( $/.$/ );
1802 sub _plugins_usage_help {
1803 return sprintf $help_format, '? [NAME ...]',
1804 loc("show usage for plugins");
1808 ### send a command to a remote host, retrieve the answer;
1809 sub __send_remote_command {
1812 my $remote = $self->remote or return;
1813 my $user = $remote->{'username'};
1814 my $pass = $remote->{'password'};
1815 my $conn = $remote->{'connection'};
1816 my $end = "\015\012";
1819 my $send = join "\0", $user, $pass, $cmd;
1821 print $conn $send . $end;
1823 ### XXX why doesn't something like this just work?
1824 #1 while recv($conn, $answer, 1024, 0);
1827 $conn->recv( $buff, 1024, 0 );
1829 last if $buff =~ /$end$/;
1832 my($status,$buffer) = split "\0", $answer;
1834 return ($status, $buffer);
1838 sub _read_configuration_from_rc {
1840 my $rc_file = shift;
1843 if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) {
1844 $Config::Auto::DisablePerl = 1;
1846 eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) };
1849 loc( "Unable to read in config file '%1': %2", $rc_file, $@ )
1857 loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ),
1858 loc( "You can install modules by URL using '%1'", 'i URL' ),
1859 loc( "You can turn off these tips using '%1'",
1860 's conf show_startup_tip 0' ),
1861 loc( "You can use wildcards like '%1' and '%2' on search results",
1863 loc( "You can use plugins. Type '%1' to list available plugins",
1865 loc( "You can show all your out of date modules using '%1'", 'o' ),
1866 loc( "Many operations take options, like '%1', '%2' or '%3'",
1867 '--verbose', '--force', '--skiptest' ),
1868 loc( "The documentation in %1 and %2 is very useful",
1869 "CPANPLUS::Module", "CPANPLUS::Backend" ),
1870 loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ),
1871 loc( "You can run an interactive setup using '%1'", 's reconfigure' ),
1872 loc( "You can add custom sources to your index. See '%1' for details",
1874 loc( "CPANPLUS now has an experimental SQLite backend. You can enable ".
1875 "it via: '%1'. Update dependencies via '%2'",
1876 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save',
1877 's selfupdate enabled_features ' ),
1880 sub _show_random_tip {
1882 $self->__print( $/, "Did you know...\n ",
1883 $tips[ int rand scalar @tips ], $/ );
1896 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1900 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1904 The CPAN++ interface (of which this module is a part of) is copyright (c)
1905 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1907 This library is free software; you may redistribute and/or modify it
1908 under the same terms as Perl itself.
1912 L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp>
1917 # c-indentation-style: bsd
1919 # indent-tabs-mode: nil
1921 # vim: expandtab shiftwidth=4:
1926 e => "_expand_inc", # scratch it, imho -- not used enough
1928 ### free letters: g j k n y ###