source: branches/2015/dev_r5021_UKMO1_CICE_coupling/NEMOGCM/EXTERNAL/fcm/lib/Fcm/CLI.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: 4.8 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;
10
11use Carp qw{croak};
12use Fcm::CLI::Config;
13use Fcm::CLI::Exception;
14use Fcm::Util::ClassLoader;
15use File::Basename qw{basename};
16use Getopt::Long qw{GetOptions};
17use Scalar::Util qw{blessed};
18
19################################################################################
20# Invokes the FCM command line interface
21sub invoke {
22    local(@ARGV) = @ARGV;
23    my $config          = Fcm::CLI::Config->instance();
24    my $subcommand_name = @ARGV ? shift(@ARGV) : q{};
25    my $subcommand      = $config->get_subcommand_of($subcommand_name);
26    eval {
27        if (!$subcommand) {
28            croak(Fcm::CLI::Exception->new({message => 'unknown command'}));
29        }
30        my ($opts_ref, $args_ref, $is_help) = _parse_argv_using($subcommand);
31        my ($invoker_class, $invoker);
32        if ($is_help) {
33            $invoker_class
34                = _load_invoker_class_of($config->get_subcommand_of(q{}));
35            $invoker = $invoker_class->new({
36                command   => $subcommand_name,
37                arguments => [$subcommand_name],
38            });
39        }
40        else {
41            $invoker_class = _load_invoker_class_of($subcommand);
42            $invoker = $invoker_class->new({
43                command   => $subcommand_name,
44                options   => $opts_ref,
45                arguments => $args_ref,
46                (
47                    $subcommand->get_invoker_config()
48                    ? %{$subcommand->get_invoker_config()}
49                    : ()
50                ),
51            });
52        }
53        $invoker->invoke();
54    };
55    if ($@) {
56        if (Fcm::CLI::Exception->caught($@)) {
57            die(sprintf(
58                qq{%s%s: %s\nType "%s help%s" for usage\n},
59                basename($0),
60                ($subcommand_name ? qq{ $subcommand_name} : q{}),
61                $@->get_message(),
62                basename($0),
63                defined($subcommand) ? qq{ $subcommand_name} : q{},
64            ));
65        }
66        else {
67            die($@);
68        }
69    }
70}
71
72################################################################################
73# Parses options in @ARGV using the options settings of a subcommand
74sub _parse_argv_using {
75    my ($subcommand) = @_;
76    my %options = ();
77    my $is_help = undef;
78    if (($subcommand->get_options())) {
79        my $problem = q{};
80        local($SIG{__WARN__}) = sub {
81            ($problem) = @_;
82        };
83        my $success = GetOptions(
84            \%options,
85            (map {$_->get_arg_for_getopt_long()} ($subcommand->get_options())),
86        );
87        if (!$success) {
88            croak(Fcm::CLI::Exception->new({message => sprintf(
89                "option parse failed: %s", $problem,
90            )}));
91        }
92
93        OPTION:
94        for my $option ($subcommand->get_options()) {
95            if (!exists($options{$option->get_name()})) {
96                next OPTION;
97            }
98            if ($option->is_help()) {
99                $is_help = 1;
100            }
101            if (
102                $option->has_arg() == $option->ARRAY_ARG
103                && $option->get_delimiter()
104            ) {
105                $options{$option->get_name()} = [split(
106                    $option->get_delimiter(),
107                    join(
108                        $option->get_delimiter(),
109                        @{$options{$option->get_name()}},
110                    ),
111                )];
112            }
113        }
114    }
115    return (\%options, [@ARGV], $is_help);
116}
117
118################################################################################
119# Loads and returns the invoker class of a subcommand
120sub _load_invoker_class_of {
121    my ($subcommand) = @_;
122    my $invoker_class
123        = $subcommand->get_invoker_class() ? $subcommand->get_invoker_class()
124        :                                    'Fcm::CLI::Invoker'
125        ;
126    return Fcm::Util::ClassLoader::load($invoker_class);
127}
128
1291;
130__END__
131
132=head1 NAME
133
134Fcm::CLI
135
136=head1 SYNOPSIS
137
138    use Fcm::CLI
139    Fcm::CLI::invoke();
140
141=head1 DESCRIPTION
142
143Invokes the FCM command line interface.
144
145=head1 FUNCTIONS
146
147=over 4
148
149=item invoke()
150
151Invokes the FCM command line interface.
152
153=back
154
155=head1 TO DO
156
157Move option/argument parsing to L<Fcm::CLI::Invoker|Fcm::CLI::Invoker>?
158
159Use an OO interface?
160
161=head1 SEE ALSO
162
163L<Fcm::CLI::Config|Fcm::CLI::Config>,
164L<Fcm::CLI::Invoker|Fcm::CLI::Invoker>,
165L<Fcm::CLI::Subcommand|Fcm::CLI::Subcommand>,
166L<Fcm::CLI::Option|Fcm::CLI::Option>
167
168=head1 COPYRIGHT
169
170E<169> Crown copyright Met Office. All rights reserved.
171
172=cut
Note: See TracBrowser for help on using the repository browser.