[perl5.git] / 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 => [ ] },
    _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 seperate 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 => [ ] },
	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
5bc5f6dc RGS	193	$self->__print(
5bc5f6dc RGS	194	loc("%1 -- CPAN exploration and module installation (v%2)",
6aaee015 RGS	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",
5bc5f6dc RGS	198	$cpan->VERSION, $rl_avail), "\n\n"
5bc5f6dc RGS	199	);
6aaee015 RGS	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
5bc5f6dc RGS	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
6aaee015 RGS	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