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