[perl5.git] / cpan / CPANPLUS / lib / CPANPLUS / Shell.pm

package CPANPLUS::Shell;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Configure;
use CPANPLUS::Internals::Constants;

use Module::Load                qw[load];
use Params::Check               qw[check];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

$Params::Check::VERBOSE = 1;

use vars qw[@ISA $SHELL $DEFAULT];

$DEFAULT    = SHELL_DEFAULT;

=pod

=head1 NAME

CPANPLUS::Shell

=head1 SYNOPSIS

    use CPANPLUS::Shell;             # load the shell indicated by your
                                     # config -- defaults to
                                     # CPANPLUS::Shell::Default

    use CPANPLUS::Shell qw[Classic]  # load CPANPLUS::Shell::Classic;

    my $ui      = CPANPLUS::Shell->new();
    my $name    = $ui->which;        # Find out what shell you loaded

    $ui->shell;                      # run the ui shell


=head1 DESCRIPTION

This module is the generic loading (and base class) for all C<CPANPLUS>
shells. Through this module you can load any installed C<CPANPLUS>
shell.

Just about all the functionality is provided by the shell that you have
loaded, and not by this class (which merely functions as a generic
loading class), so please consult the documentation of your shell of
choice.

=cut

sub import {
    my $class   = shift;
    my $option  = shift;

    ### find out what shell we're supposed to load ###
    $SHELL      = $option
                    ? $class . '::' . $option
                    : do {  ### XXX this should offer to reconfigure 
                            ### CPANPLUS, somehow.  --rs
                            ### XXX load Configure only if we really have to
                            ### as that means any $Conf passed later on will
                            ### be ignored in favour of the one that was 
                            ### retrieved via ->new --kane
                        my $conf = CPANPLUS::Configure->new() or 
                        die loc("No configuration available -- aborting") . $/;
                        $conf->get_conf('shell') || $DEFAULT;
                    };
                    
    ### load the shell, fall back to the default if required
    ### and die if even that doesn't work
    EVAL: {
        eval { load $SHELL };

        if( $@ ) {
            my $err = $@;

            die loc("Your default shell '%1' is not available: %2",
                    $DEFAULT, $err) .
                loc("Check your installation!") . "\n"
                    if $SHELL eq $DEFAULT;

            warn loc("Failed to use '%1': %2", $SHELL, $err),
                 loc("Switching back to the default shell '%1'", $DEFAULT),
                 "\n";

            $SHELL = $DEFAULT;
            redo EVAL;
        }
    }
    @ISA = ($SHELL);
}

sub which { return $SHELL }

1;

###########################################################################
### abstracted out subroutines available to programmers of other shells ###
###########################################################################

package CPANPLUS::Shell::_Base::ReadLine;

use strict;
use vars qw($AUTOLOAD $TMPL);

use FileHandle;
use CPANPLUS::Error;
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

$Params::Check::VERBOSE = 1;


$TMPL = {
    brand           => { default => '', strict_type => 1 },
    prompt          => { default => '> ', strict_type => 1 },
    pager           => { default => '' },
    backend         => { default => '' },
    term            => { default => '' },
    format          => { default => '' },
    dist_format     => { default => '' },
    remote          => { default => undef },
    noninteractive  => { default => '' },
    cache           => { default => [ ] },
    settings        => { default => { install_all_prereqs => undef },
                         no_override => 1 },
    _old_sigpipe    => { default => '', no_override => 1 },
    _old_outfh      => { default => '', no_override => 1 },
    _signals        => { default => { INT => { } }, no_override => 1 },
};

### autogenerate accessors ###
for my $key ( keys %$TMPL ) {
    no strict 'refs';
    *{__PACKAGE__."::$key"} = sub {
        my $self = shift;
        $self->{$key} = $_[0] if @_;
        return $self->{$key};
    }
}

sub _init {
    my $class   = shift;
    my %hash    = @_;

    my $self    = check( $TMPL, \%hash ) or return;

    bless $self, $class;

    ### signal handler ###
    $SIG{INT} = $self->_signals->{INT}->{handler} =
        sub {
            unless ( $self->_signals->{INT}->{count}++ ) {
                warn loc("Caught SIGINT"), "\n";
            } else {
                warn loc("Got another SIGINT"), "\n"; die;
            }
        };
    ### end sig handler ###

    return $self;
}

