lib/CPANPLUS/Shell/Classic.pm

   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: