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