[10672] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # (C) British Crown Copyright 2006-17 Met Office. |
---|
| 3 | # |
---|
| 4 | # This file is part of FCM, tools for managing and building source code. |
---|
| 5 | # |
---|
| 6 | # FCM is free software: you can redistribute it and/or modify |
---|
| 7 | # it under the terms of the GNU General Public License as published by |
---|
| 8 | # the Free Software Foundation, either version 3 of the License, or |
---|
| 9 | # (at your option) any later version. |
---|
| 10 | # |
---|
| 11 | # FCM is distributed in the hope that it will be useful, |
---|
| 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
| 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
| 14 | # GNU General Public License for more details. |
---|
| 15 | # |
---|
| 16 | # You should have received a copy of the GNU General Public License |
---|
| 17 | # along with FCM. If not, see <http://www.gnu.org/licenses/>. |
---|
| 18 | # ------------------------------------------------------------------------------ |
---|
| 19 | use strict; |
---|
| 20 | use warnings; |
---|
| 21 | |
---|
| 22 | # ------------------------------------------------------------------------------ |
---|
| 23 | package FCM::CLI; |
---|
| 24 | use base qw{FCM::Class::CODE}; |
---|
| 25 | |
---|
| 26 | use FCM::CLI::Exception; |
---|
| 27 | use FCM::CLI::Parser; |
---|
| 28 | use FCM::Context::Event; |
---|
| 29 | use FCM::System; |
---|
| 30 | use FindBin; |
---|
| 31 | use File::Basename qw{dirname}; |
---|
| 32 | use File::Spec::Functions qw{catfile rel2abs}; |
---|
| 33 | use Pod::Usage qw{pod2usage}; |
---|
| 34 | |
---|
| 35 | my $E = 'FCM::CLI::Exception'; |
---|
| 36 | our $EVENT; |
---|
| 37 | our $S; |
---|
| 38 | our %ACTION_OF = ( |
---|
| 39 | # Commands handled by FCM |
---|
| 40 | 'add' => _opt_func('check', sub {$S->cm_check_unknown(@_)}), |
---|
| 41 | 'branch' => \&_branch, |
---|
| 42 | 'branch-create' => _sys_func(sub {$S->cm_branch_create(@_)}), |
---|
| 43 | 'branch-delete' => _sys_func(sub {$S->cm_branch_delete(@_)}), |
---|
| 44 | 'branch-diff' => _sys_func(sub {$S->cm_branch_diff(@_)}), |
---|
| 45 | 'branch-info' => _sys_func(sub {$S->cm_branch_info(@_)}), |
---|
| 46 | 'branch-list' => _sys_func(sub {$S->cm_branch_list(@_)}), |
---|
| 47 | 'browse' => _sys_func(sub {$S->browse(@_)}), |
---|
| 48 | 'build' => _sys_func(sub {$S->build(@_)}), |
---|
| 49 | 'cfg-print' => _sys_func(sub {$S->config_parse(@_)}), |
---|
| 50 | 'checkout' => _sys_func(sub {$S->cm_checkout(@_)}), |
---|
| 51 | 'cmp-ext-cfg' => _sys_func(sub {$S->config_compare(@_)}), |
---|
| 52 | 'commit' => _sys_func(sub {$S->cm_commit(@_)}), |
---|
| 53 | 'conflicts' => _sys_func(sub {$S->cm_resolve_conflicts(@_)}), |
---|
| 54 | 'delete' => _opt_func('check', sub {$S->cm_check_missing(@_)}), |
---|
| 55 | 'diff' => _opt_func( |
---|
| 56 | 'branch', sub {$S->cm_branch_diff(@_)}, sub {$S->cm_diff(@_)}, |
---|
| 57 | ), |
---|
| 58 | 'export-items' => _sys_func(sub {$S->export_items(@_)}), |
---|
| 59 | 'extract' => _sys_func(sub {$S->extract(@_)}), |
---|
| 60 | 'gui' => \&_gui, |
---|
| 61 | 'help' => \&_help, |
---|
| 62 | 'keyword-print' => _sys_func(sub {$S->keyword_find(@_)}), |
---|
| 63 | 'loc-layout' => _sys_func(sub {$S->cm_loc_layout(@_)}), |
---|
| 64 | 'merge' => _sys_func(sub {$S->cm_merge(@_)}), |
---|
| 65 | 'mkpatch' => _sys_func(sub {$S->cm_mkpatch(@_)}), |
---|
| 66 | 'make' => _sys_func(sub {$S->make(@_)}), |
---|
| 67 | 'project-create'=> _sys_func(sub {$S->cm_project_create(@_)}), |
---|
| 68 | 'switch' => _opt_func( |
---|
| 69 | 'relocate', sub {$S->svn(@_)}, sub {$S->cm_switch(@_)}, |
---|
| 70 | ), |
---|
| 71 | 'test-battery' => \&_test_battery, |
---|
| 72 | 'update' => _sys_func(sub {$S->cm_update(@_)}), |
---|
| 73 | 'version' => \&_version, |
---|
| 74 | # Commands passed directly to "svn" |
---|
| 75 | map {($_ => _sys_func())} qw{ |
---|
| 76 | blame |
---|
| 77 | cat |
---|
| 78 | cleanup |
---|
| 79 | copy |
---|
| 80 | export |
---|
| 81 | import |
---|
| 82 | info |
---|
| 83 | list |
---|
| 84 | lock |
---|
| 85 | log |
---|
| 86 | mergeinfo |
---|
| 87 | mkdir |
---|
| 88 | move |
---|
| 89 | patch |
---|
| 90 | propdel |
---|
| 91 | propedit |
---|
| 92 | propget |
---|
| 93 | proplist |
---|
| 94 | propset |
---|
| 95 | relocate |
---|
| 96 | resolve |
---|
| 97 | resolved |
---|
| 98 | revert |
---|
| 99 | status |
---|
| 100 | unlock |
---|
| 101 | upgrade |
---|
| 102 | }, |
---|
| 103 | ); |
---|
| 104 | # List of overridden subcommands that need to display "svn help" |
---|
| 105 | our %CLI_MORE_HELP_FOR = map {($_, 1)} (qw{add delete diff switch update}); |
---|
| 106 | |
---|
| 107 | # Creates the class. |
---|
| 108 | __PACKAGE__->class( |
---|
| 109 | {'gui' => '$', 'parser' => 'FCM::CLI::Parser', 'system' => 'FCM::System'}, |
---|
| 110 | { init => sub { |
---|
| 111 | my $attrib_ref = shift(); |
---|
| 112 | $attrib_ref->{parser} ||= FCM::CLI::Parser->new(); |
---|
| 113 | $attrib_ref->{system} |
---|
| 114 | ||= FCM::System->new({'gui' => $attrib_ref->{'gui'}}); |
---|
| 115 | }, |
---|
| 116 | action_of => {main => \&_main}, |
---|
| 117 | }, |
---|
| 118 | ); |
---|
| 119 | |
---|
| 120 | # The main CLI action. |
---|
| 121 | sub _main { |
---|
| 122 | my ($attrib_ref, @argv) = @_; |
---|
| 123 | local($EVENT) = sub {$attrib_ref->{system}->util()->event(@_)}; |
---|
| 124 | my ($app, $option_ref, @args) = eval {$attrib_ref->{parser}->parse(@argv)}; |
---|
| 125 | if (my $e = $@) { |
---|
| 126 | _err($attrib_ref, \@argv, $e); |
---|
| 127 | } |
---|
| 128 | if (!$app || $option_ref->{help}) { |
---|
| 129 | return _help($attrib_ref, $app); |
---|
| 130 | } |
---|
| 131 | $option_ref ||= {}; |
---|
| 132 | my $q = $option_ref->{quiet} || 0; |
---|
| 133 | my $v = $option_ref->{verbose} || 0; |
---|
| 134 | my $reporter = $attrib_ref->{system}->util()->util_of_report(); |
---|
| 135 | my $verbosity = $reporter->DEFAULT + $v - $q; |
---|
| 136 | if (exists($ENV{FCM_DEBUG}) && $ENV{FCM_DEBUG} eq 'true') { |
---|
| 137 | $verbosity = $reporter->DEBUG; |
---|
| 138 | } |
---|
| 139 | $reporter->get_ctx_of_stderr()->set_verbosity($verbosity); |
---|
| 140 | $reporter->get_ctx_of_stdout()->set_verbosity($verbosity); |
---|
| 141 | my @context = eval { |
---|
| 142 | if (!exists($ACTION_OF{$app})) { |
---|
| 143 | return $E->throw($E->APP, \@argv); |
---|
| 144 | } |
---|
| 145 | $ACTION_OF{$app}->($attrib_ref, $app, $option_ref, @args); |
---|
| 146 | }; |
---|
| 147 | if (my $e = $@) { |
---|
| 148 | return _err($attrib_ref, \@argv, $e); |
---|
| 149 | } |
---|
| 150 | } |
---|
| 151 | |
---|
| 152 | # "fcm branch". |
---|
| 153 | sub _branch { |
---|
| 154 | my ($attrib_ref, $app, $option_ref, @args) = @_; |
---|
| 155 | my $method |
---|
| 156 | = exists($option_ref->{create}) ? 'cm_branch_create' |
---|
| 157 | : exists($option_ref->{delete}) ? 'cm_branch_delete' |
---|
| 158 | : exists($option_ref->{list}) ? 'cm_branch_list' |
---|
| 159 | : 'cm_branch_info' |
---|
| 160 | ; |
---|
| 161 | if ($option_ref->{create}) { |
---|
| 162 | if (!$option_ref->{name}) { |
---|
| 163 | return $E->throw($E->OPT, [$app, @args]); |
---|
| 164 | } |
---|
| 165 | my $name = delete($option_ref->{name}); |
---|
| 166 | unshift(@args, $name); |
---|
| 167 | } |
---|
| 168 | $attrib_ref->{system}->($method, $option_ref, @args); |
---|
| 169 | } |
---|
| 170 | |
---|
| 171 | # Handles FCM::Exception. |
---|
| 172 | sub _err { |
---|
| 173 | my ($attrib_ref, $argv_ref, $e) = @_; |
---|
| 174 | $EVENT->(FCM::Context::Event->E, $e) || die($e); |
---|
| 175 | die("\n"); |
---|
| 176 | } |
---|
| 177 | |
---|
| 178 | # "fcm gui". |
---|
| 179 | sub _gui { |
---|
| 180 | my ($attrib_ref, $app, $option_ref, @args) = @_; |
---|
| 181 | exec("$FindBin::Bin/fcm_gui", @args); |
---|
| 182 | } |
---|
| 183 | |
---|
| 184 | # Implements "fcm help" and usage. |
---|
| 185 | sub _help { |
---|
| 186 | my ($attrib_ref, $app, $option_ref, @args) = @_; |
---|
| 187 | $app ||= 'help'; |
---|
| 188 | my @keys = ($app eq 'help' && @args) ? @args : (q{}); |
---|
| 189 | for my $key (@keys) { |
---|
| 190 | if (exists($FCM::CLI::Parser::PREF_NAME_OF{$key})) { |
---|
| 191 | $key = $FCM::CLI::Parser::PREF_NAME_OF{$key}; |
---|
| 192 | } |
---|
| 193 | my $pod |
---|
| 194 | = $key ? catfile(dirname($INC{'FCM/CLI.pm'}), 'CLI', "fcm-$key.pod") |
---|
| 195 | : $0 |
---|
| 196 | ; |
---|
| 197 | if ($pod eq $0) { |
---|
| 198 | _version($attrib_ref, $app, $option_ref, @args); |
---|
| 199 | } |
---|
| 200 | my $has_pod = -f $pod; |
---|
| 201 | if ($has_pod) { |
---|
| 202 | my $reporter = $attrib_ref->{system}->util()->util_of_report(); |
---|
| 203 | my $verbosity = $reporter->get_ctx_of_stdout()->get_verbosity(); |
---|
| 204 | pod2usage({ |
---|
| 205 | '-exitval' => 'NOEXIT', |
---|
| 206 | '-input' => $pod, |
---|
| 207 | '-verbose' => $verbosity, |
---|
| 208 | }); |
---|
| 209 | } |
---|
| 210 | if (!$has_pod || exists($CLI_MORE_HELP_FOR{$key})) { |
---|
| 211 | $attrib_ref->{system}->svn('help', {}, $key ? $key : ()) |
---|
| 212 | } |
---|
| 213 | } |
---|
| 214 | return; |
---|
| 215 | } |
---|
| 216 | |
---|
| 217 | # "fcm test-battery". |
---|
| 218 | sub _test_battery { |
---|
| 219 | my ($attrib_ref, $app, $option_ref, @args) = @_; |
---|
| 220 | exec("$FindBin::Bin/fcm_test_battery", @args); |
---|
| 221 | } |
---|
| 222 | |
---|
| 223 | # Returns a function that select the alternate handler for the application. The |
---|
| 224 | # handler is either $method_id (if $opt_id is set) or "svn". |
---|
| 225 | sub _opt_func { |
---|
| 226 | my ($opt_id, $code0_ref, $code1_ref) = @_; |
---|
| 227 | $code0_ref = _sys_func($code0_ref); |
---|
| 228 | $code1_ref = _sys_func($code1_ref); |
---|
| 229 | sub { |
---|
| 230 | my ($attrib_ref, $app, $option_ref, @args) = @_; |
---|
| 231 | my $code_ref = exists($option_ref->{$opt_id}) ? $code0_ref : $code1_ref; |
---|
| 232 | $code_ref->($attrib_ref, $app, $option_ref, @args); |
---|
| 233 | }; |
---|
| 234 | } |
---|
| 235 | |
---|
| 236 | # Invokes a system function. |
---|
| 237 | sub _sys_func { |
---|
| 238 | my ($code_ref) = @_; |
---|
| 239 | sub { |
---|
| 240 | my ($attrib_ref, $app, @args) = @_; |
---|
| 241 | local($S) = $attrib_ref->{system}; |
---|
| 242 | defined($code_ref) ? $code_ref->(@args) : $S->svn($app, @args); |
---|
| 243 | }; |
---|
| 244 | } |
---|
| 245 | |
---|
| 246 | # Implements "fcm version". |
---|
| 247 | sub _version { |
---|
| 248 | my ($attrib_ref, $app, $option_ref, @args) = @_; |
---|
| 249 | my $version = $attrib_ref->{system}->util()->version(); |
---|
| 250 | $EVENT->(FCM::Context::Event->OUT, "FCM $version\n"); |
---|
| 251 | } |
---|
| 252 | |
---|
| 253 | # ------------------------------------------------------------------------------ |
---|
| 254 | 1; |
---|
| 255 | __END__ |
---|
| 256 | |
---|
| 257 | =head1 NAME |
---|
| 258 | |
---|
| 259 | FCM::CLI |
---|
| 260 | |
---|
| 261 | =head1 SYNOPSIS |
---|
| 262 | |
---|
| 263 | my $cli = FCM::CLI->new(); |
---|
| 264 | $cli->(@ARGV); |
---|
| 265 | |
---|
| 266 | =head1 DESCRIPTION |
---|
| 267 | |
---|
| 268 | An implementation of the FCM command line interface. |
---|
| 269 | |
---|
| 270 | =head1 METHODS |
---|
| 271 | |
---|
| 272 | =over 4 |
---|
| 273 | |
---|
| 274 | =item $class->new() |
---|
| 275 | |
---|
| 276 | Returns a new instance. |
---|
| 277 | |
---|
| 278 | =item $cli->(@ARGV) |
---|
| 279 | |
---|
| 280 | Determines the application using the first element in @ARGV, parses the options |
---|
| 281 | and arguments according to the application, and invokes the application. |
---|
| 282 | |
---|
| 283 | =back |
---|
| 284 | |
---|
| 285 | =head1 DIAGNOSTICS |
---|
| 286 | |
---|
| 287 | =head2 FCM::CLI::Exception |
---|
| 288 | |
---|
| 289 | This exception is thrown when the CLI fails to invoke an application. |
---|
| 290 | |
---|
| 291 | =head1 COPYRIGHT |
---|
| 292 | |
---|
| 293 | (C) Crown copyright Met Office. All rights reserved. |
---|
| 294 | |
---|
| 295 | =cut |
---|