[1980] | 1 | #!/usr/bin/perl |
---|
| 2 | |
---|
| 3 | use strict; |
---|
| 4 | use warnings; |
---|
| 5 | |
---|
| 6 | |
---|
| 7 | ################################################################################ |
---|
| 8 | # A sub-class of Fcm::CLI::Invoker for testing |
---|
| 9 | { |
---|
| 10 | package TestInvoker; |
---|
| 11 | use base qw{Fcm::CLI::Invoker}; |
---|
| 12 | |
---|
| 13 | our $LATEST_INSTANCE; |
---|
| 14 | |
---|
| 15 | ############################################################################ |
---|
| 16 | # Returns a test attrib |
---|
| 17 | sub get_test_attrib { |
---|
| 18 | my ($self) = @_; |
---|
| 19 | return $self->{test_attrib}; |
---|
| 20 | } |
---|
| 21 | |
---|
| 22 | ############################################################################ |
---|
| 23 | # Invokes the sub-system |
---|
| 24 | sub invoke { |
---|
| 25 | my ($self) = @_; |
---|
| 26 | $LATEST_INSTANCE = $self; |
---|
| 27 | } |
---|
| 28 | } |
---|
| 29 | |
---|
| 30 | use Fcm::CLI::Config; |
---|
| 31 | use Fcm::CLI::Subcommand; |
---|
| 32 | use Test::More (tests => 25); |
---|
| 33 | |
---|
| 34 | main(); |
---|
| 35 | |
---|
| 36 | sub main { |
---|
| 37 | use_ok('Fcm::CLI'); |
---|
| 38 | test_invalid_subcommand(); |
---|
| 39 | test_invoker_not_implemented(); |
---|
| 40 | test_normal_invoke(); |
---|
| 41 | test_help_invoke(); |
---|
| 42 | test_get_invoker_normal(); |
---|
| 43 | test_load_invoker_class(); |
---|
| 44 | } |
---|
| 45 | |
---|
| 46 | ################################################################################ |
---|
| 47 | # Tests to ensure that an invalid subcommand results in an exception |
---|
| 48 | sub test_invalid_subcommand { |
---|
| 49 | Fcm::CLI::Config->instance({core_subcommands => [], vc_subcommands => []}); |
---|
| 50 | eval { |
---|
| 51 | local(@ARGV) = ('foo'); |
---|
| 52 | Fcm::CLI::invoke(); |
---|
| 53 | }; |
---|
| 54 | like($@, qr{foo: unknown command}, 'invalid subcommand'); |
---|
| 55 | } |
---|
| 56 | |
---|
| 57 | ################################################################################ |
---|
| 58 | # Tests to ensure that an unimplemented invoker results in an exception |
---|
| 59 | sub test_invoker_not_implemented { |
---|
| 60 | Fcm::CLI::Config->instance({ |
---|
| 61 | core_subcommands => [ |
---|
| 62 | Fcm::CLI::Subcommand->new({names => ['foo']}), |
---|
| 63 | Fcm::CLI::Subcommand->new({ |
---|
| 64 | names => ['bar'], invoker_class => 'barley', |
---|
| 65 | }), |
---|
| 66 | ], |
---|
| 67 | vc_subcommands => [], |
---|
| 68 | }); |
---|
| 69 | eval { |
---|
| 70 | local(@ARGV) = ('foo'); |
---|
| 71 | Fcm::CLI::invoke(); |
---|
| 72 | }; |
---|
| 73 | like($@, qr{foo: \s command \s not \s implemented}xms, 'not implemented'); |
---|
| 74 | eval { |
---|
| 75 | local(@ARGV) = ('bar'); |
---|
| 76 | Fcm::CLI::invoke(); |
---|
| 77 | }; |
---|
| 78 | like($@, qr{barley: \s class \s loading \s failed}xms, 'not implemented'); |
---|
| 79 | } |
---|
| 80 | |
---|
| 81 | ################################################################################ |
---|
| 82 | # Tests normal usage of invoke |
---|
| 83 | sub test_normal_invoke { |
---|
| 84 | my $prefix = "normal invoke"; |
---|
| 85 | Fcm::CLI::Config->instance({ |
---|
| 86 | core_subcommands => [ |
---|
| 87 | Fcm::CLI::Subcommand->new({ |
---|
| 88 | names => ['foo'], |
---|
| 89 | invoker_class => 'TestInvoker', |
---|
| 90 | invoker_config => {test_attrib => 'test_attrib value'}, |
---|
| 91 | }), |
---|
| 92 | ], |
---|
| 93 | vc_subcommands => [], |
---|
| 94 | }); |
---|
| 95 | ok(!$TestInvoker::LATEST_INSTANCE, "$prefix: invoker not called"); |
---|
| 96 | local(@ARGV) = ('foo', 'bar', 'baz'); |
---|
| 97 | Fcm::CLI::invoke(); |
---|
| 98 | my $invoker = $TestInvoker::LATEST_INSTANCE; |
---|
| 99 | if (!$invoker) { |
---|
| 100 | fail($prefix); |
---|
| 101 | } |
---|
| 102 | else { |
---|
| 103 | is($invoker->get_command(), 'foo', "$prefix: invoker command"); |
---|
| 104 | is_deeply({$invoker->get_options()}, {}, "$prefix: invoker options"); |
---|
| 105 | is_deeply([$invoker->get_arguments()], ['bar', 'baz'], |
---|
| 106 | "$prefix: invoker arguments"); |
---|
| 107 | is($invoker->get_test_attrib(), 'test_attrib value', |
---|
| 108 | "$prefix: invoker test attrib"); |
---|
| 109 | } |
---|
| 110 | $TestInvoker::LATEST_INSTANCE = undef; |
---|
| 111 | } |
---|
| 112 | |
---|
| 113 | ################################################################################ |
---|
| 114 | # Tests help usage of invoke |
---|
| 115 | sub test_help_invoke { |
---|
| 116 | my $prefix = "help invoke"; |
---|
| 117 | Fcm::CLI::Config->instance({ |
---|
| 118 | core_subcommands => [ |
---|
| 119 | Fcm::CLI::Subcommand->new({ |
---|
| 120 | names => ['foo'], |
---|
| 121 | invoker_class => 'TestInvoker', |
---|
| 122 | invoker_config => {test_attrib => 'test_attrib value normal'}, |
---|
| 123 | options => [ |
---|
| 124 | Fcm::CLI::Option->new({name => 'foo', is_help => 1}), |
---|
| 125 | ], |
---|
| 126 | }), |
---|
| 127 | Fcm::CLI::Subcommand->new({ |
---|
| 128 | names => [q{}], |
---|
| 129 | invoker_class => 'TestInvoker', |
---|
| 130 | }), |
---|
| 131 | ], |
---|
| 132 | vc_subcommands => [], |
---|
| 133 | }); |
---|
| 134 | ok(!$TestInvoker::LATEST_INSTANCE, "$prefix: invoker not called"); |
---|
| 135 | local(@ARGV) = ('foo', '--foo'); |
---|
| 136 | Fcm::CLI::invoke(); |
---|
| 137 | my $invoker = $TestInvoker::LATEST_INSTANCE; |
---|
| 138 | if (!$invoker) { |
---|
| 139 | fail($prefix); |
---|
| 140 | } |
---|
| 141 | else { |
---|
| 142 | is_deeply([$invoker->get_arguments()], ['foo'], |
---|
| 143 | "$prefix: invoker argument"); |
---|
| 144 | } |
---|
| 145 | $TestInvoker::LATEST_INSTANCE = undef; |
---|
| 146 | } |
---|
| 147 | |
---|
| 148 | ################################################################################ |
---|
| 149 | # Tests getting an invoker |
---|
| 150 | sub test_get_invoker_normal { |
---|
| 151 | my $prefix = 'get invoker normal'; |
---|
| 152 | my @options = ( |
---|
| 153 | Fcm::CLI::Option->new({name => 'foo'}), |
---|
| 154 | Fcm::CLI::Option->new({name => 'bar'}), |
---|
| 155 | Fcm::CLI::Option->new({name => 'baz'}), |
---|
| 156 | Fcm::CLI::Option->new({ |
---|
| 157 | name => q{pork}, |
---|
| 158 | delimiter => q{,}, |
---|
| 159 | has_arg => Fcm::CLI::Option->ARRAY_ARG, |
---|
| 160 | }), |
---|
| 161 | ); |
---|
| 162 | my $subcommand = Fcm::CLI::Subcommand->new({options => \@options}); |
---|
| 163 | my %TEST = ( |
---|
| 164 | test1 => { |
---|
| 165 | argv => ['--foo', '--bar', 'egg', 'ham', 'sausage'], |
---|
| 166 | command => 'command', |
---|
| 167 | options => {foo => 1, bar => 1}, |
---|
| 168 | arguments => ['egg', 'ham', 'sausage'], |
---|
| 169 | }, |
---|
| 170 | test2 => { |
---|
| 171 | argv => ['--baz', '--foo', '--bar'], |
---|
| 172 | command => 'test', |
---|
| 173 | options => {foo => 1, bar => 1, baz => 1}, |
---|
| 174 | arguments => [], |
---|
| 175 | }, |
---|
| 176 | test3 => { |
---|
| 177 | argv => ['egg', 'ham', 'sausage'], |
---|
| 178 | command => 'meal', |
---|
| 179 | options => {}, |
---|
| 180 | arguments => ['egg', 'ham', 'sausage'], |
---|
| 181 | }, |
---|
| 182 | test4 => { |
---|
| 183 | argv => ['--pork', 'ham', '--pork', 'sausage'], |
---|
| 184 | command => 'pig', |
---|
| 185 | options => {pork => ['ham', 'sausage']}, |
---|
| 186 | arguments => [], |
---|
| 187 | }, |
---|
| 188 | test5 => { |
---|
| 189 | argv => ['--pork', 'ham,sausage', '--pork', 'bacon', 'liver'], |
---|
| 190 | command => 'pig', |
---|
| 191 | options => {pork => ['ham', 'sausage', 'bacon']}, |
---|
| 192 | arguments => ['liver'], |
---|
| 193 | }, |
---|
| 194 | ); |
---|
| 195 | for my $key (keys(%TEST)) { |
---|
| 196 | local(@ARGV) = @{$TEST{$key}{argv}}; |
---|
| 197 | my ($opts_ref, $args_ref) = Fcm::CLI::_parse_argv_using($subcommand); |
---|
| 198 | is_deeply($opts_ref, $TEST{$key}{options}, |
---|
| 199 | "$prefix $key: get options"); |
---|
| 200 | is_deeply($args_ref, $TEST{$key}{arguments}, |
---|
| 201 | "$prefix $key: get arguments"); |
---|
| 202 | } |
---|
| 203 | my %BAD_TEST = ( |
---|
| 204 | test1 => { |
---|
| 205 | argv => ['--egg', '--bar', 'foo', 'ham', 'sausage'], |
---|
| 206 | }, |
---|
| 207 | test2 => { |
---|
| 208 | argv => ['--foo=egg'], |
---|
| 209 | }, |
---|
| 210 | ); |
---|
| 211 | for my $key (keys(%BAD_TEST)) { |
---|
| 212 | local(@ARGV) = @{$BAD_TEST{$key}{argv}}; |
---|
| 213 | eval { |
---|
| 214 | Fcm::CLI::_parse_argv_using($subcommand); |
---|
| 215 | }; |
---|
| 216 | isa_ok($@, 'Fcm::CLI::Exception', "$prefix $key"); |
---|
| 217 | } |
---|
| 218 | } |
---|
| 219 | |
---|
| 220 | ################################################################################ |
---|
| 221 | # Tests loading an invoker with a different class |
---|
| 222 | sub test_load_invoker_class { |
---|
| 223 | my $prefix = 'get invoker class'; |
---|
| 224 | eval { |
---|
| 225 | my $subcommand = Fcm::CLI::Subcommand->new({invoker_class => 'foo'}); |
---|
| 226 | Fcm::CLI::_load_invoker_class_of($subcommand); |
---|
| 227 | }; |
---|
| 228 | isa_ok($@, 'Fcm::Exception', "$prefix"); |
---|
| 229 | |
---|
| 230 | my $invoker_class = 'Fcm::CLI::Invoker::ConfigSystem'; |
---|
| 231 | my $subcommand |
---|
| 232 | = Fcm::CLI::Subcommand->new({invoker_class => $invoker_class}); |
---|
| 233 | my $class = Fcm::CLI::_load_invoker_class_of($subcommand); |
---|
| 234 | is($class, $invoker_class, "$prefix: $invoker_class"); |
---|
| 235 | } |
---|
| 236 | |
---|
| 237 | __END__ |
---|