ext/CPANPLUS/t/15_CPANPLUS-Shell.t

   1 ### the shell prints to STDOUT, so capture that here
   2 ### and we can check the output
   3 ### make sure we can find our conf.pl file
   4 BEGIN {
   5     use FindBin;
   6     require "$FindBin::Bin/inc/conf.pl";
   7 }
   8
   9 ### this lets us capture output from the default shell
  10 {   no warnings 'redefine';
  11
  12     my $out;
  13     *CPANPLUS::Shell::Default::__print = sub {
  14         my $self = shift;
  15         $out .= "@_";
  16     };
  17
  18     sub _out        { $out }
  19     sub _reset_out  { $out = '' }
  20 }
  21
  22 use strict;
  23 use Test::More      'no_plan';
  24 use CPANPLUS::Internals::Constants;
  25
  26 ### in some subprocesses, the Term::ReadKey code will go
  27 ### balistic and die because it can't figure out terminal
  28 ### dimensions. If we add these env vars, it'll use them
  29 ### as a default and not die. Thanks to Slaven Rezic for
  30 ### reporting this.
  31 local $ENV{'COLUMNS'} = 80 unless $ENV{'COLUMNS'};
  32 local $ENV{'LINES'}   = 40 unless $ENV{'LINES'};
  33
  34 my $Conf    = gimme_conf();
  35 my $Class   = 'CPANPLUS::Shell';
  36 my $Default = SHELL_DEFAULT;
  37 my $TestMod = TEST_CONF_MODULE;
  38 my $TestAuth= TEST_CONF_AUTHOR;
  39
  40
  41 ### basic load tests
  42 use_ok( $Class, 'Default' );
  43 is( $Class->which,  SHELL_DEFAULT,
  44                                 "Default shell loaded" );
  45
  46 ### create an object
  47 my $Shell = $Class->new( $Conf );
  48 ok( $Shell,                     "   New object created" );
  49 isa_ok( $Shell, $Default,       "   Object" );
  50
  51 ### method tests
  52 {
  53     ### uri to use for /cs tests
  54     my $cs_path = File::Spec->rel2abs(
  55                         File::Spec->catfile(
  56                             $FindBin::Bin,
  57                             TEST_CONF_CPAN_DIR,
  58                         )
  59                     );
  60     my $cs_uri = $Shell->backend->_host_to_uri(
  61                         scheme  => 'file',
  62                         host    => '',
  63                         path    => $cs_path,
  64                     );
  65
  66     my $base = $Conf->get_conf('base');
  67
  68     ### XXX have to keep the list ordered, as some methods only work as
  69     ### expected *after* others have run
  70     my @map = (
  71         'v'                     => qr/CPANPLUS/,
  72         '! $self->__print($$)'  => qr/$$/,
  73         '?'                     => qr/\[General\]/,
  74         'h'                     => qr/\[General\]/,
  75         's'                     => qr/Unknown type/,
  76         's conf'                => qr/$Default/,
  77         's program'             => qr/sudo/,
  78         's mirrors'             => do { my $re = TEST_CONF_CPAN_DIR; qr/$re/ },
  79         's selfupdate'          => qr/selfupdate/,
  80         'b'                     => qr/autobundle/,
  81         "a $TestAuth"           => qr/$TestAuth/,
  82         "m $TestMod"            => qr/$TestMod/,
  83         "w"                     => qr/$TestMod/,
  84         "r 1"                   => qr/README/,
  85         "r $TestMod"            => qr/README/,
  86         "f $TestMod"            => qr/$TestAuth/,
  87         "d $TestMod"            => qr/$TestMod/,
  88         ### XXX this one prints to stdout in a subprocess -- skipping this
  89         ### for now due to possible PERL_CORE issues
  90         #"t $TestMod"            => qr/$TestMod.*tested successfully/i,
  91         "l $TestMod"            => qr/$TestMod/,
  92         '! die $$; p'           => qr/$$/,
  93         '/plugins'              => qr/Available plugins:/i,
  94         '/? ?'                  => qr/usage/i,
  95
  96         ### custom source plugin tests
  97         ### lower case path matching, as on VMS we can't predict case
  98         "/? cs"                  => qr|/cs|,
  99         "/cs --add $cs_uri"      => qr/Added remote source/,
 100         "/cs --list"             => do { my $re = quotemeta($cs_uri); qr/$re/i },
 101         "/cs --contents $cs_uri" => qr/$TestAuth/i,
 102         "/cs --update"           => qr/Updated remote sources/,
 103         "/cs --update $cs_uri"   => qr/Updated remote sources/,
 104
 105         ### --write leaves a file that we should clean up, so make
 106         ### sure it's in the path that we clean up already anyway
 107         "/cs --write $base"      => qr/Wrote remote source index/,
 108         "/cs --remove $cs_uri"   => qr/Removed remote source/,
 109     );
 110
 111     my $meth = 'dispatch_on_input';
 112     can_ok( $Shell, $meth );
 113
 114     while( my($input,$out_re) = splice(@map, 0, 2) ) {
 115
 116         ### empty output cache
 117         __PACKAGE__->_reset_out;
 118         CPANPLUS::Error->flush;
 119
 120         ok( 1,                  "Testing '$input'" );
 121         $Shell->$meth( input => $input );
 122
 123         my $out = __PACKAGE__->_out;
 124
 125         ### XXX remove me
 126         #diag( $out );
 127
 128         ok( $out,               "   Output received" );
 129         like( $out, $out_re,    "   Output matches '$out_re'" );
 130     }
 131 }
 132
 133 __END__
 134
 135 #### test seperately, they have side effects
 136 'q'                     => qr/^$/,          # no output!
 137 's save boxed'          => do { my $re = CONFIG_BOXED;       qr/$re/ },
 138 ### this doens't write any output
 139 'x --update_source'     => qr/module tree/i,
 140 s edit
 141 s reconfigure
 142 'c'     => '_reports',
 143 'i'     => '_install',
 144 'u'     => '_uninstall',
 145 'z'     => '_shell',
 146 ### might not have any out of date modules...
 147 'o'     => '_uptodate',
 148
 149