Commit | Line | Data |
5bc5f6dc |
1 | ### the shell prints to STDOUT, so capture that here |
2 | ### and we can check the output |
494f1016 |
3 | ### make sure we can find our conf.pl file |
4 | BEGIN { |
5 | use FindBin; |
6 | require "$FindBin::Bin/inc/conf.pl"; |
7 | } |
8 | |
5bc5f6dc |
9 | ### this lets us capture output from the default shell |
10 | { no warnings 'redefine'; |
494f1016 |
11 | |
5bc5f6dc |
12 | my $out; |
13 | *CPANPLUS::Shell::Default::__print = sub { |
14 | my $self = shift; |
15 | $out .= "@_"; |
16 | }; |
494f1016 |
17 | |
5bc5f6dc |
18 | sub _out { $out } |
19 | sub _reset_out { $out = '' } |
20 | } |
494f1016 |
21 | |
5bc5f6dc |
22 | use strict; |
23 | use Test::More 'no_plan'; |
24 | use CPANPLUS::Internals::Constants; |
494f1016 |
25 | |
5879cbe1 |
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 | |
5bc5f6dc |
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; |
494f1016 |
39 | |
5bc5f6dc |
40 | |
494f1016 |
41 | ### basic load tests |
5bc5f6dc |
42 | use_ok( $Class, 'Default' ); |
494f1016 |
43 | is( $Class->which, SHELL_DEFAULT, |
44 | "Default shell loaded" ); |
45 | |
5bc5f6dc |
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 | |
5879cbe1 |
66 | my $base = $Conf->get_conf('base'); |
5bc5f6dc |
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 |
5879cbe1 |
97 | ### lower case path matching, as on VMS we can't predict case |
5bc5f6dc |
98 | "/? cs" => qr|/cs|, |
99 | "/cs --add $cs_uri" => qr/Added remote source/, |
5879cbe1 |
100 | "/cs --list" => do { my $re = quotemeta($cs_uri); qr/$re/i }, |
101 | "/cs --contents $cs_uri" => qr/$TestAuth/i, |
5bc5f6dc |
102 | "/cs --update" => qr/Updated remote sources/, |
103 | "/cs --update $cs_uri" => qr/Updated remote sources/, |
5879cbe1 |
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/, |
5bc5f6dc |
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 | |