### the shell prints to STDOUT, so capture that here
### and we can check the output
### make sure we can find our conf.pl file
BEGIN {
use FindBin;
require "$FindBin::Bin/inc/conf.pl";
}
### this lets us capture output from the default shell
{ no warnings 'redefine';
my $out;
*CPANPLUS::Shell::Default::__print = sub {
my $self = shift;
$out .= "@_";
};
sub _out { $out }
sub _reset_out { $out = '' }
}
use strict;
use Test::More 'no_plan';
use CPANPLUS::Internals::Constants;
### in some subprocesses, the Term::ReadKey code will go
### balistic and die because it can't figure out terminal
### dimensions. If we add these env vars, it'll use them
### as a default and not die. Thanks to Slaven Rezic for
### reporting this.
local $ENV{'COLUMNS'} = 80 unless $ENV{'COLUMNS'};
local $ENV{'LINES'} = 40 unless $ENV{'LINES'};
my $Conf = gimme_conf();
my $Class = 'CPANPLUS::Shell';
my $Default = SHELL_DEFAULT;
my $TestMod = TEST_CONF_MODULE;
my $TestAuth= TEST_CONF_AUTHOR;
### basic load tests
use_ok( $Class, 'Default' );
is( $Class->which, SHELL_DEFAULT,
"Default shell loaded" );
### create an object
my $Shell = $Class->new( $Conf );
ok( $Shell, " New object created" );
isa_ok( $Shell, $Default, " Object" );
### method tests
{
### uri to use for /cs tests
my $cs_path = File::Spec->rel2abs(
File::Spec->catfile(
$FindBin::Bin,
TEST_CONF_CPAN_DIR,
)
);
my $cs_uri = $Shell->backend->_host_to_uri(
scheme => 'file',
host => '',
path => $cs_path,
);
my $base = $Conf->get_conf('base');
### XXX have to keep the list ordered, as some methods only work as
### expected *after* others have run
my @map = (
'v' => qr/CPANPLUS/,
'! $self->__print($$)' => qr/$$/,
'?' => qr/\[General\]/,
'h' => qr/\[General\]/,
's' => qr/Unknown type/,
's conf' => qr/$Default/,
's program' => qr/sudo/,
's mirrors' => do { my $re = TEST_CONF_CPAN_DIR; qr/$re/ },
's selfupdate' => qr/selfupdate/,
'b' => qr/autobundle/,
"a $TestAuth" => qr/$TestAuth/,
"m $TestMod" => qr/$TestMod/,
"w" => qr/$TestMod/,
"r 1" => qr/README/,
"r $TestMod" => qr/README/,
"f $TestMod" => qr/$TestAuth/,
"d $TestMod" => qr/$TestMod/,
### XXX this one prints to stdout in a subprocess -- skipping this
### for now due to possible PERL_CORE issues
#"t $TestMod" => qr/$TestMod.*tested successfully/i,
"l $TestMod" => qr/$TestMod/,
'! die $$; p' => qr/$$/,
'/plugins' => qr/Available plugins:/i,
'/? ?' => qr/usage/i,
### custom source plugin tests
### lower case path matching, as on VMS we can't predict case
"/? cs" => qr|/cs|,
"/cs --add $cs_uri" => qr/Added remote source/,
"/cs --list" => do { my $re = quotemeta($cs_uri); qr/$re/i },
"/cs --contents $cs_uri" => qr/$TestAuth/i,
"/cs --update" => qr/Updated remote sources/,
"/cs --update $cs_uri" => qr/Updated remote sources/,
### --write leaves a file that we should clean up, so make
### sure it's in the path that we clean up already anyway
"/cs --write $base" => qr/Wrote remote source index/,
"/cs --remove $cs_uri" => qr/Removed remote source/,
);
my $meth = 'dispatch_on_input';
can_ok( $Shell, $meth );
while( my($input,$out_re) = splice(@map, 0, 2) ) {
### empty output cache
__PACKAGE__->_reset_out;
CPANPLUS::Error->flush;
ok( 1, "Testing '$input'" );
$Shell->$meth( input => $input );
my $out = __PACKAGE__->_out;
### XXX remove me
#diag( $out );
ok( $out, " Output received" );
like( $out, $out_re, " Output matches '$out_re'" );
}
}
__END__
#### test seperately, they have side effects
'q' => qr/^$/, # no output!
's save boxed' => do { my $re = CONFIG_BOXED; qr/$re/ },
### this doens't write any output
'x --update_source' => qr/module tree/i,
s edit
s reconfigure
'c' => '_reports',
'i' => '_install',
'u' => '_uninstall',
'z' => '_shell',
### might not have any out of date modules...
'o' => '_uptodate',