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