| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 ################################################## 2 ### CPANPLUS/Shell/Classic.pm ### 3 ### Backwards compatible shell for CPAN++ ### 4 ### Written 08-04-2002 by Jos Boumans ### 5 ################################################## 6 7 package CPANPLUS::Shell::Classic; 8 9 use strict; 10 11 12 use CPANPLUS::Error; 13 use CPANPLUS::Backend; 14 use CPANPLUS::Configure::Setup; 15 use CPANPLUS::Internals::Constants; 16 17 use Cwd; 18 use IPC::Cmd; 19 use Term::UI; 20 use Data::Dumper; 21 use Term::ReadLine; 22 23 use Module::Load qw[load]; 24 use Params::Check qw[check]; 25 use Module::Load::Conditional qw[can_load]; 26 27 $Params::Check::VERBOSE = 1; 28 $Params::Check::ALLOW_UNKNOWN = 1; 29 30 BEGIN { 31 use vars qw[ $VERSION @ISA ]; 32 @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; 33 $VERSION = '0.0562'; 34 } 35 36 load CPANPLUS::Shell; 37 38 39 ### our command set ### 40 my $map = { 41 a => '_author', 42 b => '_bundle', 43 d => '_distribution', 44 'm' => '_module', 45 i => '_find_all', 46 r => '_uptodate', 47 u => '_not_supported', 48 ls => '_ls', 49 get => '_fetch', 50 make => '_install', 51 test => '_install', 52 install => '_install', 53 clean => '_not_supported', 54 look => '_shell', 55 readme => '_readme', 56 h => '_help', 57 '?' => '_help', 58 o => '_set_conf', 59 reload => '_reload', 60 autobundle => '_autobundle', 61 '!' => '_bang', 62 #'q' => '_quit', # done it the loop itself 63 }; 64 65 ### the shell object, scoped to the file ### 66 my $Shell; 67 my $Brand = 'cpan'; 68 my $Prompt = $Brand . '> '; 69 70 sub new { 71 my $class = shift; 72 73 my $cb = new CPANPLUS::Backend; 74 my $self = $class->SUPER::_init( 75 brand => $Brand, 76 term => Term::ReadLine->new( $Brand ), 77 prompt => $Prompt, 78 backend => $cb, 79 format => "%5s %-50s %8s %-10s\n", 80 ); 81 ### make it available package wide ### 82 $Shell = $self; 83 84 ### enable verbose, it's the cpan.pm way 85 $cb->configure_object->set_conf( verbose => 1 ); 86 87 88 ### register install callback ### 89 $cb->_register_callback( 90 name => 'install_prerequisite', 91 code => \&__ask_about_install, 92 ); 93 94 ### register test report callback ### 95 $cb->_register_callback( 96 name => 'edit_test_report', 97 code => \&__ask_about_test_report, 98 ); 99 100 return $self; 101 } 102 103 sub shell { 104 my $self = shift; 105 my $term = $self->term; 106 107 $self->_show_banner; 108 $self->_input_loop && print "\n"; 109 $self->_quit; 110 } 111 112 sub _input_loop { 113 my $self = shift; 114 my $term = $self->term; 115 my $cb = $self->backend; 116 117 my $normal_quit = 0; 118 while ( 119 defined (my $input = eval { $term->readline($self->prompt) } ) 120 or $self->_signals->{INT}{count} == 1 121 ) { 122 ### re-initiate all signal handlers 123 while (my ($sig, $entry) = each %{$self->_signals} ) { 124 $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); 125 } 126 127 last if $self->_dispatch_on_input( input => $input ); 128 129 ### flush the lib cache ### 130 $cb->_flush( list => [qw|lib load|] ); 131 132 } continue { 133 $self->_signals->{INT}{count}-- 134 if $self->_signals->{INT}{count}; # clear the sigint count 135 } 136 137 return 1; 138 } 139 140 sub _dispatch_on_input { 141 my $self = shift; 142 my $conf = $self->backend->configure_object(); 143 my $term = $self->term; 144 my %hash = @_; 145 146 my $string; 147 my $tmpl = { 148 input => { required => 1, store => \$string } 149 }; 150 151 check( $tmpl, \%hash ) or return; 152 153 ### the original force setting; 154 my $force_store = $conf->get_conf( 'force' ); 155 156 ### parse the input: the first part before the space 157 ### is the command, followed by arguments. 158 ### see the usage below 159 my $key; 160 PARSE_INPUT: { 161 $string =~ s|^\s*([\w\?\!]+)\s*||; 162 chomp $string; 163 $key = lc($1); 164 } 165 166 ### you prefixed the input with 'force' 167 ### that means we set the force flag, and 168 ### reparse the input... 169 ### YAY goto block :) 170 if( $key eq 'force' ) { 171 $conf->set_conf( force => 1 ); 172 goto PARSE_INPUT; 173 } 174 175 ### you want to quit 176 return 1 if $key =~ /^q/; 177 178 my $method = $map->{$key}; 179 unless( $self->can( $method ) ) { 180 print "Unknown command '$key'. Type ? for help.\n"; 181 return; 182 } 183 184 ### dispatch the method call 185 eval { $self->$method( 186 command => $key, 187 result => [ split /\s+/, $string ], 188 input => $string ); 189 }; 190 warn $@ if $@; 191 192 return; 193 } 194 195 ### displays quit message 196 sub _quit { 197 198 ### well, that's what CPAN.pm says... 199 print "Lockfile removed\n"; 200 } 201 202 sub _not_supported { 203 my $self = shift; 204 my %hash = @_; 205 206 my $cmd; 207 my $tmpl = { 208 command => { required => 1, store => \$cmd } 209 }; 210 211 check( $tmpl, \%hash ) or return; 212 213 print "Sorry, the command '$cmd' is not supported\n"; 214 215 return; 216 } 217 218 sub _fetch { 219 my $self = shift; 220 my $cb = $self->backend; 221 my %hash = @_; 222 223 my($aref, $input); 224 my $tmpl = { 225 result => { store => \$aref, default => [] }, 226 input => { default => 'all', store => \$input }, 227 }; 228 229 check( $tmpl, \%hash ) or return; 230 231 for my $mod (@$aref) { 232 my $obj; 233 234 unless( $obj = $cb->module_tree($mod) ) { 235 print "Warning: Cannot get $input, don't know what it is\n"; 236 print "Try the command\n\n"; 237 print "\ti /$mod/\n\n"; 238 print "to find objects with matching identifiers.\n"; 239 240 next; 241 } 242 243 $obj->fetch && $obj->extract; 244 } 245 246 return $aref; 247 } 248 249 sub _install { 250 my $self = shift; 251 my $cb = $self->backend; 252 my %hash = @_; 253 254 my $mapping = { 255 make => { target => TARGET_CREATE, skiptest => 1 }, 256 test => { target => TARGET_CREATE }, 257 install => { target => TARGET_INSTALL }, 258 }; 259 260 my($aref,$cmd); 261 my $tmpl = { 262 result => { store => \$aref, default => [] }, 263 command => { required => 1, store => \$cmd, allow => [keys %$mapping] }, 264 }; 265 266 check( $tmpl, \%hash ) or return; 267 268 for my $mod (@$aref) { 269 my $obj = $cb->module_tree( $mod ); 270 271 unless( $obj ) { 272 print "No such module '$mod'\n"; 273 next; 274 } 275 276 my $opts = $mapping->{$cmd}; 277 $obj->install( %$opts ); 278 } 279 280 return $aref; 281 } 282 283 sub _shell { 284 my $self = shift; 285 my $cb = $self->backend; 286 my $conf = $cb->configure_object; 287 my %hash = @_; 288 289 my($aref, $cmd); 290 my $tmpl = { 291 result => { store => \$aref, default => [] }, 292 command => { required => 1, store => \$cmd }, 293 294 }; 295 296 check( $tmpl, \%hash ) or return; 297 298 299 my $shell = $conf->get_program('shell'); 300 unless( $shell ) { 301 print "Your configuration does not define a value for subshells.\n". 302 qq[Please define it with "o conf shell <your shell>"\n]; 303 return; 304 } 305 306 my $cwd = Cwd::cwd(); 307 308 for my $mod (@$aref) { 309 print "Running $cmd for $mod\n"; 310 311 my $obj = $cb->module_tree( $mod ) or next; 312 $obj->fetch or next; 313 $obj->extract or next; 314 315 $cb->_chdir( dir => $obj->status->extract ) or next; 316 317 local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; 318 if( system($shell) and $! ) { 319 print "Error executing your subshell '$shell': $!\n"; 320 next; 321 } 322 } 323 $cb->_chdir( dir => $cwd ); 324 325 return $aref; 326 } 327 328 sub _readme { 329 my $self = shift; 330 my $cb = $self->backend; 331 my $conf = $cb->configure_object; 332 my %hash = @_; 333 334 my($aref, $cmd); 335 my $tmpl = { 336 result => { store => \$aref, default => [] }, 337 command => { required => 1, store => \$cmd }, 338 339 }; 340 341 check( $tmpl, \%hash ) or return; 342 343 for my $mod (@$aref) { 344 my $obj = $cb->module_tree( $mod ) or next; 345 346 if( my $readme = $obj->readme ) { 347 348 $self->_pager_open; 349 print $readme; 350 $self->_pager_close; 351 } 352 } 353 354 return 1; 355 } 356 357 sub _reload { 358 my $self = shift; 359 my $cb = $self->backend; 360 my $conf = $cb->configure_object; 361 my %hash = @_; 362 363 my($input, $cmd); 364 my $tmpl = { 365 input => { default => 'all', store => \$input }, 366 command => { required => 1, store => \$cmd }, 367 368 }; 369 370 check( $tmpl, \%hash ) or return; 371 372 if ( $input =~ /cpan/i ) { 373 print qq[You want to reload the CPAN code\n]; 374 print qq[Just type 'q' and then restart... ] . 375 qq[Trust me, it is MUCH safer\n]; 376 377 } elsif ( $input =~ /index/i ) { 378 $cb->reload_indices(update_source => 1); 379 380 } else { 381 print qq[cpan re-evals the CPANPLUS.pm file\n]; 382 print qq[index re-reads the index files\n]; 383 } 384 385 return 1; 386 } 387 388 sub _autobundle { 389 my $self = shift; 390 my $cb = $self->backend; 391 392 print qq[Writing bundle file... This may take a while\n]; 393 394 my $where = $cb->autobundle(); 395 396 print $where 397 ? qq[\nWrote autobundle to $where\n] 398 : qq[\nCould not create autobundle\n]; 399 400 return 1; 401 } 402 403 sub _set_conf { 404 my $self = shift; 405 my $cb = $self->backend; 406 my $conf = $cb->configure_object; 407 my %hash = @_; 408 409 my($aref, $input); 410 my $tmpl = { 411 result => { store => \$aref, default => [] }, 412 input => { default => 'all', store => \$input }, 413 }; 414 415 check( $tmpl, \%hash ) or return; 416 417 my $type = shift @$aref; 418 419 if( $type eq 'debug' ) { 420 print qq[Sorry you cannot set debug options through ] . 421 qq[this shell in CPANPLUS\n]; 422 return; 423 424 } elsif ( $type eq 'conf' ) { 425 426 ### from CPAN.pm :o) 427 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf' 428 # should have been called set and 'o debug' maybe 'set debug' 429 430 # commit Commit changes to disk 431 # defaults Reload defaults from disk 432 # init Interactive setting of all options 433 434 my $name = shift @$aref; 435 my $value = "@$aref"; 436 437 if( $name eq 'init' ) { 438 my $setup = CPANPLUS::Configure::Setup->new( 439 conf => $cb->configure_object, 440 term => $self->term, 441 backend => $cb, 442 ); 443 return $setup->init; 444 445 } elsif ($name eq 'commit' ) {; 446 $cb->configure_object->save; 447 print "Your CPAN++ configuration info has been saved!\n\n"; 448 return; 449 450 } elsif ($name eq 'defaults' ) { 451 print qq[Sorry, CPANPLUS cannot restore default for you.\n] . 452 qq[Perhaps you should run the interactive setup again.\n] . 453 qq[\ttry running 'o conf init'\n]; 454 return; 455 456 ### we're just supplying things in the 'conf' section now, 457 ### not the program section.. it's a bit of a hassle to make that 458 ### work cleanly with the original CPAN.pm interface, so we'll fix 459 ### it when people start complaining, which is hopefully never. 460 } else { 461 unless( $name ) { 462 my @list = grep { $_ ne 'hosts' } 463 $conf->options( type => $type ); 464 465 my $method = 'get_' . $type; 466 467 local $Data::Dumper::Indent = 0; 468 for my $name ( @list ) { 469 my $val = $conf->$method($name); 470 ($val) = ref($val) 471 ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) 472 : "'$val'"; 473 printf " %-25s %s\n", $name, $val; 474 } 475 476 } elsif ( $name eq 'hosts' ) { 477 print "Setting hosts is not trivial.\n" . 478 "It is suggested you edit the " . 479 "configuration file manually"; 480 481 } else { 482 my $method = 'set_' . $type; 483 if( $conf->$method($name => defined $value ? $value : '') ) { 484 my $set_to = defined $value ? $value : 'EMPTY STRING'; 485 print "Key '$name' was set to '$set_to'\n"; 486 } 487 } 488 } 489 } else { 490 print qq[Known options:\n] . 491 qq[ conf set or get configuration variables\n] . 492 qq[ debug set or get debugging options\n]; 493 } 494 495 return; 496 } 497 498 ######################## 499 ### search functions ### 500 ######################## 501 502 sub _author { 503 my $self = shift; 504 my $cb = $self->backend; 505 my %hash = @_; 506 507 my($aref, $short, $input, $class); 508 my $tmpl = { 509 result => { store => \$aref, default => ['/./'] }, 510 short => { default => 0, store => \$short }, 511 input => { default => 'all', store => \$input }, 512 class => { default => 'Author', no_override => 1, 513 store => \$class }, 514 }; 515 516 check( $tmpl, \%hash ) or return; 517 518 my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref; 519 520 521 my @rv; 522 for my $type (qw[author cpanid]) { 523 push @rv, $cb->search( type => $type, allow => \@regexes ); 524 } 525 526 unless( @rv ) { 527 print "No object of type $class found for argument $input\n" 528 unless $short; 529 return; 530 } 531 532 return $self->_pp_author( 533 result => \@rv, 534 class => $class, 535 short => $short, 536 input => $input ); 537 538 } 539 540 ### find all modules matching a query ### 541 sub _module { 542 my $self = shift; 543 my $cb = $self->backend; 544 my %hash = @_; 545 546 my($aref, $short, $input, $class); 547 my $tmpl = { 548 result => { store => \$aref, default => ['/./'] }, 549 short => { default => 0, store => \$short }, 550 input => { default => 'all', store => \$input }, 551 class => { default => 'Module', no_override => 1, 552 store => \$class }, 553 }; 554 555 check( $tmpl, \%hash ) or return; 556 557 my @rv; 558 for my $module (@$aref) { 559 if( $module =~ m|/(.+)/| ) { 560 push @rv, $cb->search( type => 'module', 561 allow => [qr/$1/i] ); 562 } else { 563 my $obj = $cb->module_tree( $module ) or next; 564 push @rv, $obj; 565 } 566 } 567 568 return $self->_pp_module( 569 result => \@rv, 570 class => $class, 571 short => $short, 572 input => $input ); 573 } 574 575 ### find all bundles matching a query ### 576 sub _bundle { 577 my $self = shift; 578 my $cb = $self->backend; 579 my %hash = @_; 580 581 my($aref, $short, $input, $class); 582 my $tmpl = { 583 result => { store => \$aref, default => ['/./'] }, 584 short => { default => 0, store => \$short }, 585 input => { default => 'all', store => \$input }, 586 class => { default => 'Bundle', no_override => 1, 587 store => \$class }, 588 }; 589 590 check( $tmpl, \%hash ) or return; 591 592 my @rv; 593 for my $bundle (@$aref) { 594 if( $bundle =~ m|/(.+)/| ) { 595 push @rv, $cb->search( type => 'module', 596 allow => [qr/Bundle::.*?$1/i] ); 597 } else { 598 my $obj = $cb->module_tree( "Bundle::$bundle}" ) or next; 599 push @rv, $obj; 600 } 601 } 602 603 return $self->_pp_module( 604 result => \@rv, 605 class => $class, 606 short => $short, 607 input => $input ); 608 } 609 610 sub _distribution { 611 my $self = shift; 612 my $cb = $self->backend; 613 my %hash = @_; 614 615 my($aref, $short, $input, $class); 616 my $tmpl = { 617 result => { store => \$aref, default => ['/./'] }, 618 short => { default => 0, store => \$short }, 619 input => { default => 'all', store => \$input }, 620 class => { default => 'Distribution', no_override => 1, 621 store => \$class }, 622 }; 623 624 check( $tmpl, \%hash ) or return; 625 626 my @rv; 627 for my $module (@$aref) { 628 ### if it's a regex... ### 629 if ( my ($match) = $module =~ m|^/(.+)/$|) { 630 631 ### something like /FOO/Bar.tar.gz/ was entered 632 if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) { 633 my $seen; 634 635 my @data = $cb->search( type => 'package', 636 allow => [qr/$package/i] ); 637 638 my @list = $cb->search( type => 'path', 639 allow => [qr/$path/i], 640 data => \@data ); 641 642 ### make sure we dont list the same dist twice 643 for my $val ( @list ) { 644 next if $seen->{$val->package}++; 645 646 push @rv, $val; 647 } 648 649 ### something like /FOO/ or /Bar.tgz/ was entered 650 ### so we look both in the path, as well as in the package name 651 } else { 652 my $seen; 653 { my @list = $cb->search( type => 'package', 654 allow => [qr/$match/i] ); 655 656 ### make sure we dont list the same dist twice 657 for my $val ( @list ) { 658 next if $seen->{$val->package}++; 659 660 push @rv, $val; 661 } 662 } 663 664 { my @list = $cb->search( type => 'path', 665 allow => [qr/$match/i] ); 666 667 ### make sure we dont list the same dist twice 668 for my $val ( @list ) { 669 next if $seen->{$val->package}++; 670 671 push @rv, $val; 672 } 673 674 } 675 } 676 677 } else { 678 679 ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz 680 if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) { 681 my @data = $cb->search( type => 'package', 682 allow => [qr/^$package$/] ); 683 my @list = $cb->search( type => 'path', 684 allow => [qr/$path$/i], 685 data => \@data); 686 687 ### make sure we dont list the same dist twice 688 my $seen; 689 for my $val ( @list ) { 690 next if $seen->{$val->package}++; 691 692 push @rv, $val; 693 } 694 } 695 } 696 } 697 698 return $self->_pp_distribution( 699 result => \@rv, 700 class => $class, 701 short => $short, 702 input => $input ); 703 } 704 705 sub _find_all { 706 my $self = shift; 707 708 my @rv; 709 for my $method (qw[_author _bundle _module _distribution]) { 710 my $aref = $self->$method( @_, short => 1 ); 711 712 push @rv, @$aref if $aref; 713 } 714 715 print scalar(@rv). " items found\n" 716 } 717 718 sub _uptodate { 719 my $self = shift; 720 my $cb = $self->backend; 721 my %hash = @_; 722 723 my($aref, $short, $input, $class); 724 my $tmpl = { 725 result => { store => \$aref, default => ['/./'] }, 726 short => { default => 0, store => \$short }, 727 input => { default => 'all', store => \$input }, 728 class => { default => 'Uptodate', no_override => 1, 729 store => \$class }, 730 }; 731 732 check( $tmpl, \%hash ) or return; 733 734 735 my @rv; 736 if( @$aref) { 737 for my $module (@$aref) { 738 if( $module =~ m|/(.+)/| ) { 739 my @list = $cb->search( type => 'module', 740 allow => [qr/$1/i] ); 741 742 ### only add those that are installed and not core 743 push @rv, grep { not $_->package_is_perl_core } 744 grep { $_->installed_file } 745 @list; 746 747 } else { 748 my $obj = $cb->module_tree( $module ) or next; 749 push @rv, $obj; 750 } 751 } 752 } else { 753 @rv = @{$cb->_all_installed}; 754 } 755 756 return $self->_pp_uptodate( 757 result => \@rv, 758 class => $class, 759 short => $short, 760 input => $input ); 761 } 762 763 sub _ls { 764 my $self = shift; 765 my $cb = $self->backend; 766 my %hash = @_; 767 768 my($aref, $short, $input, $class); 769 my $tmpl = { 770 result => { store => \$aref, default => [] }, 771 short => { default => 0, store => \$short }, 772 input => { default => 'all', store => \$input }, 773 class => { default => 'Uptodate', no_override => 1, 774 store => \$class }, 775 }; 776 777 check( $tmpl, \%hash ) or return; 778 779 my @rv; 780 for my $name (@$aref) { 781 my $auth = $cb->author_tree( uc $name ); 782 783 unless( $auth ) { 784 print qq[ls command rejects argument $name: not an author\n]; 785 next; 786 } 787 788 push @rv, $auth->distributions; 789 } 790 791 return $self->_pp_ls( 792 result => \@rv, 793 class => $class, 794 short => $short, 795 input => $input ); 796 } 797 798 ############################ 799 ### pretty printing subs ### 800 ############################ 801 802 803 sub _pp_author { 804 my $self = shift; 805 my %hash = @_; 806 807 my( $aref, $short, $class, $input ); 808 my $tmpl = { 809 result => { required => 1, default => [], strict_type => 1, 810 store => \$aref }, 811 short => { default => 0, store => \$short }, 812 class => { required => 1, store => \$class }, 813 input => { required => 1, store => \$input }, 814 }; 815 816 check( $tmpl, \%hash ) or return; 817 818 ### no results 819 if( !@$aref ) { 820 print "No objects of type $class found for argument $input\n" 821 unless $short; 822 823 ### one result, long output desired; 824 } elsif( @$aref == 1 and !$short ) { 825 826 ### should look like this: 827 #cpan> a KANE 828 #Author id = KANE 829 # EMAIL boumans@frg.eur.nl 830 # FULLNAME Jos Boumans 831 832 my $obj = shift @$aref; 833 834 print "$class id = ", $obj->cpanid(), "\n"; 835 printf " %-12s %s\n", 'EMAIL', $obj->email(); 836 printf " %-12s %s%s\n", 'FULLNAME', $obj->author(); 837 838 } else { 839 840 ### should look like this: 841 #Author KANE (Jos Boumans) 842 #Author LBROCARD (Leon Brocard) 843 #2 items found 844 845 for my $obj ( @$aref ) { 846 printf qq[%-15s %s ("%s" (%s))\n], 847 $class, $obj->cpanid, $obj->author, $obj->email; 848 } 849 print scalar(@$aref)." items found\n" unless $short; 850 } 851 852 return $aref; 853 } 854 855 sub _pp_module { 856 my $self = shift; 857 my %hash = @_; 858 859 my( $aref, $short, $class, $input ); 860 my $tmpl = { 861 result => { required => 1, default => [], strict_type => 1, 862 store => \$aref }, 863 short => { default => 0, store => \$short }, 864 class => { required => 1, store => \$class }, 865 input => { required => 1, store => \$input }, 866 }; 867 868 check( $tmpl, \%hash ) or return; 869 870 871 ### no results 872 if( !@$aref ) { 873 print "No objects of type $class found for argument $input\n" 874 unless $short; 875 876 ### one result, long output desired; 877 } elsif( @$aref == 1 and !$short ) { 878 879 880 ### should look like this: 881 #Module id = LWP 882 # DESCRIPTION Libwww-perl 883 # CPAN_USERID GAAS (Gisle Aas <gisle@ActiveState.com>) 884 # CPAN_VERSION 5.64 885 # CPAN_FILE G/GA/GAAS/libwww-perl-5.64.tar.gz 886 # DSLI_STATUS RmpO (released,mailing-list,perl,object-oriented) 887 # MANPAGE LWP - The World-Wide Web library for Perl 888 # INST_FILE C:\Perl\site\lib\LWP.pm 889 # INST_VERSION 5.62 890 891 my $obj = shift @$aref; 892 my $aut_obj = $obj->author; 893 my $format = " %-12s %s%s\n"; 894 895 print "$class id = ", $obj->module(), "\n"; 896 printf $format, 'DESCRIPTION', $obj->description() 897 if $obj->description(); 898 899 printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" . 900 $aut_obj->author() . " <" . $aut_obj->email() . ">)"; 901 902 printf $format, 'CPAN_VERSION', $obj->version(); 903 printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package(); 904 905 printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip) 906 if $obj->dslip() =~ /\w/; 907 908 #printf $format, 'MANPAGE', $obj->foo(); 909 ### this is for bundles... CPAN.pm downloads them, 910 #printf $format, 'CONATAINS, 911 # parses and goes from there... 912 913 printf $format, 'INST_FILE', $obj->installed_file || 914 '(not installed)'; 915 printf $format, 'INST_VERSION', $obj->installed_version; 916 917 918 919 } else { 920 921 ### should look like this: 922 #Module LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) 923 #Module POE (R/RC/RCAPUTO/POE-0.19.tar.gz) 924 #2 items found 925 926 for my $obj ( @$aref ) { 927 printf "%-15s %-15s (%s)\n", $class, $obj->module(), 928 $obj->path() .'/'. $obj->package(); 929 } 930 print scalar(@$aref). " items found\n" unless $short; 931 } 932 933 return $aref; 934 } 935 936 sub _pp_dslip { 937 my $self = shift; 938 my $dslip = shift or return; 939 940 my (%_statusD, %_statusS, %_statusL, %_statusI); 941 942 @_statusD{qw(? i c a b R M S)} = 943 qw(unknown idea pre-alpha alpha beta released mature standard); 944 945 @_statusS{qw(? m d u n)} = 946 qw(unknown mailing-list developer comp.lang.perl.* none); 947 948 @_statusL{qw(? p c + o h)} = qw(unknown perl C C++ other hybrid); 949 @_statusI{qw(? f r O h)} = 950 qw(unknown functions references+ties object-oriented hybrid); 951 952 my @status = split("", $dslip); 953 954 my $results = sprintf( "%s (%s,%s,%s,%s)", 955 $dslip, 956 $_statusD{$status[0]}, 957 $_statusS{$status[1]}, 958 $_statusL{$status[2]}, 959 $_statusI{$status[3]} 960 ); 961 962 return $results; 963 } 964 965 sub _pp_distribution { 966 my $self = shift; 967 my $cb = $self->backend; 968 my %hash = @_; 969 970 my( $aref, $short, $class, $input ); 971 my $tmpl = { 972 result => { required => 1, default => [], strict_type => 1, 973 store => \$aref }, 974 short => { default => 0, store => \$short }, 975 class => { required => 1, store => \$class }, 976 input => { required => 1, store => \$input }, 977 }; 978 979 check( $tmpl, \%hash ) or return; 980 981 982 ### no results 983 if( !@$aref ) { 984 print "No objects of type $class found for argument $input\n" 985 unless $short; 986 987 ### one result, long output desired; 988 } elsif( @$aref == 1 and !$short ) { 989 990 991 ### should look like this: 992 #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz 993 # CPAN_USERID SABECK (Scott Beck <scott@gossamer-threads.com>) 994 # CONTAINSMODS POE::Component::Client::POP3 995 996 my $obj = shift @$aref; 997 my $aut_obj = $obj->author; 998 my $pkg = $obj->package; 999 my $format = " %-12s %s\n"; 1000 1001 my @list = $cb->search( type => 'package', 1002 allow => [qr/^$pkg$/] ); 1003 1004 1005 print "$class id = ", $obj->path(), '/', $obj->package(), "\n"; 1006 printf $format, 'CPAN_USERID', 1007 $aut_obj->cpanid .' ('. $aut_obj->author . 1008 ' '. $aut_obj->email .')'; 1009 1010 ### yes i know it's ugly, but it's what cpan.pm does 1011 printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list); 1012 1013 } else { 1014 1015 ### should look like this: 1016 #Distribution LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) 1017 #Distribution POE (R/RC/RCAPUTO/POE-0.19.tar.gz) 1018 #2 items found 1019 1020 for my $obj ( @$aref ) { 1021 printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package(); 1022 } 1023 1024 print scalar(@$aref). " items found\n" unless $short; 1025 } 1026 1027 return $aref; 1028 } 1029 1030 sub _pp_uptodate { 1031 my $self = shift; 1032 my $cb = $self->backend; 1033 my %hash = @_; 1034 1035 my( $aref, $short, $class, $input ); 1036 my $tmpl = { 1037 result => { required => 1, default => [], strict_type => 1, 1038 store => \$aref }, 1039 short => { default => 0, store => \$short }, 1040 class => { required => 1, store => \$class }, 1041 input => { required => 1, store => \$input }, 1042 }; 1043 1044 check( $tmpl, \%hash ) or return; 1045 1046 my $format = "%-25s %9s %9s %s\n"; 1047 1048 my @not_uptodate; 1049 my $no_version; 1050 1051 my %seen; 1052 for my $mod (@$aref) { 1053 next if $mod->package_is_perl_core; 1054 next if $seen{ $mod->package }++; 1055 1056 1057 if( $mod->installed_file and not $mod->installed_version ) { 1058 $no_version++; 1059 next; 1060 } 1061 1062 push @not_uptodate, $mod unless $mod->is_uptodate; 1063 } 1064 1065 unless( @not_uptodate ) { 1066 my $string = $input 1067 ? "for $input" 1068 : ''; 1069 print "All modules are up to date $string\n"; 1070 return; 1071 1072 } else { 1073 printf $format, ( 'Package namespace', 1074 'installed', 1075 'latest', 1076 'in CPAN file' 1077 ); 1078 } 1079 1080 for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) { 1081 printf $format, ( $mod->module, 1082 $mod->installed_version, 1083 $mod->version, 1084 $mod->path .'/'. $mod->package, 1085 ); 1086 } 1087 1088 print "$no_version installed modules have no (parsable) version number\n" 1089 if $no_version; 1090 1091 return \@not_uptodate; 1092 } 1093 1094 sub _pp_ls { 1095 my $self = shift; 1096 my $cb = $self->backend; 1097 my %hash = @_; 1098 1099 my( $aref, $short, $class, $input ); 1100 my $tmpl = { 1101 result => { required => 1, default => [], strict_type => 1, 1102 store => \$aref }, 1103 short => { default => 0, store => \$short }, 1104 class => { required => 1, store => \$class }, 1105 input => { required => 1, store => \$input }, 1106 }; 1107 1108 check( $tmpl, \%hash ) or return; 1109 1110 ### should look something like this: 1111 #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz 1112 #8171 2002-08-13 KANE/Acme-Comment-1.01.zip 1113 #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz 1114 #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz 1115 #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip 1116 #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz 1117 1118 ### don't know size or mtime 1119 #my $format = "%8d %10s %s/%s\n"; 1120 1121 for my $mod ( sort { $a->package cmp $b->package } @$aref ) { 1122 print "\t" . $mod->package . "\n"; 1123 } 1124 1125 return $aref; 1126 } 1127 1128 1129 ############################# 1130 ### end pretty print subs ### 1131 ############################# 1132 1133 1134 sub _bang { 1135 my $self = shift; 1136 my %hash = @_; 1137 1138 my( $input ); 1139 my $tmpl = { 1140 input => { required => 1, store => \$input }, 1141 }; 1142 1143 check( $tmpl, \%hash ) or return; 1144 1145 eval $input; 1146 warn $@ if $@; 1147 1148 print "\n"; 1149 1150 return; 1151 } 1152 1153 sub _help { 1154 print qq[ 1155 Display Information 1156 a authors 1157 b string display bundles 1158 d or info distributions 1159 m /regex/ about modules 1160 i or anything of above 1161 r none reinstall recommendations 1162 u uninstalled distributions 1163 1164 Download, Test, Make, Install... 1165 get download 1166 make make (implies get) 1167 test modules, make test (implies make) 1168 install dists, bundles make install (implies test) 1169 clean make clean 1170 look open subshell in these dists' directories 1171 readme display these dists' README files 1172 1173 Other 1174 h,? display this menu ! perl-code eval a perl command 1175 o conf [opt] set and query options q quit the cpan shell 1176 reload cpan load CPAN.pm again reload index load newer indices 1177 autobundle Snapshot force cmd unconditionally do cmd 1178 ]; 1179 1180 } 1181 1182 1183 1184 1; 1185 __END__ 1186 1187 =pod 1188 1189 =head1 NAME 1190 1191 CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS 1192 1193 =head1 DESCRIPTION 1194 1195 The Classic shell is designed to provide the feel of the CPAN.pm shell 1196 using CPANPLUS underneath. 1197 1198 For detailed documentation, refer to L<CPAN>. 1199 1200 =head1 BUG REPORTS 1201 1202 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. 1203 1204 =head1 AUTHOR 1205 1206 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. 1207 1208 =head1 COPYRIGHT 1209 1210 The CPAN++ interface (of which this module is a part of) is copyright (c) 1211 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. 1212 1213 This library is free software; you may redistribute and/or modify it 1214 under the same terms as Perl itself. 1215 1216 =head1 SEE ALSO 1217 1218 L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author> 1219 1220 =cut 1221 1222 1223 =head1 SEE ALSO 1224 1225 L<CPAN> 1226 1227 =cut 1228 1229 1230 1231 # Local variables: 1232 # c-indentation-style: bsd 1233 # c-basic-offset: 4 1234 # indent-tabs-mode: nil 1235 # End: 1236 # vim: expandtab shiftwidth=4:
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 |