### display shell's banner, takes the Backend object as argument
sub _show_banner {
    my $self = shift;
    my $cpan = $self->backend;
    my $term = $self->term;

    ### Tries to probe for our ReadLine support status
    # a) under an interactive shell?
    my $rl_avail = (!$term->isa('CPANPLUS::Shell::_Faked'))
        # b) do we have a tty terminal?
        ? (-t STDIN)
            # c) should we enable the term?
            ? (!$self->__is_bad_terminal($term))
                # d) external modules available?
                ? ($term->ReadLine ne "Term::ReadLine::Stub")
                    # a+b+c+d => "Smart" terminal
                    ? loc("enabled")
                    # a+b+c => "Stub" terminal
                    : loc("available (try 'i Term::ReadLine::Perl')")
                # a+b => "Bad" terminal
                : loc("disabled")
            # a => "Dumb" terminal
            : loc("suppressed")
        # none    => "Faked" terminal
        : loc("suppressed in batch mode");

    $rl_avail = loc("ReadLine support %1.", $rl_avail);
    $rl_avail = "\n*** $rl_avail" if (length($rl_avail) > 45);

    $self->__print(
          loc("%1 -- CPAN exploration and module installation (v%2)",
                $self->which, $self->which->VERSION()), "\n",
          loc("*** Please report bugs to <bug-cpanplus\@rt.cpan.org>."), "\n",
          loc("*** Using CPANPLUS::Backend v%1.  %2",
                $cpan->VERSION, $rl_avail), "\n\n"
    );
}

### checks whether the Term::ReadLine is broken and needs to fallback to Stub
sub __is_bad_terminal {
    my $self = shift;
    my $term = $self->term;

    return unless $^O eq 'MSWin32';

    ### replace the term with the default (stub) one
    return $self->term(Term::ReadLine::Stub->new( $self->brand ) );
}

### open a pager handle
sub _pager_open {
    my $self  = shift;
    my $cpan  = $self->backend;
    my $cmd   = $cpan->configure_object->get_program('pager') or return;

    $self->_old_sigpipe( $SIG{PIPE} );
    $SIG{PIPE} = 'IGNORE';

    my $fh = new FileHandle;
    unless ( $fh->open("| $cmd") ) {
        error(loc("could not pipe to %1: %2\n", $cmd, $!) );
        return;
    }

    $fh->autoflush(1);

    $self->pager( $fh );
    $self->_old_outfh( select $fh );

    return $fh;
}

### print to the current pager handle, or STDOUT if it's not opened
sub _pager_close {
    my $self  = shift;
    my $pager = $self->pager or return;

    $pager->close if (ref($pager) and $pager->can('close'));

    $self->pager( undef );

    select $self->_old_outfh;
    $SIG{PIPE} = $self->_old_sigpipe;

    return 1;
}


{
    my $win32_console;

    ### determines row count of current terminal; defaults to 25.
    ### used by the pager functions
    sub _term_rowcount {
        my $self = shift;
        my $cpan = $self->backend;
        my %hash = @_;

        my $default;
        my $tmpl = {
            default => { default => 25, allow => qr/^\d$/,
                         store => \$default }
        };

        check( $tmpl, \%hash ) or return;

        if ( $^O eq 'MSWin32' ) {
            if ( can_load( modules => { 'Win32::Console' => '0.0' } ) ) {
                $win32_console ||= Win32::Console->new();
                my $rows = ($win32_console->Info)[-1];
                return $rows;
            }

        } else {
            local $Module::Load::Conditional::VERBOSE = 0;
            if ( can_load(modules => {'Term::Size' => '0.0'}) ) {
                my ($cols, $rows) = Term::Size::chars();
                return $rows;
            }
        }
        return $default;
    }
}

### Custom print routines, mainly to be able to catch output
### in test cases, or redirect it if need be
{   sub __print {
        my $self = shift;
        print @_;
    }
    
    sub __printf {
        my $self = shift;
        my $fmt  = shift;
        
        ### MUST specify $fmt as a separate param, and not as part
        ### of @_, as it will then miss the $fmt and return the 
        ### number of elements in the list... =/ --kane
        $self->__print( sprintf( $fmt, @_ ) );
    }
}

1;

=pod

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is copyright (c) 
2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.

This library is free software; you may redistribute and/or modify it 
under the same terms as Perl itself.

=head1 SEE ALSO

L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell::Classic>, L<cpanp>

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
Commit	Line	Data
6aaee015 RGS	1	package CPANPLUS::Shell;
	2
	3	use strict;
	4
	5	use CPANPLUS::Error;
	6	use CPANPLUS::Configure;
494f1016	7	use CPANPLUS::Internals::Constants;
6aaee015 RGS	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
494f1016	17	$DEFAULT = SHELL_DEFAULT;
6aaee015 RGS	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
6aaee015 RGS	52	sub import {
	53	my $class = shift;
	54	my $option = shift;
6aaee015 RGS	55
	56	### find out what shell we're supposed to load ###
	57	$SHELL = $option
	58	? $class . '::' . $option
5bc5f6dc RGS	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
6aaee015 RGS	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 => [ ] },
4443dd53 JB	127	settings => { default => { install_all_prereqs => undef },
4443dd53 JB	128	no_override => 1 },
6aaee015 RGS	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
5bc5f6dc RGS	195	$self->__print(
5bc5f6dc RGS	196	loc("%1 -- CPAN exploration and module installation (v%2)",
6aaee015 RGS	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",
5bc5f6dc RGS	200	$cpan->VERSION, $rl_avail), "\n\n"
5bc5f6dc RGS	201	);
6aaee015 RGS	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
5bc5f6dc RGS	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
9b73d503	302	### MUST specify $fmt as a separate param, and not as part
5bc5f6dc RGS	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
6aaee015 RGS	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