[Summary view] [Print] [Text view]

   1  package CPANPLUS::Shell;
   2  
   3  use strict;
   4  
   5  use CPANPLUS::Error;
   6  use CPANPLUS::Configure;
   7  use CPANPLUS::Internals::Constants;
   8  
   9  use Module::Load                qw[load];
  10  use Params::Check               qw[check];
  11  use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  12  
  13  $Params::Check::VERBOSE = 1;
  14  
  15  use vars qw[@ISA $SHELL $DEFAULT];
  16  
  17  $DEFAULT    = SHELL_DEFAULT;
  18  
  19  =pod
  20  
  21  =head1 NAME
  22  
  23  CPANPLUS::Shell
  24  
  25  =head1 SYNOPSIS
  26  
  27      use CPANPLUS::Shell;             # load the shell indicated by your
  28                                       # config -- defaults to
  29                                       # CPANPLUS::Shell::Default
  30  
  31      use CPANPLUS::Shell qw[Classic]  # load CPANPLUS::Shell::Classic;
  32  
  33      my $ui      = CPANPLUS::Shell->new();
  34      my $name    = $ui->which;        # Find out what shell you loaded
  35  
  36      $ui->shell;                      # run the ui shell
  37  
  38  
  39  =head1 DESCRIPTION
  40  
  41  This module is the generic loading (and base class) for all C<CPANPLUS>
  42  shells. Through this module you can load any installed C<CPANPLUS>
  43  shell.
  44  
  45  Just about all the functionality is provided by the shell that you have
  46  loaded, and not by this class (which merely functions as a generic
  47  loading class), so please consult the documentation of your shell of
  48  choice.
  49  
  50  =cut
  51  
  52  sub import {
  53      my $class   = shift;
  54      my $option  = shift;
  55  
  56      ### find out what shell we're supposed to load ###
  57      $SHELL      = $option
  58                      ? $class . '::' . $option
  59                      : do {  ### XXX this should offer to reconfigure 
  60                              ### CPANPLUS, somehow.  --rs
  61                              ### XXX load Configure only if we really have to
  62                              ### as that means any $Conf passed later on will
  63                              ### be ignored in favour of the one that was 
  64                              ### retrieved via ->new --kane
  65                          my $conf = CPANPLUS::Configure->new() or 
  66                          die loc("No configuration available -- aborting") . $/;
  67                          $conf->get_conf('shell') || $DEFAULT;
  68                      };
  69                      
  70      ### load the shell, fall back to the default if required
  71      ### and die if even that doesn't work
  72      EVAL: {
  73          eval { load $SHELL };
  74  
  75          if( $@ ) {
  76              my $err = $@;
  77  
  78              die loc("Your default shell '%1' is not available: %2",
  79                      $DEFAULT, $err) .
  80                  loc("Check your installation!") . "\n"
  81                      if $SHELL eq $DEFAULT;
  82  
  83              warn loc("Failed to use '%1': %2", $SHELL, $err),
  84                   loc("Switching back to the default shell '%1'", $DEFAULT),
  85                   "\n";
  86  
  87              $SHELL = $DEFAULT;
  88              redo EVAL;
  89          }
  90      }
  91      @ISA = ($SHELL);
  92  }
  93  
  94  sub which { return $SHELL }
  95  
  96  1;
  97  
  98  ###########################################################################
  99  ### abstracted out subroutines available to programmers of other shells ###
 100  ###########################################################################
 101  
 102  package CPANPLUS::Shell::_Base::ReadLine;
 103  
 104  use strict;
 105  use vars qw($AUTOLOAD $TMPL);
 106  
 107  use FileHandle;
 108  use CPANPLUS::Error;
 109  use Params::Check               qw[check];
 110  use Module::Load::Conditional   qw[can_load];
 111  use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
 112  
 113  $Params::Check::VERBOSE = 1;
 114  
 115  
 116  $TMPL = {
 117      brand           => { default => '', strict_type => 1 },
 118      prompt          => { default => '> ', strict_type => 1 },
 119      pager           => { default => '' },
 120      backend         => { default => '' },
 121      term            => { default => '' },
 122      format          => { default => '' },
 123      dist_format     => { default => '' },
 124      remote          => { default => undef },
 125      noninteractive  => { default => '' },
 126      cache           => { default => [ ] },
 127      _old_sigpipe    => { default => '', no_override => 1 },
 128      _old_outfh      => { default => '', no_override => 1 },
 129      _signals        => { default => { INT => { } }, no_override => 1 },
 130  };
 131  
 132  ### autogenerate accessors ###
 133  for my $key ( keys %$TMPL ) {
 134      no strict 'refs';
 135      *{__PACKAGE__."::$key"} = sub {
 136          my $self = shift;
 137          $self->{$key} = $_[0] if @_;
 138          return $self->{$key};
 139      }
 140  }
 141  
 142  sub _init {
 143      my $class   = shift;
 144      my %hash    = @_;
 145  
 146      my $self    = check( $TMPL, \%hash ) or return;
 147  
 148      bless $self, $class;
 149  
 150      ### signal handler ###
 151      $SIG{INT} = $self->_signals->{INT}->{handler} =
 152          sub {
 153              unless ( $self->_signals->{INT}->{count}++ ) {
 154                  warn loc("Caught SIGINT"), "\n";
 155              } else {
 156                  warn loc("Got another SIGINT"), "\n"; die;
 157              }
 158          };
 159      ### end sig handler ###
 160  
 161      return $self;
 162  }
 163  
 164  ### display shell's banner, takes the Backend object as argument
 165  sub _show_banner {
 166      my $self = shift;
 167      my $cpan = $self->backend;
 168      my $term = $self->term;
 169  
 170      ### Tries to probe for our ReadLine support status
 171      # a) under an interactive shell?
 172      my $rl_avail = (!$term->isa('CPANPLUS::Shell::_Faked'))
 173          # b) do we have a tty terminal?
 174          ? (-t STDIN)
 175              # c) should we enable the term?
 176              ? (!$self->__is_bad_terminal($term))
 177                  # d) external modules available?
 178                  ? ($term->ReadLine ne "Term::ReadLine::Stub")
 179                      # a+b+c+d => "Smart" terminal
 180                      ? loc("enabled")
 181                      # a+b+c => "Stub" terminal
 182                      : loc("available (try 'i Term::ReadLine::Perl')")
 183                  # a+b => "Bad" terminal
 184                  : loc("disabled")
 185              # a => "Dumb" terminal
 186              : loc("suppressed")
 187          # none    => "Faked" terminal
 188          : loc("suppressed in batch mode");
 189  
 190      $rl_avail = loc("ReadLine support %1.", $rl_avail);
 191      $rl_avail = "\n*** $rl_avail" if (length($rl_avail) > 45);
 192  
 193      $self->__print(
 194            loc("%1 -- CPAN exploration and module installation (v%2)",
 195                  $self->which, $self->which->VERSION()), "\n",
 196            loc("*** Please report bugs to <bug-cpanplus\@rt.cpan.org>."), "\n",
 197            loc("*** Using CPANPLUS::Backend v%1.  %2",
 198                  $cpan->VERSION, $rl_avail), "\n\n"
 199      );
 200  }
 201  
 202  ### checks whether the Term::ReadLine is broken and needs to fallback to Stub
 203  sub __is_bad_terminal {
 204      my $self = shift;
 205      my $term = $self->term;
 206  
 207      return unless $^O eq 'MSWin32';
 208  
 209      ### replace the term with the default (stub) one
 210      return $self->term(Term::ReadLine::Stub->new( $self->brand ) );
 211  }
 212  
 213  ### open a pager handle
 214  sub _pager_open {
 215      my $self  = shift;
 216      my $cpan  = $self->backend;
 217      my $cmd   = $cpan->configure_object->get_program('pager') or return;
 218  
 219      $self->_old_sigpipe( $SIG{PIPE} );
 220      $SIG{PIPE} = 'IGNORE';
 221  
 222      my $fh = new FileHandle;
 223      unless ( $fh->open("| $cmd") ) {
 224          error(loc("could not pipe to %1: %2\n", $cmd, $!) );
 225          return;
 226      }
 227  
 228      $fh->autoflush(1);
 229  
 230      $self->pager( $fh );
 231      $self->_old_outfh( select $fh );
 232  
 233      return $fh;
 234  }
 235  
 236  ### print to the current pager handle, or STDOUT if it's not opened
 237  sub _pager_close {
 238      my $self  = shift;
 239      my $pager = $self->pager or return;
 240  
 241      $pager->close if (ref($pager) and $pager->can('close'));
 242  
 243      $self->pager( undef );
 244  
 245      select $self->_old_outfh;
 246      $SIG{PIPE} = $self->_old_sigpipe;
 247  
 248      return 1;
 249  }
 250  
 251  
 252  
 253  {
 254      my $win32_console;
 255  
 256      ### determines row count of current terminal; defaults to 25.
 257      ### used by the pager functions
 258      sub _term_rowcount {
 259          my $self = shift;
 260          my $cpan = $self->backend;
 261          my %hash = @_;
 262  
 263          my $default;
 264          my $tmpl = {
 265              default => { default => 25, allow => qr/^\d$/,
 266                           store => \$default }
 267          };
 268  
 269          check( $tmpl, \%hash ) or return;
 270  
 271          if ( $^O eq 'MSWin32' ) {
 272              if ( can_load( modules => { 'Win32::Console' => '0.0' } ) ) {
 273                  $win32_console ||= Win32::Console->new();
 274                  my $rows = ($win32_console->Info)[-1];
 275                  return $rows;
 276              }
 277  
 278          } else {
 279              local $Module::Load::Conditional::VERBOSE = 0;
 280              if ( can_load(modules => {'Term::Size' => '0.0'}) ) {
 281                  my ($cols, $rows) = Term::Size::chars();
 282                  return $rows;
 283              }
 284          }
 285          return $default;
 286      }
 287  }
 288  
 289  ### Custom print routines, mainly to be able to catch output
 290  ### in test cases, or redirect it if need be
 291  {   sub __print {
 292          my $self = shift;
 293          print @_;
 294      }
 295      
 296      sub __printf {
 297          my $self = shift;
 298          my $fmt  = shift;
 299          
 300          ### MUST specify $fmt as a seperate param, and not as part
 301          ### of @_, as it will then miss the $fmt and return the 
 302          ### number of elements in the list... =/ --kane
 303          $self->__print( sprintf( $fmt, @_ ) );
 304      }
 305  }
 306  
 307  1;
 308  
 309  =pod
 310  
 311  =head1 BUG REPORTS
 312  
 313  Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 314  
 315  =head1 AUTHOR
 316  
 317  This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 318  
 319  =head1 COPYRIGHT
 320  
 321  The CPAN++ interface (of which this module is a part of) is copyright (c) 
 322  2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 323  
 324  This library is free software; you may redistribute and/or modify it 
 325  under the same terms as Perl itself.
 326  
 327  =head1 SEE ALSO
 328  
 329  L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell::Classic>, L<cpanp>
 330  
 331  =cut
 332  
 333  # Local variables:
 334  # c-indentation-style: bsd
 335  # c-basic-offset: 4
 336  # indent-tabs-mode: nil
 337  # End:
 338  # vim: expandtab shiftwidth=4:
 339