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