source: branches/2015/dev_r5021_UKMO1_CICE_coupling/NEMOGCM/EXTERNAL/fcm/lib/Fcm/CLI/Subcommand.pm @ 5445

Last change on this file since 5445 was 5445, checked in by davestorkey, 5 years ago

Clear SVN keywords from 2015/dev_r5021_UKMO1_CICE_coupling branch.

File size: 6.3 KB
Line 
1# ------------------------------------------------------------------------------
2# (C) Crown copyright Met Office. All rights reserved.
3# For further details please refer to the file COPYRIGHT.txt
4# which you should have received as part of this distribution.
5# ------------------------------------------------------------------------------
6use strict;
7use warnings;
8
9package Fcm::CLI::Subcommand;
10
11use Carp qw{croak};
12use Fcm::CLI::Exception;
13use Fcm::Util::ClassLoader;
14
15################################################################################
16# Constructor
17sub new {
18    my ($class, $args_ref) = @_;
19    return bless({%{$args_ref}}, $class);
20}
21
22################################################################################
23# Methods: get_*
24for my $key (
25    # Returns the long description of this subcommand
26    'description',
27    # Returns the class of the invoker of this subcommand
28    'invoker_class',
29    # Returns the extra config to be given to the invoker of this subcommand
30    'invoker_config',
31    # Returns the names of this subcommand
32    'names',
33    # Returns the options of this subcommand
34    'options',
35    # Returns the synopsis of this subcommand
36    'synopsis',
37    # Returns the usage of this subcommand
38    'usage',
39) {
40    no strict qw{refs};
41    my $getter = "get_$key";
42    *$getter = sub {
43        my ($self) = @_;
44        if (defined($self->{$key})) {
45            if (ref($self->{$key}) eq 'ARRAY') {
46                return (wantarray() ? @{$self->{$key}} : $self->{$key});
47            }
48            else {
49                return $self->{$key};
50            }
51        }
52        else {
53            return;
54        }
55    }
56}
57
58################################################################################
59# Returns true if this subcommand represents a command in the CM sub-system
60sub is_vc {
61    my ($self) = @_;
62    return $self->{is_vc};
63}
64
65################################################################################
66# Returns true if $string matches a name of this subcommand
67sub has_a_name {
68    my ($self, $string) = @_;
69    if ($self->get_names() && ref($self->get_names()) eq 'ARRAY') {
70        my %name_of = map {$_, 1} @{$self->get_names()};
71        return exists($name_of{$string});
72    }
73    else {
74        return;
75    }
76}
77
78################################################################################
79# Invokes this subcommand based on current @ARGV
80sub get_invoker {
81    my ($self, $command) = @_;
82    my %options = ();
83    if (($self->get_options())) {
84        my $problem = q{};
85        local($SIG{__WARN__}) = sub {
86            ($problem) = @_;
87        };
88        my $success = GetOptions(
89            \%options,
90            (map {$_->get_arg_for_getopt_long()} ($self->get_options())),
91        );
92        if (!$success) {
93            croak(Fcm::CLI::Exception->new({message => sprintf(
94                "%s: option parse failed: %s", $command, $problem,
95            )}));
96        }
97    }
98    my $invoker_class
99        = $self->get_invoker_class() ? $self->get_invoker_class()
100        :                              'Fcm::CLI::Invoker'
101        ;
102    Fcm::Util::ClassLoader::load($invoker_class);
103    my $invoker = $invoker_class->new({
104        command   => $command,
105        options   => \%options,
106        arguments => [@ARGV],
107    });
108    return $invoker;
109}
110
111################################################################################
112# Returns a simple string representation of this subcommand
113sub as_string {
114    my ($self) = @_;
115    # FIXME: can do with using Text::Template or Perl6::Form
116    if (
117           $self->get_names()
118        && ref($self->get_names()) eq 'ARRAY'
119        && @{$self->get_names()}
120    ) {
121        my @names = $self->get_names();
122        my $return = $names[0];
123        for my $i (1 .. $#names) {
124            if ($names[$i]) {
125                $return
126                    .= $i == 1       ? q{ (} . $names[$i]
127                    :                  q{, } . $names[$i]
128                    ;
129            }
130            if ($i == $#names) {
131                $return .= q{)};
132            }
133        }
134        return $return;
135    }
136    else {
137        return q{};
138    }
139}
140
1411;
142__END__
143
144=head1 NAME
145
146Fcm::CLI::Subcommand
147
148=head1 SYNOPSIS
149
150    use Fcm::CLI::Subcommand;
151    $subcommand = Fcm::CLI::Subcommand->new({
152        names          => ['build', 'bld'],
153        options        => [
154            Fcm::CLI::Option->new(
155                # ... some arguments ...
156            ),
157            # ... more options
158        ],
159        synopsis       => 'invokes the build system',
160        description    => $description,
161        usage          => '[OPTIONS] [CONFIG]',
162        invoker_class  => $invoker_class,
163        invoker_config => {
164            option1 => $option1,
165            # ... more options
166        },
167    });
168    $boolean = $subcommand->has_a_name($string);
169    $invoker_class = $subcommand->get_invoker_class();
170
171=head1 DESCRIPTION
172
173An object of this class is used to store the configuration of a subcommand of
174the FCM CLI.
175
176=head1 METHODS
177
178=over 4
179
180=item new($args_ref)
181
182Constructor.
183
184=item get_description()
185
186Returns the long description of this subcommand.
187
188=item get_invoker_class()
189
190Returns the invoker class of this subcommand, which should be a sub-class of
191L<Fcm::CLI::Invoker|Fcm::CLI::Invoker>.
192
193=item get_invoker_cconfig()
194
195Returns a reference to a hash containing the extra configuration to be given to
196the constructor of the invoker of this subcommand.
197
198=item get_names()
199
200Returns an array containing the names of this subcommand.
201
202=item get_options()
203
204Returns an array containing the options of this subcommand. Each element of
205the array should be a L<Fcm::CLI::Option|Fcm::CLI::Option> object.
206
207=item get_synopsis()
208
209Returns a short synopsis of this subcommand.
210
211=item get_usage()
212
213Returns a short usage statement of this subcommand.
214
215=item is_vc()
216
217Returns true if this subcommand represents commands in the underlying VC system.
218
219=item has_a_name($string)
220
221Returns true if a name in C<$self-E<gt>get_names()> matches $string.
222
223=back
224
225=head1 DIAGNOSTICS
226
227=over 4
228
229=item L<Fcm::CLI::Exception|Fcm::CLI::Exception>
230
231The invoke() method may croak() with this exception.
232
233=back
234
235=head1 SEE ALSO
236
237L<Fcm::CLI::Exception|Fcm::CLI::Exception>,
238L<Fcm::CLI::Invoker|Fcm::CLI::Invoker>,
239L<Fcm::CLI::Option|Fcm::CLI::Option>
240
241=head1 COPYRIGHT
242
243E<169> Crown copyright Met Office. All rights reserved.
244
245=cut
Note: See TracBrowser for help on using the repository browser.