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     _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