[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/CPANPLUS/Shell/ -> Classic.pm (source)

   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:


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1