source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM/System/CM.pm @ 5321

Last change on this file since 5321 was 5129, checked in by abarral, 4 months ago

Re-add removed by mistake fcm
File size: 24.7 KB
Line 
1# ------------------------------------------------------------------------------
2# Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
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::System::CM;
24use base qw{FCM::Class::CODE};
25
26use Cwd qw{cwd};
27use FCM1::Cm;
28use FCM1::Interactive;
29use FCM::Context::Event;
30use FCM::Context::Locator;
31use FCM::System::CM::CommitMessage;
32use FCM::System::CM::Prompt;
33use FCM::System::CM::ResolveConflicts qw{_cm_resolve_conflicts};
34use FCM::System::CM::SVN;
35use FCM::System::Exception;
36use FCM::Util::Exception;
37use File::Spec::Functions qw{catfile};
38use List::Util qw{first};
39use Storable qw{dclone};
40
41# The (keys) named actions of this class and (values) their implementations.
42our %ACTION_OF = (
43    cm_branch_create     => \&_cm_branch_create,
44    cm_branch_delete     => _fcm1_func(\&FCM1::Cm::cm_branch_delete),
45    cm_branch_diff       => _fcm1_func(\&FCM1::Cm::cm_branch_diff),
46    cm_branch_info       => _fcm1_func(\&FCM1::Cm::cm_branch_info),
47    cm_branch_list       => \&_cm_branch_list,
48    cm_commit            => _fcm1_func(\&FCM1::Cm::cm_commit),
49    cm_checkout          => \&_cm_checkout,
50    cm_check_missing     => _fcm1_func(
51        \&FCM1::Cm::cm_check_missing,
52        _opt_mod_st_check_handler_func('WC_STATUS_PATH'),
53    ),
54    cm_check_unknown     => _fcm1_func(
55        \&FCM1::Cm::cm_check_unknown,
56        _opt_mod_st_check_handler_func('WC_STATUS_PATH'),
57    ),
58    cm_diff              => \&_cm_diff,
59    cm_loc_layout        => \&_cm_loc_layout,
60    cm_merge             => _fcm1_func(\&FCM1::Cm::cm_merge),
61    cm_mkpatch           => _fcm1_func(\&FCM1::Cm::cm_mkpatch),
62    cm_project_create    => \&_cm_project_create,
63    cm_resolve_conflicts => \&_cm_resolve_conflicts,
64    cm_switch            => _fcm1_func(
65        \&FCM1::Cm::cm_switch, _opt_mod_st_check_handler_func('WC_STATUS'),
66    ),
67    cm_update            => _fcm1_func(
68        \&FCM1::Cm::cm_update, _opt_mod_st_check_handler_func('WC_STATUS'),
69    ),
70    svn                  => \&_svn,
71);
72
73# Alias
74my $E = 'FCM::System::Exception';
75
76# Creates the class.
77__PACKAGE__->class(
78    {   commit_message_util => '&',
79        gui                 => '$',
80        prompt              => '&',
81        svn                 => '&',
82        util                => '&',
83    },
84    {init => \&_init, action_of => \%ACTION_OF},
85);
86
87sub _init {
88    my ($attrib_ref) = @_;
89    if (!defined(FCM1::Keyword::get_util())) {
90        FCM1::Keyword::set_util($attrib_ref->{util});
91    }
92    if ($attrib_ref->{'gui'}) {
93        FCM1::Interactive::set_impl(
94            'FCM1::Interactive::InputGetter::GUI',
95            {geometry => $attrib_ref->{gui}},
96        );
97    }
98    $attrib_ref->{prompt} = FCM::System::CM::Prompt->new({
99        gui => $attrib_ref->{gui}, util => $attrib_ref->{util},
100    });
101    $attrib_ref->{commit_message_util} = FCM::System::CM::CommitMessage->new({
102        gui  => $attrib_ref->{gui},
103        util => $attrib_ref->{util},
104    });
105    $attrib_ref->{svn} = FCM::System::CM::SVN->new({util => $attrib_ref->{util}});
106    FCM1::Cm::set_util($attrib_ref->{util});
107    FCM1::Cm::set_commit_message_util($attrib_ref->{commit_message_util});
108    FCM1::Cm::set_svn_util($attrib_ref->{svn});
109}
110
111# Create a branch in a project.
112sub _cm_branch_create {
113    my ($attrib_ref, $option_ref, @args) = @_;
114    _parse_args($attrib_ref, $option_ref, \@args);
115    my ($name, $source) = @args;
116    # Check branch name
117    if (!$name || $name !~ qr{\A[\w\.\-/]+\z}msx) {
118        return $E->throw($E->CM_BRANCH_NAME, $name ? $name : q{});
119    }
120    # Determine ticket list with name
121    if (!$option_ref->{ticket} && $name =~ qr{\A[1-9]\d*([_\-][1-9]\d*)*\z}msx) {
122        $option_ref->{ticket} = [split(qr{[_\-]}msx, $name)];
123    }
124    # Check source
125    $source ||= cwd() . '@HEAD';
126    my $layout = $attrib_ref->{svn}->get_layout($source);
127    my $root = $layout->get_root();
128    my $source_rev = $layout->get_peg_rev();
129    my $project = $layout->get_project();
130    my $source_branch = $layout->get_branch();
131    if (!defined($project)) {
132        return $E->throw($E->CM_BRANCH_SOURCE, $source);
133    }
134    my @project_paths = split(qr{/}msx, $project);
135
136    # Determine whether to create a branch of a branch
137    if (!$option_ref->{'branch-of-branch'} || !$source_branch) {
138        $source_branch = 'trunk';
139    }
140    $source = join('/', $root, @project_paths, $source_branch)
141        . '@' . $source_rev;
142    my $source_commit_rev
143        = $attrib_ref->{svn}->get_info($source)->[0]->{'commit:revision'};
144    $source = join('/', $root, @project_paths, $source_branch)
145        . '@' . $source_commit_rev;
146    $attrib_ref->{util}->event(
147        FCM::Context::Event->CM_BRANCH_CREATE_SOURCE, $source, $source_rev,
148    );
149
150    # Handle multiple tickets
151    $option_ref->{ticket} ||= [];
152    $option_ref->{ticket} = [
153        sort
154            {$a <=> $b}
155        map
156            {s{\A#}{}msx; $_}
157        split(qr{,}msx, join(q{,}, @{$option_ref->{ticket}}))
158    ];
159
160    # Determine the sub-directory names of the branch
161    # FIXME: hard coded legacy!
162    my %layout_config = %{$layout->get_config()};
163    my @names;
164    if ($layout_config{'template-branch'}) {
165        my $template = $layout_config{'template-branch'};
166        if (    index($template, '{category}') >= 0
167            ||  index($template, '{owner}') >= 0
168        ) {
169            $option_ref->{type} ||= 'dev::user';
170            $option_ref->{type} = lc($option_ref->{type});
171            $option_ref->{type}
172                = $option_ref->{type} eq 'user'   ? 'dev::user'
173                : $option_ref->{type} eq 'share'  ? 'dev::share'
174                : $option_ref->{type} eq 'config' ? 'pkg::config'
175                : $option_ref->{type} eq 'rel'    ? 'pkg::rel'
176                : $option_ref->{type} eq 'dev'    ? 'dev::user'
177                : $option_ref->{type} eq 'test'   ? 'test::user'
178                : $option_ref->{type} eq 'pkg'    ? 'pkg::user'
179                :                                   $option_ref->{type}
180                ;
181            if (!grep {$option_ref->{type} eq $_} qw{
182                dev::share dev::user test::share test::user
183                pkg::config pkg::rel  pkg::share  pkg::user
184            }) {
185                return $E->throw($E->CM_OPT_ARG, ['type', $option_ref->{type}]);
186            }
187            my %set = map {$_ => 1} split('::', $option_ref->{type});
188            if (index($template, '{category}') >= 0) {
189                my $index = index($template, '{category}');
190                my $category = first {exists($set{$_})} qw{dev test pkg};
191                substr($template, $index, length('{category}'), $category);
192            }
193            if (index($template, '{owner}') >= 0) {
194                my $index = index($template, '{owner}');
195                my $owner = exists($set{user})
196                    ? $attrib_ref->{svn}->get_username($root)
197                    : first {exists($set{lc($_)})} qw{Share Config Rel};
198                substr($template, $index, length('{owner}'), $owner);
199            }
200        }
201        if (index($template, '{name_prefix}') >= 0) {
202            my $index = index($template, '{name_prefix}');
203            # Check revision flag is valid
204            $option_ref->{'rev-flag'} ||= 'normal';
205            $option_ref->{'rev-flag'} = lc($option_ref->{'rev-flag'});
206            if (!grep {$_ eq $option_ref->{'rev-flag'}} qw{normal number none}) {
207                return $E->throw(
208                    $E->CM_OPT_ARG, ['rev-flag', $option_ref->{'rev-flag'}]);
209            }
210            my $name_prefix = q{};
211            if ($option_ref->{'rev-flag'} ne 'none') {
212                $name_prefix = 'r' . $source_commit_rev;
213                if ($option_ref->{'rev-flag'} eq 'normal') {
214                    # Attempt to replace revision number with a keyword
215                    my $locator = FCM::Context::Locator->new($source);
216                    my $as_keyword = $attrib_ref->{util}->loc_as_keyword($locator);
217                    my ($u, $r) = $attrib_ref->{svn}->split_by_peg($as_keyword);
218                    if ($source_commit_rev ne $r) {
219                        $name_prefix = $r;
220                    }
221                }
222
223                # Add an underscore
224                $name_prefix .= '_';
225            }
226            substr($template, $index, length('{name_prefix}'), $name_prefix);
227        }
228        if (index($template, '{name}') >= 0) {
229            my $index = index($template, '{name}');
230            substr($template, $index, length('{name}'), $name);
231        }
232        push(@names, split(qr{/+}msx, $template));
233    }
234    else {
235        push(@names, split(qr{/+}msx, $name));
236    }
237    if ($layout_config{'depth-branch'} != scalar(@names)) {
238        return $E->throw($E->CM_BRANCH_NAME, join('/', @names));
239    }
240    if ($layout_config{'dir-branch'}) {
241        unshift(@names, $layout_config{'dir-branch'});
242    }
243    # Check whether the branch already exists
244    my $target = join('/', $root, @project_paths, @names);
245    my $target_url = eval {$attrib_ref->{svn}->get_info($target)->[0]->{url}};
246    $@ = undef;
247    if ($target_url) {
248        return $E->throw($E->CM_ALREADY_EXIST, $target_url);
249    }
250
251    # Message for the commit log
252    my @tickets = @{$option_ref->{ticket}};
253    my @message = sprintf('%sCreated %s from %s@%d.' . "\n",
254        (@tickets ? join(q{,}, map {'#' . $_} @tickets) . q{: } : q{}),
255        join('/', q{}, @project_paths, @names),
256        join('/', q{}, @project_paths, $source_branch), $source_commit_rev,
257    );
258
259    # Create a temporary file for the commit log message
260    my $commit_message_ctx = $attrib_ref->{commit_message_util}->ctx();
261    $commit_message_ctx->set_auto_part(join(q{}, @message));
262    $commit_message_ctx->set_info_part(sprintf("%s    %s\n", 'A', $target));
263    if (!$option_ref->{'non-interactive'}) {
264        $attrib_ref->{commit_message_util}->edit($commit_message_ctx);
265    }
266    $attrib_ref->{commit_message_util}->notify($commit_message_ctx);
267    my $temp_handle
268        = $attrib_ref->{commit_message_util}->temp($commit_message_ctx);
269
270    # Check with the user to see if he/she wants to go ahead
271    if (    !$option_ref->{'non-interactive'}
272        &&  !$attrib_ref->{prompt}->question('BRANCH_CREATE')
273    ) {
274        return;
275    }
276
277    # Create the branch
278    $attrib_ref->{svn}->call(
279        'copy',
280        '--file', $temp_handle->filename(),
281        '--parents',
282        ($option_ref->{'svn-non-interactive'} ? '--non-interactive' : ()),
283        (   defined($option_ref->{'password'})
284            ? ('--password', $option_ref->{'password'}) : ()
285        ),
286        $source,
287        $target,
288    );
289    $attrib_ref->{util}->event(FCM::Context::Event->CM_CREATE_TARGET, $target);
290
291    # Switch working copy to point to newly created branch
292    if ($option_ref->{'switch'}) {
293        $ACTION_OF{'cm_switch'}->($attrib_ref, $option_ref, $target);
294    }
295
296    $target;
297}
298
299# Filter lists branches in projects.
300sub _cm_branch_list {
301    my ($attrib_ref, $option_ref, @args) = @_;
302    _parse_args($attrib_ref, $option_ref, \@args);
303    my $used_default_arg;
304    if (!@args) {
305        @args = cwd() . '@HEAD';
306        $used_default_arg = 1;
307    }
308    my %common_patterns_at;
309    if ($option_ref->{'only'} && @{$option_ref->{'only'}}) {
310        for (@{$option_ref->{'only'}}) {
311            my ($depth, $pattern) = split(qr{:}msx, $_, 2);
312            $common_patterns_at{$depth} ||= [];
313            push(@{$common_patterns_at{$depth}}, $pattern);
314        }
315    }
316    my $UTIL = $attrib_ref->{'util'};
317    ARG:
318    for my $arg (@args) {
319        my %patterns_at = %{dclone(\%common_patterns_at)};
320        my %info = eval {%{$attrib_ref->{svn}->get_info($arg)->[0]}};
321        if ($@) {
322            if ($used_default_arg) {
323                # Can't complain about a bad arg if we put it there.
324                return $E->throw($E->SHELL, $@->{ctx}, $@->{ctx}->{e});
325            }
326            return $E->throw($E->CM_ARG, $arg);
327        }
328        my $url = $info{'url'} . '@' . $info{'revision'};
329        my $layout = $attrib_ref->{svn}->get_layout($url);
330        my $root = $layout->get_root();
331        my $rev = $layout->get_peg_rev();
332        my $project = $layout->get_project();
333        if (!defined($project)) {
334            next ARG;
335        }
336        my $url_project = $root . ($project ? '/' . $project : q{});
337        my %layout_config = %{$layout->get_config()};
338        if ($layout_config{'level-owner-branch'} && !$option_ref->{'show-all'}) {
339            my $level = $layout_config{'level-owner-branch'};
340            if ($option_ref->{'user'} && @{$option_ref->{'user'}}) {
341                $patterns_at{$level} = [
342                    map {'^' . $_ . '$'}
343                    map {split(qr{[,:]}msx, $_)}
344                    @{$option_ref->{'user'}}
345                ];
346            }
347            elsif (!%patterns_at) {
348                my $owner = $attrib_ref->{svn}->get_username($root);
349                $patterns_at{$level} = ['^' . $owner . '$'];
350            }
351        }
352        my $url0 = $url_project;
353        if ($layout_config{'dir-branch'}) {
354            $url0 .= '/' . $layout_config{'dir-branch'};
355        }
356        else {
357            for my $key (qw{trunk tag}) {
358                if ($layout_config{"dir-$key"}) {
359                    $patterns_at{1} ||= [];
360                    push(
361                        @{$patterns_at{1}},
362                        '^(?!' . $layout_config{"dir-$key"} .  '$)',
363                    );
364                }
365            }
366        }
367        my @branches = $attrib_ref->{svn}->get_list(
368            $url0 . '@' . $rev,
369            sub {
370                my ($this_url, $this_name, $is_dir, $depth) = @_;
371                if (    exists($patterns_at{$depth})
372                    &&  !grep {$this_name =~ /$_/} @{$patterns_at{$depth}}
373                ) {
374                    return (0, 0);
375                }
376                my $can_return = $depth >= $layout_config{'depth-branch'};
377                ($can_return, ($is_dir && !$can_return));
378            },
379        );
380        if ($option_ref->{'url'}) {
381            $UTIL->event(
382                FCM::Context::Event->CM_BRANCH_LIST,
383                $url_project . '@' . $rev, @branches,
384            );
385        }
386        else {
387            $UTIL->event(
388                FCM::Context::Event->CM_BRANCH_LIST,
389                map {$UTIL->loc_as_keyword(FCM::Context::Locator->new($_))}
390                    ($url_project . '@' . $rev, @branches),
391            );
392        }
393    }
394}
395
396# Wraps "svn checkout".
397sub _cm_checkout {
398    my ($attrib_ref, $option_ref, @args) = @_;
399    _parse_args($attrib_ref, $option_ref, \@args);
400    my $target = @args && !$attrib_ref->{util}->uri_match($args[-1])
401        ? $args[-1] : cwd();
402    my $info_entry = eval {$attrib_ref->{svn}->get_info($target)->[0]};
403    if ($@) {
404        $@ = undef; # OK, not a working copy
405    }
406    elsif (grep {index($_, 'wc-info:') == 0} keys(%{$info_entry})) {
407        return $E->throw($E->CM_CHECKOUT, [$target, $info_entry->{url}]);
408    }
409    $attrib_ref->{svn}->call('checkout', @args);
410}
411
412# Wraps "svn diff".
413sub _cm_diff {
414    my ($attrib_ref, $option_ref, @args) = @_;
415    _parse_args($attrib_ref, $option_ref, \@args);
416    local(%ENV) = %ENV;
417    $ENV{FCM_GRAPHIC_DIFF}
418        ||= $attrib_ref->{util}->external_cfg_get('graphic-diff');
419    $attrib_ref->{svn}->call('diff', @args);
420}
421
422# Parse and print layout information of each target in @args.
423sub _cm_loc_layout {
424    my ($attrib_ref, $option_ref, @args) = @_;
425    _parse_args($attrib_ref, $option_ref, \@args);
426    if (!@args) {
427        @args = qw{.};
428    }
429    my $OUT = sub {
430        $attrib_ref->{util}->event(FCM::Context::Event->OUT, @_);
431    };
432    my $not_first;
433    for my $arg (@args) {
434        if ($not_first) {
435            $OUT->("\n");
436        }
437        $not_first = 1;
438        $OUT->("target: $arg\n");
439        my $layout = $attrib_ref->{svn}->get_layout($arg);
440        $OUT->($layout->as_string());
441    }
442}
443
444# Create a new project in a repository.
445sub _cm_project_create {
446    my ($attrib_ref, $option_ref, @args) = @_;
447    _parse_args($attrib_ref, $option_ref, \@args);
448    my ($name, $root_arg) = @args;
449    # Check project name
450    if (!$name || $name !~ qr{\A[\w\.\-/]+\z}msx) {
451        return $E->throw($E->CM_PROJECT_NAME, $name);
452    }
453    # Check root
454    if (!$root_arg) {
455        return $E->throw($E->CM_REPOSITORY, q{});
456    }
457    my $layout = $attrib_ref->{svn}->get_layout($root_arg);
458    my $root = $layout->get_root();
459    if (!$root) {
460        return $E->throw($E->CM_REPOSITORY, $root_arg);
461    }
462
463    # Check whether the depth of the project name is valid
464    my %layout_config = %{$layout->get_config()};
465    my @names = split(qr{/+}msx, $name);
466    my $depth_expected = $layout_config{'depth-project'};
467    if (defined($depth_expected) && $depth_expected != scalar(@names)) {
468        return $E->throw($E->CM_PROJECT_NAME, join('/', @names));
469    }
470    # Check whether the project (trunk) already exists
471    my $target = join('/', $root, @names, $layout_config{'dir-trunk'});
472    my $target_url = eval {$attrib_ref->{svn}->get_info($target)->[0]->{url}};
473    $@ = undef;
474    if ($target_url) {
475        return $E->throw($E->CM_ALREADY_EXIST, $target_url);
476    }
477
478    # Message for the commit log
479    my @message = sprintf("%s: new project.\n", join('/', @names));
480
481    # Create a temporary file for the commit log message
482    my $commit_message_ctx = $attrib_ref->{commit_message_util}->ctx();
483    $commit_message_ctx->set_auto_part(join(q{}, @message));
484    $commit_message_ctx->set_info_part(sprintf("%s    %s\n", 'A', $target));
485    if (!$option_ref->{'non-interactive'}) {
486        $attrib_ref->{commit_message_util}->edit($commit_message_ctx);
487    }
488    $attrib_ref->{commit_message_util}->notify($commit_message_ctx);
489    my $temp_handle
490        = $attrib_ref->{commit_message_util}->temp($commit_message_ctx);
491
492    # Check with the user to see if he/she wants to go ahead
493    if (    !$option_ref->{'non-interactive'}
494        &&  !$attrib_ref->{prompt}->question('PROJECT_CREATE')
495    ) {
496        return;
497    }
498
499    # Create the branch
500    $attrib_ref->{svn}->call(
501        'mkdir',
502        '--file', $temp_handle->filename(),
503        '--parents',
504        ($option_ref->{'svn-non-interactive'} ? '--non-interactive' : ()),
505        (   defined($option_ref->{'password'})
506            ? ('--password', $option_ref->{'password'}) : ()
507        ),
508        $target,
509    );
510    $attrib_ref->{util}->event(FCM::Context::Event->CM_CREATE_TARGET, $target);
511
512    $target;
513}
514
515# Returns a simple wrapper to FCM 1 FCM1::Cm functions.
516sub _fcm1_func {
517    my ($action_ref, $opt_mod_ref) = @_;
518    $opt_mod_ref ||= sub {};
519    sub {
520        my ($attrib_ref, $option_ref, @args) = @_;
521        _parse_args($attrib_ref, $option_ref, \@args);
522        local(@ARGV) = @args;
523        $opt_mod_ref->($option_ref);
524        eval {$action_ref->($option_ref, @args)};
525        if ($@) {
526            if (!FCM1::Cm::Abort->caught($@)) {
527                die($@);
528            }
529            if (!($@->get_code() eq $@->NULL || $@->get_code() eq $@->USER)) {
530                die($@);
531            }
532            $attrib_ref->{util}->event(
533                FCM::Context::Event->CM_ABORT, lc($@->get_code()),
534            );
535            $@ = undef;
536        }
537        return;
538    };
539}
540
541# Generate an option modifier to st_check_handler.
542sub _opt_mod_st_check_handler_func {
543    my $key = shift();
544    sub {
545        my $option_ref = shift();
546        if (!$option_ref->{'non-interactive'}) {
547            $option_ref->{st_check_handler} = $FCM1::Cm::CLI_HANDLER_OF{$key};
548        }
549    };
550}
551
552# Expands keywords in arguments.
553sub _parse_args {
554    my ($attrib_ref, $option_ref, $args_ref) = @_;
555    # Location keywords
556    my $UTIL = $attrib_ref->{util};
557    my $url;
558    for my $arg (@{$args_ref}) {
559        eval {
560            my $locator = FCM::Context::Locator->new($arg);
561            if ($UTIL->loc_what_type($locator) eq 'svn') {
562                my $new_arg = $UTIL->loc_as_normalised($locator);
563                my $SVN = $attrib_ref->{svn};
564                my ($new_arg_url, $new_arg_rev) = $SVN->split_by_peg($new_arg);
565                my (    $arg_url,     $arg_rev) = $SVN->split_by_peg($arg);
566                if (index($arg_url, $UTIL->loc_kw_prefix() . ':') == 0) {
567                    $arg_url = $new_arg_url;
568                }
569                if ($arg_rev && $new_arg_rev && $arg_rev ne $new_arg_rev) {
570                    $arg_rev = $new_arg_rev;
571                }
572                $arg = $arg_url . ($arg_rev ? '@' . $arg_rev : q{});
573                $url ||= $new_arg_url;
574            }
575        };
576        if (my $e = $@) {
577            if (    !FCM::Util::Exception->caught($e)
578                ||  index($e->get_code(), 'LOCATOR_') != 0
579            ) {
580                die($e);
581            }
582            $@ = undef;
583        }
584    }
585    # Revision keywords
586    $url ||= cwd();
587    my $in_opt_rev;
588    for my $arg (@{$args_ref}) {
589        my ($opt, $opt_arg);
590        if ($in_opt_rev) {
591            $in_opt_rev = 0;
592            ($opt, $opt_arg) = (q{}, $arg);
593        }
594        elsif (grep {$_ eq $arg} qw{-c --change -r --revision}) {
595            $in_opt_rev = 1;
596        }
597        else {
598            ($opt, $opt_arg)
599                = $arg =~ qr{\A(-[cr]|--(?:change|revision)=)(.*)\z}msx;
600        }
601        if ($opt_arg) {
602            $arg = $opt . _parse_args_rev($attrib_ref, $url, $opt_arg);
603        }
604    }
605    for my $key (grep {exists($option_ref->{$_})} qw{change revision}) {
606        $option_ref->{$key}
607            = _parse_args_rev($attrib_ref, $url, $option_ref->{$key});
608    }
609}
610
611# Expands revision keywords in an argument.
612sub _parse_args_rev {
613    my ($attrib_ref, $url, $arg) = @_;
614    my $UTIL = $attrib_ref->{util};
615    join(
616        ':',
617        map {
618            my $rev = $_;
619            my $locator = FCM::Context::Locator->new($url . '@' . $rev);
620            local($@);
621            my $value = eval{$UTIL->loc_as_normalised($locator)};
622            if ($value) {
623                (my $url, $rev) = $attrib_ref->{svn}->split_by_peg($value);
624            }
625            $rev;
626        } split(qr{:}msx, $arg, 2)
627    );
628}
629
630# Invokes a system "svn" call.
631sub _svn {
632    my ($attrib_ref, $app, $option_ref, @args) = @_;
633    _parse_args($attrib_ref, $option_ref, \@args);
634    $attrib_ref->{svn}->call($app, @args);
635}
636
637#-------------------------------------------------------------------------------
6381;
639__END__
640
641=head1 NAME
642
643FCM::System::CM
644
645=head1 SYNOPSIS
646
647    use FCM::System::CM;
648    my $system = FCM::System::CM->new(\%attrib);
649    my ($out, $err) = $system->svn({}, @args);
650
651=head1 DESCRIPTION
652
653The FCM code management sub-system. This is currently a thin adaptor of
654L<FCM1::Cm|FCM1::Cm>.
655
656=head1 METHODS
657
658=over 4
659
660=item $class->new(\%attrib)
661
662Returns a new instance. This class should normally be initialised by
663L<FCM::System|FCM::System>.
664
665=item $system->cm_branch_create(\%option,@args)
666
667Implement the C<fcm branch-create> command. On success, return the branch name
668created.
669
670=item $system->cm_branch_list(\%option,@args)
671
672Implement the C<fcm branch-list> command.
673
674=item $system->cm_checkout(\%option,@args)
675
676Thin wrapper of the C<svn checkout> command. Ensure checkout to clean location.
677
678=item $system->cm_diff(\%option,@args)
679
680Thin wrapper of the C<svn diff> command. Allow --graphical option.
681
682=item $system->cm_loc_layout(\%option,@args)
683
684Implement the C<fcm loc-layout> command.
685
686=item $system->cm_project_create(\%option,@args)
687
688Implement the C<fcm project-create> command.
689
690=item $system->cm_branch_delete(\%option,@args)
691=item $system->cm_branch_info(\%option,@args)
692=item $system->cm_commit(\%option,@args)
693=item $system->cm_check_missing(\%option,@args)
694=item $system->cm_check_unknown(\%option,@args)
695=item $system->cm_merge(\%option,@args)
696=item $system->cm_mkpatch(\%option,@args)
697=item $system->cm_resolve_conflicts(\%option,@args)
698=item $system->cm_switch(\%option,@args)
699=item $system->cm_update(\%option,@args)
700
701Thin adaptors for the corresponding code management functions in
702L<FCM1::Cm|FCM1::Cm>.
703
704=item $system->svn($app,\%option,@args)
705
706Invokes a system call to L<svn|svn> $app with @args. %option is not currently
707used, but is left in the argument list for compatibility with the other methods.
708
709=back
710
711=head1 COPYRIGHT
712
713Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
714
715=cut
Note: See TracBrowser for help on using the repository browser.