New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Parser.pm in vendors/lib/FCM/CLI – NEMO

source: vendors/lib/FCM/CLI/Parser.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing
File size: 16.0 KB
Line 
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# ------------------------------------------------------------------------------
19use strict;
20use warnings;
21
22# ------------------------------------------------------------------------------
23package FCM::CLI::Parser;
24use base qw{FCM::Class::CODE};
25
26use FCM::CLI::Exception;
27use Getopt::Long qw{GetOptions :config bundling};
28
29use constant {
30    OPT_INCR => q{+},   # no argument, but incremental
31    OPT_BOOL => q{},    # no argument
32    OPT_SCAL => q{=s},  # single argument
33    OPT_LIST => q{=s@}, # multiple argument
34};
35
36# Option hash, key = preferred name of option, value = HASH reference where:
37# arg     => argument flag
38# letters => ARRAY reference of a list of option letters
39# names   => ARRAY reference of a list of names
40our %OPTION_OF = map {
41    ($_->[0][0], {arg => $_->[2], letters => $_->[1], names => $_->[0]});
42} (
43    [['archive'            ,            ], ['a'], OPT_BOOL],
44    [['auto-log'           ,            ], [   ], OPT_BOOL],
45    [['branch'             ,            ], ['b'], OPT_BOOL],
46    [['branch-of-branch'   , 'bob'      ], [   ], OPT_BOOL],
47    [['browser'            ,            ], ['b'], OPT_SCAL],
48    [['check'              ,            ], ['c'], OPT_BOOL],
49    [['clean'              ,            ], [   ], OPT_BOOL],
50    [['create'             ,            ], ['c'], OPT_BOOL],
51    [['config-file'        , 'file'     ], ['f'], OPT_LIST],
52    [['config-file-path'   ,            ], ['F'], OPT_LIST],
53    [['custom'             ,            ], [   ], OPT_BOOL],
54    [['delete'             ,            ], ['d'], OPT_BOOL],
55    [['diff-cmd'           ,            ], [   ], OPT_SCAL],
56    [['directory'          ,            ], ['C'], OPT_SCAL],
57    [['dry-run'            ,            ], [   ], OPT_BOOL],
58    [['exclude'            ,            ], [   ], OPT_LIST],
59    [['extensions'         ,            ], ['x'], OPT_SCAL],
60    [['graphical'          ,            ], ['g'], OPT_BOOL],
61    [['fcm1'               ,            ], ['1'], OPT_BOOL],
62    [['full'               ,            ], ['f'], OPT_BOOL],
63    [['help'               , 'usage'    ], ['h'], OPT_BOOL],
64    [['ignore-lock'        ,            ], [   ], OPT_BOOL],
65    [['info'               ,            ], ['i'], OPT_BOOL],
66    [['jobs'               ,            ], ['j'], OPT_SCAL],
67    [['list'               ,            ], ['l'], OPT_BOOL],
68    [['name'               ,            ], ['n'], OPT_SCAL],
69    [['new'                ,            ], ['N'], OPT_BOOL],
70    [['non-interactive'    ,            ], [   ], OPT_BOOL],
71    [['only'               ,            ], [   ], OPT_LIST],
72    [['organisation'       ,            ], [   ], OPT_SCAL],
73    [['password'           ,            ], [   ], OPT_SCAL],
74    [['quiet'              ,            ], ['q'], OPT_INCR],
75    [['relocate'           ,            ], [   ], OPT_BOOL],
76    [['reverse'            ,            ], [   ], OPT_BOOL],
77    [['revision'           ,            ], ['r'], OPT_SCAL],
78    [['rev-flag'           ,            ], [   ], OPT_SCAL],
79    [['show-all'           ,            ], ['a'], OPT_BOOL],
80    [['show-children'      ,            ], [   ], OPT_BOOL],
81    [['show-other'         ,            ], [   ], OPT_BOOL],
82    [['show-siblings'      ,            ], [   ], OPT_BOOL],
83    [['stage'              ,            ], ['s'], OPT_SCAL],
84    [['summarize'          , 'summarise'], [   ], OPT_BOOL],
85    [['svn-non-interactive',            ], [   ], OPT_BOOL],
86    [['switch'             ,            ], ['s'], OPT_BOOL],
87    [['targets'            ,            ], ['t'], OPT_LIST],
88    [['ticket'             ,            ], ['k'], OPT_LIST],
89    [['trac'               ,            ], ['t'], OPT_BOOL],
90    [['type'               ,            ], ['t'], OPT_SCAL],
91    [['url'                ,            ], [   ], OPT_BOOL],
92    [['user'               ,            ], ['u'], OPT_LIST],
93    [['verbose'            ,            ], ['v'], OPT_INCR],
94    [['verbosity'          ,            ], ['v'], OPT_SCAL],
95    [['wiki'               ,            ], ['w'], OPT_BOOL],
96    [['wiki-format'        , 'wiki'     ], ['w'], OPT_SCAL],
97    [['xml'                ,            ], [   ], OPT_BOOL],
98);
99# Hook command before parsing the options
100our %HOOK_BEFORE_FOR = (
101    'add'    => _get_code_to_match($OPTION_OF{check}),
102    'delete' => _get_code_to_match($OPTION_OF{check}),
103    'diff'   => sub {
104        _get_code_to_replace(
105            $OPTION_OF{graphical}, [qw{
106                --config-option config:working-copy:exclusive-locking-clients=
107                --diff-cmd fcm_graphic_diff
108            }]
109        )->(@_);
110        _get_code_to_replace($OPTION_OF{summarize}, ['--summarize'])->(@_);
111        _get_code_to_match($OPTION_OF{branch})->(@_);
112    },
113    'switch' => sub {!_get_code_to_match($OPTION_OF{relocate})->(@_)},
114);
115our $HELP_APP = 'help';
116# Options for known applications
117our %OPTIONS_FOR = (
118    'add'           => [$OPTION_OF{check}],
119    'branch'        => [@OPTION_OF{
120        qw{ branch-of-branch create delete info list name non-interactive
121            password quiet revision rev-flag show-all show-children
122            show-siblings svn-non-interactive ticket type user verbose
123        }
124    }],
125    'branch-create' => [@OPTION_OF{
126        qw{ branch-of-branch non-interactive password rev-flag
127            svn-non-interactive switch ticket type
128        }
129    }],
130    'branch-delete' => [@OPTION_OF{
131        qw{ non-interactive password quiet show-all show-children show-siblings
132            svn-non-interactive switch verbose
133        }
134    }],
135    'branch-diff'   => [@OPTION_OF{
136        qw{diff-cmd graphical extensions summarize trac wiki xml}
137    }],
138    'branch-info'   => [@OPTION_OF{
139        qw{quiet show-all show-children show-siblings verbose}
140    }],
141    'branch-list'   => [@OPTION_OF{
142        qw{only quiet show-all url user verbose}
143    }],
144    'browse'        => [$OPTION_OF{browser}],
145    'build'         => [@OPTION_OF{
146        qw{archive clean full ignore-lock jobs stage targets verbosity}
147    }],
148    'cfg-print'     => [$OPTION_OF{fcm1}],
149    'cmp-ext-cfg'   => [@OPTION_OF{qw{quiet verbose wiki-format}}],
150    'commit'        => [@OPTION_OF{
151        qw{dry-run password svn-non-interactive}
152    }],
153    'conflicts'     => [],
154    'delete'        => [$OPTION_OF{check}],
155    'diff'          => [@OPTION_OF{
156        qw{branch diff-cmd extensions summarize trac wiki}
157    }],
158    'export-items'  => [@OPTION_OF{qw{directory config-file new}}],
159    'extract'       => [@OPTION_OF{qw{clean full ignore-lock verbosity}}],
160    'gui'           => [],
161    $HELP_APP       => [@OPTION_OF{qw{quiet verbose}}],
162    'keyword-print' => [@OPTION_OF{qw{verbose}}],
163    'loc-layout'    => [@OPTION_OF{qw{verbose}}],
164    'make'          => [@OPTION_OF{
165        qw{ archive directory ignore-lock jobs config-file config-file-path name
166            new quiet verbose
167        }
168    }],
169    'merge'         => [@OPTION_OF{
170        qw{ auto-log custom dry-run non-interactive quiet reverse revision
171            verbose}
172    }],
173    'mkpatch'       => [@OPTION_OF{qw{exclude organisation revision}}],
174    'project-create'=> [@OPTION_OF{
175        qw{non-interactive password svn-non-interactive}
176    }],
177    'switch'        => [@OPTION_OF{qw{non-interactive revision quiet verbose}}],
178    'update'        => [@OPTION_OF{qw{non-interactive revision quiet verbose}}],
179);
180# Preferred names of known applications with aliases
181our %PREF_NAME_OF = (
182    'ann'      => 'blame',
183    'annotate' => 'blame',
184    'bcreate'  => 'branch-create',
185    'bc'       => 'branch-create',
186    'bdel'     => 'branch-delete',
187    'bdelete'  => 'branch-delete',
188    'bdi'      => 'branch-diff',
189    'bdiff'    => 'branch-diff',
190    'binfo'    => 'branch-info',
191    'bld'      => 'build',
192    'blist'    => 'branch-list',
193    'bls'      => 'branch-list',
194    'br'       => 'branch',
195    'brm'      => 'branch-delete',
196    'cfg'      => 'cfg-print',
197    'ci'       => 'commit',
198    'cf'       => 'conflicts',
199    'co'       => 'checkout',
200    'cp'       => 'copy',
201    'del'      => 'delete',
202    'di'       => 'diff',
203    'ext'      => 'extract',
204    'h'        => $HELP_APP,
205    'kp'       => 'keyword-print',
206    'ls'       => 'list',
207    'mv'       => 'move',
208    'pd'       => 'propdel',
209    'pdel'     => 'propdel',
210    'pe'       => 'propedit',
211    'pedit'    => 'propedit',
212    'pg'       => 'propget',
213    'pget'     => 'propget',
214    'pl'       => 'proplist',
215    'plist'    => 'proplist',
216    'praise'   => 'blame',
217    'ps'       => 'propset',
218    'pset'     => 'propset',
219    'ren'      => 'move',
220    'rename'   => 'move',
221    'rm'       => 'delete',
222    'remove'   => 'delete',
223    'st'       => 'status',
224    'sw'       => 'switch',
225    'stat'     => 'status',
226    'trac'     => 'browse',
227    'up'       => 'update',
228    'usage'    => $HELP_APP,
229    'www'      => 'browse',
230    '?'        => $HELP_APP,
231    '-V'       => 'version',
232    '--help'   => $HELP_APP,
233    '--usage'  => $HELP_APP,
234    '--version'=> 'version',
235);
236
237# Creates the class.
238__PACKAGE__->class(
239    {   help_app        => {isa => '$', default => $HELP_APP            },
240        help_option     => {isa => '%', default => {%{$OPTION_OF{help}}}},
241        hook_before_for => {isa => '%', default => {%HOOK_BEFORE_FOR}   },
242        options_for     => {isa => '%', default => {%OPTIONS_FOR}       },
243        pref_name_of    => {isa => '%', default => {%PREF_NAME_OF}      },
244    },
245    {action_of => {parse => \&_parse}},
246);
247
248# Parses the options and arguments.
249sub _parse {
250    my ($attrib_ref, @argv) = @_;
251    my @args = @argv;
252    my $option_hash_ref = {};
253    if (!@args) {
254        return ($attrib_ref->{help_app}, $option_hash_ref);
255    }
256    my $app = shift(@args);
257    if (exists($attrib_ref->{pref_name_of}{$app})) {
258        $app = $attrib_ref->{pref_name_of}{$app};
259    }
260    if (_get_code_to_match($attrib_ref->{help_option})->(\@args)) {
261        return ($attrib_ref->{help_app}, {}, $app);
262    }
263    if (exists($attrib_ref->{hook_before_for}{$app})) {
264        if (!$attrib_ref->{hook_before_for}{$app}->(\@args)) {
265            return ($app, $option_hash_ref, @args);
266        }
267    }
268    if (!exists($attrib_ref->{options_for}{$app})) {
269        return ($app, $option_hash_ref, @args);
270    }
271    my @option_strings = map {
272        join('|', @{$_->{names}}, @{$_->{letters}}) . $_->{arg};
273    } @{$attrib_ref->{options_for}{$app}};
274    local(@ARGV) = @args;
275    my @warnings;
276    local($SIG{__WARN__}) = sub {push(@warnings, @_)};
277    if (!GetOptions($option_hash_ref, @option_strings)) {
278        my $E = 'FCM::CLI::Exception';
279        for (@warnings) {
280            chomp();
281        }
282        return $E->throw($E->OPT, \@argv, join('|', @warnings));
283    }
284    @args = @ARGV;
285    return ($app, $option_hash_ref, @args);
286}
287
288# Returns a CODE reference for matching a simple option to a string.
289sub _get_option_matcher {
290    my ($option_ref) = @_;
291    return sub {
292        grep {$_[0] eq $_} (
293            (map {"--$_"} @{$option_ref->{names}  }),
294            (map { "-$_"} @{$option_ref->{letters}}),
295        );
296    };
297}
298
299# Returns a CODE reference for matching a simple option to a string.
300sub _get_code_to_match {
301    my ($option_ref) = @_;
302    my $grepper = _get_option_matcher($option_ref);
303    return sub {grep {$grepper->($_)} @{$_[0]}};
304}
305
306# Returns a CODE reference to replace a simple option in the argument list.
307sub _get_code_to_replace {
308    my ($option_ref, $replacement) = @_;
309    my @replacements = ref($replacement) ? @{$replacement} : $replacement;
310    my $grepper = _get_option_matcher($option_ref);
311    return sub {
312        @{$_[0]} = map {($grepper->($_) ? @replacements : $_)} @{$_[0]};
313        return 1;
314    };
315}
316
317# ------------------------------------------------------------------------------
3181;
319__END__
320
321=head1 NAME
322
323FCM::CLI::Parser
324
325=head1 SYNOPSIS
326
327    use FCM::CLI::Parser;
328    my $cli = FCM::CLI::Parser->new(\%attrib);
329    my ($app, $opt_hash_ref, @args) = $cli->(@ARGV);
330
331=head1 DESCRIPTION
332
333This class provides an option/argument parser for the FCM command line
334interface. The parser, when called with some arguments, returns a list. The 1st
335element is the name of the application, the 2nd element is a HASH reference
336containing the option names and their values. The remaining elements are the
337remaining arguments.
338
339=head1 METHODS
340
341=over 4
342
343=item $class->new(\%attrib)
344
345Returns a new instance. The %attrib HASH may contain the following elements:
346
347=over 4
348
349=item help_app
350
351The name of the I<help> application. Default = $FCM::CLI::Parser::HELP_APP.
352
353=item help_option
354
355An option that represents I<help>. If this option is encountered in the command
356line, the CODE reference returns (help_app, {}, $app) regardless of the other
357command line options and arguments. Default =
358$FCM::CLI::Parser::OPTIONS_FOR{help}.
359
360=item hook_before_for
361
362Hook commands for the applications, which are executed before the option parser.
363See the L</CONFIGURATIONS> section for detail. Default =
364$FCM::CLI::Parser::HOOK_BEFORE_FOR.
365
366=item options_for
367
368The options for each application. See the L</CONFIGURATIONS> section for detail.
369Default = $FCM::CLI::Parser::OPTIONS_FOR.
370
371=item pref_name_of
372
373The preferred names for the applications. See the L</CONFIGURATIONS> section for
374detail. Default = $FCM::CLI::Parser::PREF_NAME_OF.
375
376=back
377
378=item $instance->(@args)
379
380=back
381
382=head1 CONFIGURATIONS
383
384The following should only be used as read-only variables. The
385$class->new(\%attrib) method should be used to configure a parser.
386
387=over 4
388
389=item $FCM::CLI::Parser::HELP_APP
390
391The name of the I<help> application.
392
393=item %FCM::CLI::Parser::HOOK_BEFORE_FOR
394
395A hash containing the hook commands, which are invoked before calling the option
396parser. The hash keys are names of the applications, and the values are CODE
397references to invoke. If a hook exists for an application, it is called as
398$hook->(\@args) where @args is the current command line arguments (with the
399first argument, i.e. the application name removed). If the hook returns a false
400value, the parser will return immediately.
401
402=item %FCM::CLI::Parser::OPTION_OF
403
404A hash containing the known options. The key is the preferred name of the
405option, and the value is a HASH reference, where C<names> (=> ARRAY reference)
406are the long names of the option, C<letters> (=> ARRAY reference) are the
407option letters, C<arg> (=> integer) is a flag. (See L</CONSTANTS> section for
408detail.)
409
410=item %FCM::CLI::Parser::OPTIONS_FOR
411
412A hash containing the known applications. The keys are the names of the
413applications and the values are ARRAY references, each pointing to
414a list of options (as described in %FCM::CLIParser::OPTION_OF) for the
415application.
416
417=item %FCM::CLI::Parser::PREF_NAME_OF
418
419A hash containing the preferred names of an application. The keys are the
420aliases and the values are the preferred names.
421
422=back
423
424=head1 CONSTANTS
425
426=over 4
427
428=item FCM::CLI::Parser->OPT_BOOL
429
430Option flag. Option is a boolean with no argument.
431
432=item FCM::CLI::Parser->OPT_INCR
433
434Option flag. Option has no argument but is incremental.
435
436=item FCM::CLI::Parser->OPT_LIST
437
438Option flag. Option has one or more arguments.
439
440=item FCM::CLI::Parser->OPT_SCAL
441
442Option flag. Option has a single argument.
443
444=back
445
446=head1 DIAGNOSTICS
447
448=over 4
449
450=item FCM::CLI::Parser::Exception
451
452This exception is raised if an invalid command option is given. It inherits from
453L<FCM::Exception>. There is no error code associated with this exception. The
454$e->get_ctx() method returns an ARRAY reference containing the original
455arguments.
456
457=back
458
459=head1 COPYRIGHT
460
461(C) Crown copyright Met Office. All rights reserved.
462
463=cut
Note: See TracBrowser for help on using the repository browser.