ext/CPANPLUS/lib/CPANPLUS/Shell.pm

   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     settings        => { default => { install_all_prereqs => undef },
 128                          no_override => 1 },
 129     _old_sigpipe    => { default => '', no_override => 1 },
 130     _old_outfh      => { default => '', no_override => 1 },
 131     _signals        => { default => { INT => { } }, no_override => 1 },
 132 };
 133
 134 ### autogenerate accessors ###
 135 for my $key ( keys %$TMPL ) {
 136     no strict 'refs';
 137     *{__PACKAGE__."::$key"} = sub {
 138         my $self = shift;
 139         $self->{$key} = $_[0] if @_;
 140         return $self->{$key};
 141     }
 142 }
 143
 144 sub _init {
 145     my $class   = shift;
 146     my %hash    = @_;
 147
 148     my $self    = check( $TMPL, \%hash ) or return;
 149
 150     bless $self, $class;
 151
 152     ### signal handler ###
 153     $SIG{INT} = $self->_signals->{INT}->{handler} =
 154         sub {
 155             unless ( $self->_signals->{INT}->{count}++ ) {
 156                 warn loc("Caught SIGINT"), "\n";
 157             } else {
 158                 warn loc("Got another SIGINT"), "\n"; die;
 159             }
 160         };
 161     ### end sig handler ###
 162
 163     return $self;
 164 }
 165
 166 ### display shell's banner, takes the Backend object as argument
 167 sub _show_banner {
 168     my $self = shift;
 169     my $cpan = $self->backend;
 170     my $term = $self->term;
 171
 172     ### Tries to probe for our ReadLine support status
 173     # a) under an interactive shell?
 174     my $rl_avail = (!$term->isa('CPANPLUS::Shell::_Faked'))
 175         # b) do we have a tty terminal?
 176         ? (-t STDIN)
 177             # c) should we enable the term?
 178             ? (!$self->__is_bad_terminal($term))
 179                 # d) external modules available?
 180                 ? ($term->ReadLine ne "Term::ReadLine::Stub")
 181                     # a+b+c+d => "Smart" terminal
 182                     ? loc("enabled")
 183                     # a+b+c => "Stub" terminal
 184                     : loc("available (try 'i Term::ReadLine::Perl')")
 185                 # a+b => "Bad" terminal
 186                 : loc("disabled")
 187             # a => "Dumb" terminal
 188             : loc("suppressed")
 189         # none    => "Faked" terminal
 190         : loc("suppressed in batch mode");
 191
 192     $rl_avail = loc("ReadLine support %1.", $rl_avail);
 193     $rl_avail = "\n*** $rl_avail" if (length($rl_avail) > 45);
 194
 195     $self->__print(
 196           loc("%1 -- CPAN exploration and module installation (v%2)",
 197                 $self->which, $self->which->VERSION()), "\n",
 198           loc("*** Please report bugs to <bug-cpanplus\@rt.cpan.org>."), "\n",
 199           loc("*** Using CPANPLUS::Backend v%1.  %2",
 200                 $cpan->VERSION, $rl_avail), "\n\n"
 201     );
 202 }
 203
 204 ### checks whether the Term::ReadLine is broken and needs to fallback to Stub
 205 sub __is_bad_terminal {
 206     my $self = shift;
 207     my $term = $self->term;
 208
 209     return unless $^O eq 'MSWin32';
 210
 211     ### replace the term with the default (stub) one
 212     return $self->term(Term::ReadLine::Stub->new( $self->brand ) );
 213 }
 214
 215 ### open a pager handle
 216 sub _pager_open {
 217     my $self  = shift;
 218     my $cpan  = $self->backend;
 219     my $cmd   = $cpan->configure_object->get_program('pager') or return;
 220
 221     $self->_old_sigpipe( $SIG{PIPE} );
 222     $SIG{PIPE} = 'IGNORE';
 223
 224     my $fh = new FileHandle;
 225     unless ( $fh->open("| $cmd") ) {
 226         error(loc("could not pipe to %1: %2\n", $cmd, $!) );
 227         return;
 228     }
 229
 230     $fh->autoflush(1);
 231
 232     $self->pager( $fh );
 233     $self->_old_outfh( select $fh );
 234
 235     return $fh;
 236 }
 237
 238 ### print to the current pager handle, or STDOUT if it's not opened
 239 sub _pager_close {
 240     my $self  = shift;
 241     my $pager = $self->pager or return;
 242
 243     $pager->close if (ref($pager) and $pager->can('close'));
 244
 245     $self->pager( undef );
 246
 247     select $self->_old_outfh;
 248     $SIG{PIPE} = $self->_old_sigpipe;
 249
 250     return 1;
 251 }
 252
 253
 254
 255 {
 256     my $win32_console;
 257
 258     ### determines row count of current terminal; defaults to 25.
 259     ### used by the pager functions
 260     sub _term_rowcount {
 261         my $self = shift;
 262         my $cpan = $self->backend;
 263         my %hash = @_;
 264
 265         my $default;
 266         my $tmpl = {
 267             default => { default => 25, allow => qr/^\d$/,
 268                          store => \$default }
 269         };
 270
 271         check( $tmpl, \%hash ) or return;
 272
 273         if ( $^O eq 'MSWin32' ) {
 274             if ( can_load( modules => { 'Win32::Console' => '0.0' } ) ) {
 275                 $win32_console ||= Win32::Console->new();
 276                 my $rows = ($win32_console->Info)[-1];
 277                 return $rows;
 278             }
 279
 280         } else {
 281             local $Module::Load::Conditional::VERBOSE = 0;
 282             if ( can_load(modules => {'Term::Size' => '0.0'}) ) {
 283                 my ($cols, $rows) = Term::Size::chars();
 284                 return $rows;
 285             }
 286         }
 287         return $default;
 288     }
 289 }
 290
 291 ### Custom print routines, mainly to be able to catch output
 292 ### in test cases, or redirect it if need be
 293 {   sub __print {
 294         my $self = shift;
 295         print @_;
 296     }
 297
 298     sub __printf {
 299         my $self = shift;
 300         my $fmt  = shift;
 301
 302         ### MUST specify $fmt as a seperate param, and not as part
 303         ### of @_, as it will then miss the $fmt and return the
 304         ### number of elements in the list... =/ --kane
 305         $self->__print( sprintf( $fmt, @_ ) );
 306     }
 307 }
 308
 309 1;
 310
 311 =pod
 312
 313 =head1 BUG REPORTS
 314
 315 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 316
 317 =head1 AUTHOR
 318
 319 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 320
 321 =head1 COPYRIGHT
 322
 323 The CPAN++ interface (of which this module is a part of) is copyright (c)
 324 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 325
 326 This library is free software; you may redistribute and/or modify it
 327 under the same terms as Perl itself.
 328
 329 =head1 SEE ALSO
 330
 331 L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell::Classic>, L<cpanp>
 332
 333 =cut
 334
 335 # Local variables:
 336 # c-indentation-style: bsd
 337 # c-basic-offset: 4
 338 # indent-tabs-mode: nil
 339 # End:
 340 # vim: expandtab shiftwidth=4:
 341