| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package CPANPLUS::Shell::Default; 2 3 use strict; 4 5 6 use CPANPLUS::Error; 7 use CPANPLUS::Backend; 8 use CPANPLUS::Configure::Setup; 9 use CPANPLUS::Internals::Constants; 10 use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL]; 11 12 use Cwd; 13 use IPC::Cmd; 14 use Term::UI; 15 use Data::Dumper; 16 use Term::ReadLine; 17 18 use Module::Load qw[load]; 19 use Params::Check qw[check]; 20 use Module::Load::Conditional qw[can_load check_install]; 21 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; 22 23 local $Params::Check::VERBOSE = 1; 24 local $Data::Dumper::Indent = 1; # for dumpering from ! 25 26 BEGIN { 27 use vars qw[ $VERSION @ISA ]; 28 @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; 29 $VERSION = "0.84"; 30 } 31 32 load CPANPLUS::Shell; 33 34 35 my $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 65 my $rc = {}; 66 67 ### the shell object, scoped to the file ### 68 my $Shell; 69 my $Brand = loc('CPAN Terminal'); 70 my $Prompt = $Brand . '> '; 71 72 =pod 73 74 =head1 NAME 75 76 CPANPLUS::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 154 This module provides the default user interface to C<CPANPLUS>. You 155 can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>. 156 157 =cut 158 159 sub new { 160 my $class = shift; 161 162 my $cb = CPANPLUS::Backend->new( @_ ); 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 = $self->_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 $cb->_register_callback( 206 name => 'proceed_on_test_failure', 207 code => \&__ask_about_test_failure, 208 ); 209 210 ### load all the plugins 211 $self->_plugins_init; 212 213 return $self; 214 } 215 216 sub shell { 217 my $self = shift; 218 my $term = $self->term; 219 my $conf = $self->backend->configure_object; 220 221 $self->_show_banner; 222 $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner? 223 $self->_show_random_tip if $conf->get_conf('show_startup_tip'); 224 $self->_input_loop && $self->__print( "\n" ); 225 $self->_quit; 226 } 227 228 sub _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 243 $self->__print( "\n" ); 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 ### 258 sub 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+// ) { 297 $self->__print( loc("Could not understand command: %1\n". 298 "Possibly missing command before argument(s)?\n", 299 $org_input) ); 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 ) { 335 $self->__print( "\n", 336 loc( "Command '%1' not supported over remote connection", 337 join ' ', $key, $input 338 ), "\n\n" ); 339 340 } else { 341 my($status,$buff) = $self->__send_remote_command($org_input); 342 343 $self->__print( "\n", loc("Command failed!"), "\n\n" ) 344 unless $status; 345 346 $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount; 347 $self->__print( $buff ); 348 $self->_pager_close; 349 } 350 351 ### or just a plain local shell? ### 352 } else { 353 354 unless( $self->can($method) ) { 355 $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n"); 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 378 sub _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 ) { 397 $self->__print( loc("No search was done yet!"), "\n" ); 398 399 } elsif ( my $obj = $cache->[$mod] ) { 400 push @rv, $obj; 401 402 } else { 403 $self->__print( loc("No such module: %1", $mod), "\n" ); 404 } 405 406 } else { 407 my $obj = $cb->parse_module( module => $mod ); 408 409 unless( $obj ) { 410 $self->__print( loc("No such module: %1", $mod), "\n" ); 411 412 } else { 413 push @rv, $obj; 414 } 415 } 416 } 417 418 unless( scalar @rv ) { 419 $self->__print( loc("No modules found to operate on!\n") ); 420 return; 421 } else { 422 return @rv; 423 } 424 } 425 426 sub _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 443 sub __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 ) { 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 ); 468 469 } else { 470 $self->__printf( 471 $self->format, 472 $i, 473 $mod->module, 474 $self->_format_version( $mod->version ), 475 $mod->author->cpanid 476 ); 477 } 478 $i++; 479 } 480 481 $self->_pager_close; 482 483 } else { 484 $self->__print( loc("No results to display"), "\n" ); 485 } 486 } 487 488 489 sub _quit { 490 my $self = shift; 491 492 $self->dispatch_on_input( input => $rc->{'logout'} ) 493 if defined $rc->{'logout'}; 494 495 $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); 496 } 497 498 ########################### 499 ### actual command subs ### 500 ########################### 501 502 503 ### print out the help message ### 504 ### perhaps, '?' should be a slightly different version ### 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 = ( 521 loc('[General]' ), 522 loc(' h | ? # display help' ), 523 loc(' q # exit' ), 524 loc(' v # version information' ), 525 loc('[Search]' ), 526 loc(' a AUTHOR ... # search by author(s)' ), 527 loc(' m MODULE ... # search by module(s)' ), 528 loc(' f MODULE ... # list all releases of a module' ), 529 loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ), 530 loc(' w # display the result of your last search again' ), 531 loc('[Operations]' ), 532 loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ), 533 loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ), 534 loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ), 535 loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ), 536 loc(' d MODULE | NUMBER ... # download module(s)' ), 537 loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ), 538 loc(' r MODULE | NUMBER ... # display README files of module(s)' ), 539 loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ), 540 loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ), 541 loc('[Local Administration]' ), 542 loc(' b # write a bundle file for your configuration' ), 543 loc(' s program [OPT VALUE] # set program locations for this session' ), 544 loc(' s conf [OPT VALUE] # set config options for this session' ), 545 loc(' s mirrors # show currently selected mirrors' ), 546 loc(' s reconfigure # reconfigure settings ' ), 547 loc(' s selfupdate # update your CPANPLUS install '), 548 loc(' s save [user|system] # save settings for this user or systemwide' ), 549 loc(' s edit [user|system] # open configuration file in editor and reload' ), 550 loc(' ! EXPR # evaluate a perl statement' ), 551 loc(' p [FILE] # print the error stack (optionally to a file)' ), 552 loc(' x # reload CPAN indices (purges cache)' ), 553 loc(' x --update_source # reload CPAN indices, get fresh source files' ), 554 loc('[Common Options]' ), 555 loc(' i ... --skiptest # skip tests' ), 556 loc(' i ... --force # force all operations' ), 557 loc(' i ... --verbose # run in verbose mode' ), 558 loc('[Plugins]' ), 559 loc(' /plugins # list available plugins' ), 560 loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ), 561 562 ) unless @help; 563 564 $self->_pager_open if (@help >= $self->_term_rowcount); 565 ### XXX: functional placeholder for actual 'detailed' help. 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( $/ ); 570 $self->_pager_close; 571 } 572 } 573 574 ### eval some code ### 575 sub _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 $@; 594 $self->__print( "\n" ); 595 return; 596 } 597 598 sub _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 636 sub _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 675 sub _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 ) { 695 $self->__print( $mod->readme( %$opts ) ); 696 } 697 698 $self->_pager_close; 699 700 return 1; 701 } 702 703 sub _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 723 $self->__print( 724 $where 725 ? loc("Successfully fetched '%1' to '%2'", 726 $mod->module, $where ) 727 : loc("Failed to fetch '%1'", $mod->module) 728 ); 729 $self->__print( "\n" ); 730 } 731 $self->_pager_close; 732 733 } 734 735 sub _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 ) { 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 ); 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 $! ) { 771 $self->__print( 772 loc("Error executing your subshell '%1': %2", 773 $shell, $!),"\n" 774 ); 775 next; 776 } 777 } 778 $cb->_chdir( dir => $cwd ); 779 780 return 1; 781 } 782 783 sub _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 814 sub _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) ) { 833 $self->__print( 834 "\nFailure may be due to corrupt source files\n" . 835 "Try this:\n\tx --update_source\n\n" ); 836 } 837 838 return $rv; 839 840 } 841 842 sub _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 ) { 862 $self->__print( loc("Nothing done\n") ); 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) { 873 $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" ); 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 904 $self->__print( 905 loc("*** Install log written to:\n %1\n\n", $file) 906 ); 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} ) { 919 $self->__print( 920 loc("Module '%1' %tense(%2,past) successfully\n", 921 $mod->module, $action) 922 ); 923 } else { 924 $flag++; 925 $self->__print( 926 loc("Error %tense(%1,present) '%2'\n", $action, $mod->module) 927 ); 928 } 929 } 930 931 932 933 if( !$flag ) { 934 $self->__print( 935 loc("No errors %tense(%1,present) all modules", $action), "\n" 936 ); 937 } else { 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; 947 } 948 $self->__print( "\n" ); 949 950 return !$flag; 951 } 952 953 sub __ask_about_install { 954 my $mod = shift or return; 955 my $prereq = shift or return; 956 my $term = $Shell->term; 957 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". 964 "you can disable it by entering the following ". 965 "commands on the prompt:\n '%1'", 966 's conf prereqs 1; s save' ) ); 967 $Shell->__print("\n\n"); 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 977 sub __ask_about_send_test_report { 978 my($mod, $grade) = @_; 979 return 1 unless $grade eq GRADE_FAIL; 980 981 my $term = $Shell->term; 982 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" ); 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 996 sub __ask_about_edit_test_report { 997 my($mod, $grade) = @_; 998 return 0 unless $grade eq GRADE_FAIL; 999 1000 my $term = $Shell->term; 1001 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"); 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 1015 sub __ask_about_test_failure { 1016 my $mod = shift; 1017 my $captured = shift || ''; 1018 my $term = $Shell->term; 1019 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" ); 1025 1026 my $bool = $term->ask_yn( 1027 prompt => loc("Proceed anyway?"), 1028 default => 'n', 1029 ); 1030 1031 return $bool; 1032 } 1033 1034 1035 sub _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 ) { 1063 $self->__print( 1064 loc("No details for %1 - it might be outdated.", 1065 $mod->module), "\n" ); 1066 next; 1067 1068 } else { 1069 $self->__print( loc( "Details for '%1'\n", $mod->module ) ); 1070 for my $item ( sort keys %$href ) { 1071 $self->__printf( $format, $item, $href->{$item} ); 1072 } 1073 1074 my $showed; 1075 for my $item ( @list ) { 1076 $self->__printf( 1077 $format, ($showed ? '' : 'Contains:'), $item->module 1078 ); 1079 $showed++; 1080 } 1081 $self->__print( "\n" ); 1082 } 1083 } 1084 $self->_pager_close; 1085 $self->__print( "\n" ); 1086 1087 return 1; 1088 } 1089 1090 sub _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 1117 $self->__print( CPANPLUS::Error->stack_as_string ); 1118 1119 $self->_pager_close; 1120 1121 select $old if $old; 1122 $self->__print( "\n" ); 1123 1124 return 1; 1125 } 1126 1127 sub _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 :( 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 ); 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, 1172 boxed => CONFIG_BOXED, 1173 }->{ $key } || CONFIG_USER; 1174 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 ); 1190 1191 $self->__print( 1192 $rv 1193 ? loc("Configuration successfully saved to %1\n (%2)\n", 1194 $where, $rv) 1195 : loc("Failed to save configuration\n" ) 1196 ); 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 1226 $self->__print( 1227 loc("Readonly list of mirrors (in order of preference):\n\n" ) ); 1228 1229 my $i; 1230 for my $host ( @{$conf->get_conf('hosts')} ) { 1231 my $uri = $cb->_host_to_uri( %$host ); 1232 1233 $i++; 1234 $self->__print( "\t[$i] $uri\n" ); 1235 } 1236 1237 } elsif ( $type eq 'selfupdate' ) { 1238 my %valid = map { $_ => $_ } 1239 $cb->selfupdate_object->list_categories; 1240 1241 unless( $valid{$key} ) { 1242 $self->__print( 1243 loc( "To update your current CPANPLUS installation, ". 1244 "choose one of the these options:\n%1", 1245 ( join $/, map { 1246 sprintf "\ts selfupdate %-17s " . 1247 "[--latest=0] [--dryrun]", $_ 1248 } sort keys %valid ) 1249 ) 1250 ); 1251 } else { 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 1262 $self->__print(loc("The following updates will take place:"),$/.$/); 1263 1264 for my $feature ( sort keys %list ) { 1265 my $aref = $list{$feature}; 1266 1267 ### is it a 'feature' or a built in? 1268 $self->__print( 1269 $valid{$feature} 1270 ? " " . ucfirst($feature) . ":\n" 1271 : " Modules for '$feature' support:\n" 1272 ); 1273 1274 ### show what modules would be installed 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( $/ ); 1283 } 1284 1285 1286 unless( $opts->{'dryrun'} ) { 1287 $self->__print( loc("Updating your CPANPLUS installation\n") ); 1288 $cb->selfupdate_object->selfupdate( %update_args ); 1289 } 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'"; 1313 1314 $self->__printf( " $format\n", $name, $val ); 1315 } 1316 1317 } elsif ( $key eq 'hosts' ) { 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 ); 1323 } else { 1324 my $method = 'set_' . $type; 1325 $conf->$method( $key => defined $value ? $value : '' ) 1326 and $self->__print( loc("Key '%1' was set to '%2'", $key, 1327 defined $value ? $value : 'EMPTY STRING') ); 1328 } 1329 1330 } else { 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 $/, 1335 map { sprintf "\t%-11s %s", $_, $types{$_} } 1336 sort keys %types ); 1337 } 1338 } 1339 $self->__print( "\n" ); 1340 return 1; 1341 } 1342 1343 sub _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 ) { 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 ); 1395 $i++; 1396 } 1397 $self->_pager_close; 1398 1399 return 1; 1400 } 1401 1402 sub _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 1423 $self->__print( 1424 $where 1425 ? loc("Wrote autobundle to '%1'", $where) 1426 : loc("Could not create autobundle" ) 1427 ); 1428 $self->__print( "\n" ); 1429 1430 return $where ? 1 : 0; 1431 } 1432 1433 sub _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 1456 $self->__print( loc(" 1457 This will uninstall the following modules: 1458 %1 1459 1460 Note that if you installed them via a package manager, you probably 1461 should use the same package manager to uninstall them 1462 1463 ", $list) ); 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) { 1473 $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" ); 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 ) { 1482 $self->__print( 1483 loc("Module '%1' %tense(uninstall,past) successfully\n", 1484 $mod->module ) ); 1485 } else { 1486 $flag++; 1487 $self->__print( 1488 loc("Error %tense(uninstall,present) '%1'\n", $mod->module) ); 1489 } 1490 } 1491 1492 if( !$flag ) { 1493 $self->__print( 1494 loc("All modules %tense(uninstall,past) successfully"), "\n" ); 1495 } else { 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'); 1503 } 1504 $self->__print( "\n" ); 1505 1506 return !$flag; 1507 } 1508 1509 sub _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 ) { 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 ); 1559 1560 $url ||= $href->{'details'}; 1561 } 1562 1563 $self->__print( "\n==> $url\n" ) if $url; 1564 $self->__print( "\n" ); 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 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; 1591 1592 my $only_re = __PACKAGE__ . '::Plugins::\w+$'; 1593 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 } 1626 } 1627 } 1628 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 1668 { my $help_format = " /%-21s # %s\n"; 1669 1670 sub _list_plugins { 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( $/ ); 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 1686 $self->__printf( $help_format, $name, $who ); 1687 } 1688 1689 $self->__print( $/.$/ ); 1690 1691 $self->__print( 1692 " Write your own plugins? Read the documentation of:\n" . 1693 " CPANPLUS::Shell::Default::Plugins::HOWTO\n" ); 1694 1695 $self->__print( $/ ); 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 { 1708 my $self = shift; 1709 my $shell = shift; 1710 my $cb = shift; 1711 my $cmd = shift; 1712 my $input = shift; 1713 my %table = $self->plugin_table; 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 ) ) { 1726 eval { $self->__print( $sub->() ) }; 1727 error( $@ ) if $@; 1728 1729 } else { 1730 $self->__print(" No usage for '$name' -- try perldoc $pkg"); 1731 } 1732 1733 $self->__print( $/ ); 1734 } 1735 1736 $self->__print( $/.$/ ); 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; 1746 sub __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 1775 sub _read_configuration_from_rc { 1776 my $self = shift; 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 1785 $self->__print( 1786 loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) 1787 ) if $@; 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", 1799 '*', '2..5' ) , 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' ), 1803 loc( "Many operations take options, like '%1', '%2' or '%3'", 1804 '--verbose', '--force', '--skiptest' ), 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' ), 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' ), 1811 ); 1812 1813 sub _show_random_tip { 1814 my $self = shift; 1815 $self->__print( $/, "Did you know...\n ", 1816 $tips[ int rand scalar @tips ], $/ ); 1817 return 1; 1818 } 1819 } 1820 1821 1; 1822 1823 __END__ 1824 1825 =pod 1826 1827 =head1 BUG REPORTS 1828 1829 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. 1830 1831 =head1 AUTHOR 1832 1833 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. 1834 1835 =head1 COPYRIGHT 1836 1837 The CPAN++ interface (of which this module is a part of) is copyright (c) 1838 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. 1839 1840 This library is free software; you may redistribute and/or modify it 1841 under the same terms as Perl itself. 1842 1843 =head1 SEE ALSO 1844 1845 L<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 1858 TODO: 1859 e => "_expand_inc", # scratch it, imho -- not used enough 1860 1861 ### free letters: g j k n y ###
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |