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.
Cm.pm in vendors/lib/FCM1 – NEMO

source: vendors/lib/FCM1/Cm.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: 74.5 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# ------------------------------------------------------------------------------
19# NAME
20#   FCM1::Cm
21#
22# DESCRIPTION
23#   This module contains the FCM code management functionalities and wrappers
24#   to Subversion commands.
25#
26# ------------------------------------------------------------------------------
27use strict;
28use warnings;
29
30package FCM1::Cm;
31use base qw{Exporter};
32
33our @EXPORT_OK = qw(cm_check_missing cm_check_unknown cm_switch cm_update);
34
35use Cwd qw{cwd};
36use FCM::System::Exception;
37use FCM1::Config;
38use FCM1::CmBranch;
39use FCM1::CmUrl;
40use FCM1::Keyword;
41use FCM1::Util      qw{
42    get_url_of_wc
43    get_url_peg_of_wc
44    is_url
45    is_wc
46    tidy_url
47};
48use File::Basename qw{basename dirname};
49use File::Path qw{mkpath rmtree};
50use File::Spec;
51use Text::ParseWords qw{shellwords};
52
53# ------------------------------------------------------------------------------
54
55# CLI message handler
56our $CLI_MESSAGE = \&_cli_message;
57
58# List of CLI messages
59our %CLI_MESSAGE_FOR = (
60    q{}           => "%s",
61    BRANCH_LIST   => "%s at %s: %d branch(es) found for %s.\n",
62    CHDIR_WCT     => "%s: working directory changed to top of working copy.\n",
63    CF            => "Conflicts in: %s\n",
64    MERGE_ACTUAL  => "-" x 74 . "actual\n%s" . "-" x 74 . "actual\n",
65    MERGE_COMPARE => "Merge: %s\n c.f.: %s\n",
66    MERGE_OK      => "Merge succeeded.\n",
67    MERGE_DRYRUN  => "-" x 73 . "dry-run\n%s" . "-" x 73 . "dry-run\n",
68    MERGE_REVS    => "Eligible merge(s) from %s: %s\n",
69    OUT_DIR       => "Output directory: %s\n",
70    PATCH_DONE    => "%s: patch generated.\n",
71    PATCH_REV     => "Patch created for changeset %s\n",
72    SEPARATOR     => q{-} x 80 . "\n",
73    STATUS        => "%s: status of %s:\n%s\n",
74);
75
76# CLI abort and error messages
77our %CLI_MESSAGE_FOR_ABORT = (
78    FAIL => "%s: command failed.\n",
79    NULL => "%s: command will result in no change.\n",
80    USER => "%s: abort by user.\n",
81);
82
83# CLI abort and error messages
84our %CLI_MESSAGE_FOR_ERROR = (
85    CHDIR               => "%s: cannot change to directory.\n",
86    CLI                 => "%s",
87    CLI_HELP            => "Type 'fcm help %s' for usage.\n",
88    CLI_MERGE_ARG1      => "Arg 1 must be the source in auto/custom mode.\n",
89    CLI_MERGE_ARG2      => "Arg 2 must be the source in custom mode"
90                           . " if --revision not set.\n",
91    CLI_OPT_ARG         => "--%s: invalid argument [%s].\n",
92    CLI_OPT_WITH_OPT    => "--%s: must be specified with --%s.\n",
93    CLI_USAGE           => "incorrect value for the %s argument",
94    DIFF_PROJECTS       => "%s (target) and %s (source) are not related.\n",
95    INVALID_BRANCH      => "%s: not a valid URL of a standard FCM branch.\n",
96    INVALID_PROJECT     => "%s: not a valid URL of a standard FCM project.\n",
97    INVALID_TARGET      => "%s: not a valid working copy or URL.\n",
98    INVALID_URL         => "%s: not a valid URL.\n",
99    INVALID_WC          => "%s: not a valid working copy.\n",
100    MERGE_REV_INVALID   => "%s: not a revision in the available merge list.\n",
101    MERGE_SELF          => "%s: cannot be merged to its own working copy: %s.\n",
102    MERGE_UNRELATED     => "%s: target and %s: source not directly related.\n",
103    MERGE_UNSAFE        => "%s: source contains changes outside the target"
104                           . " sub-directory. Please merge with a full tree.\n",
105    MKPATH              => "%s: cannot create directory.\n",
106    NOT_EXIST           => "%s: does not exist.\n",
107    PARENT_NOT_EXIST    => "%s: parent %s no longer exists.\n",
108    RMTREE              => "%s: cannot remove.\n",
109    ST_CI_MESG_FILE     => "Attempt to add commit message file:\n%s",
110    ST_CONFLICT         => "File(s) in conflicts:\n%s",
111    ST_MISSING          => "File(s) missing:\n%s",
112    ST_OOD              => "File(s) out of date:\n%s",
113    SWITCH_UNSAFE       => "%s: merge template exists."
114                           . " Please remove before retrying.\n",
115    WC_INVALID_BRANCH   => "%s: not a working copy of a standard FCM branch.\n",
116    WC_URL_NOT_EXIST    => "%s: working copy URL does not exists at HEAD.\n",
117);
118
119# List of CLI prompt messages
120our %CLI_MESSAGE_FOR_PROMPT = (
121    CF_OVERWRITE      => qq{%s: existing changes will be overwritten.\n}
122                         . qq{ Do you wish to continue?},
123    CI                => qq{Would you like to commit this change?},
124    CI_BRANCH_SHARED  => qq{\n}
125                         . qq{*** WARNING: YOU ARE COMMITTING TO A %s BRANCH.\n}
126                         . qq{*** Please ensure that you have the}
127                         . qq{ owner's permission.\n\n}
128                         . qq{Would you like to commit this change?},
129    CI_BRANCH_USER    => qq{\n}
130                         . qq{*** WARNING: YOU ARE COMMITTING TO A BRANCH}
131                         . qq{ NOT OWNED BY YOU.\n}
132                         . qq{*** Please ensure that you have the}
133                         . qq{ owner's permission.\n\n}
134                         . qq{Would you like to commit this change?},
135    CI_TRUNK          => qq{\n}
136                         . qq{*** WARNING: YOU ARE COMMITTING TO THE TRUNK.\n}
137                         . qq{*** Please ensure that your change conforms to}
138                         . qq{ your project's working practices.\n\n}
139                         . qq{Would you like to commit this change?},
140    CONTINUE          => qq{%s: continue?},
141    MERGE             => qq{Would you like to go ahead with the merge?},
142    MERGE_REV         => qq{Enter a revision},
143    MKPATCH_OVERWRITE => qq{%s: output location exists. OK to overwrite?},
144    RUN_SVN_COMMAND   => qq{Would you like to run "svn %s"?},
145);
146
147# List of CLI warning messages
148our %CLI_MESSAGE_FOR_WARNING = (
149    BRANCH_SUBDIR   => "%s: is a sub-directory of a branch in a FCM project.\n",
150    CF_BINARY       => "%s: ignoring binary file, please resolve manually.\n",
151    INVALID_BRANCH  => $CLI_MESSAGE_FOR_ERROR{INVALID_BRANCH},
152    ST_IN_TRAC_DIFF => "%s: local changes cannot be displayed in Trac.\n"
153);
154
155# CLI prompt handler and title prefix
156our $CLI_PROMPT = \&_cli_prompt;
157our $CLI_PROMPT_PREFIX = q{fcm };
158
159# Event handlers
160our %CLI_HANDLER_OF = (
161    'WC_STATUS'      => \&_cli_handler_of_wc_status,
162    'WC_STATUS_PATH' => \&_cli_handler_of_wc_status_path,
163);
164
165# Common patterns
166our %PATTERN_OF = (
167    # A CLI option
168    CLI_OPT => qr{
169        \A            (?# beginning)
170        (--\w[\w-]*=) (?# capture 1, a long option label)
171        (.*)          (?# capture 2, the value of the option)
172        \z            (?# end)
173    }xms,
174    # A CLI revision option
175    CLI_OPT_REV => qr{
176        \A                      (?# beginning)
177        (--revision(?:=|\z)|-r) (?# capture 1, --revision, --revision= or -r)
178        (.*)                    (?# capture 2, trailing value)
179        \z                      (?# end)
180    }xms,
181    # A CLI revision option range
182    CLI_OPT_REV_RANGE => qr{
183        \A                  (?# beginning)
184        (                   (?# capture 1, begin)
185            (?:\{[^\}]+\}+) (?# a date in curly braces)
186            |               (?# or)
187            [^:]+           (?# anything but a colon)
188        )                   (?# capture 1, end)
189        (?::(.*))?          (?# colon, and capture 2 til the end)
190        \z                  (?# end)
191    }xms,
192    # A FCM branch path look-alike, should be configurable in the future
193    FCM_BRANCH_PATH => qr{
194        \A                            (?# beginning)
195        /*                            (?# some slashes)
196        (?:                           (?# group 1, begin)
197            (?:trunk/*(?:@\d+)?\z)    (?# trunk at a revision)
198            |                         (?# or)
199            (?:trunk|branches|tags)/+ (?# trunk, branch or tags)
200        )                             (?# group 1, end)
201    }xms,
202    # Last line of output from "svn status -u"
203    ST_AGAINST_REV => qr{
204        \A                           (?# beginning)
205        Status\sagainst\srevision:.* (?# output of svn status -u)
206        \z                           (?# end)
207    }xms,
208    # Extract path from "svn status"
209    ST_PATH => qr{
210        \A   (?# beginning)
211        .{6} (?# 6 columns)
212        \s+  (?# spaces)
213        (.+) (?# capture 1, target path)
214        \z   (?# end)
215    }xms,
216    # A legitimate "svn" revision
217    SVN_REV => qr{
218        \A                                      (?# beginning)
219        (?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}) (?# digit, reserved words, date)
220        \z                                      (?# end)
221    }ixms,
222);
223
224# Status matchers
225our %ST_MATCHER_FOR = (
226    CONFLICT => sub {substr($_[0], 0, 1) eq 'C' || substr($_[0], 6, 1) eq 'C'},
227    MISSING  => sub {substr($_[0], 0, 1) eq '!'},
228    MODIFIED => sub {substr($_[0], 0, 7) =~ qr{\S}xms},
229    OOD      => sub {substr($_[0], 8, 1) eq '*'},
230    UNKNOWN  => sub {substr($_[0], 0, 1) eq '?'},
231);
232
233# Set the FCM::Util object by FCM::System::CM.
234our $UTIL;
235sub set_util {
236    $UTIL = shift();
237}
238
239# Set the commit message utility provided by FCM::System::CM.
240our $COMMIT_MESSAGE_UTIL;
241sub set_commit_message_util {
242    $COMMIT_MESSAGE_UTIL = shift();
243    FCM1::CmBranch::set_commit_message_util($COMMIT_MESSAGE_UTIL);
244}
245
246# Set the SVN utility provided by FCM::System::CM.
247our $SVN;
248sub set_svn_util {
249    $SVN = shift();
250    FCM1::CmUrl::set_svn_util($SVN);
251    FCM1::CmBranch::set_svn_util($SVN);
252}
253
254# Returns the branch URL as an instance of FCM1::CmUrl.
255sub _branch_url {
256    my $arg = shift();
257    my $url
258        = $arg && is_url($arg) ? FCM1::CmUrl->new(URL => $arg)
259        : $arg && is_wc($arg)  ? FCM1::CmUrl->new(URL => get_url_of_wc($arg))
260        : !$arg && is_wc()     ? FCM1::CmUrl->new(URL => get_url_of_wc())
261        :                        undef
262        ;
263    if (!$url) {
264        return _cm_err(FCM1::Cm::Exception->INVALID_TARGET, $arg ? $arg : q{.});
265    }
266    $url;
267}
268
269# Branch delete.
270sub cm_branch_delete {
271    my ($option_ref, $arg) = @_;
272    my $branch = cm_branch_info($option_ref, $arg);
273    $branch->del(
274        PASSWORD            => $option_ref->{password},
275        NON_INTERACTIVE     => $option_ref->{'non-interactive'},
276        SVN_NON_INTERACTIVE => $option_ref->{'svn-non-interactive'},
277    );
278    if (!$arg && $option_ref->{'switch'}) {
279        cm_switch($option_ref, $branch->layout()->get_config()->{'dir-trunk'});
280    }
281}
282
283# Branch diff.
284sub cm_branch_diff {
285    my ($option_ref, $target) = @_;
286    local(%ENV) = %ENV;
287    $ENV{FCM_GRAPHIC_DIFF} ||= $UTIL->external_cfg_get('graphic-diff');
288    my @diff_cmd
289        = $option_ref->{graphical}  ? (qw{
290            --config-option config:working-copy:exclusive-locking-clients=
291            --diff-cmd fcm_graphic_diff
292        })
293        : $option_ref->{'diff-cmd'} ? ('--diff-cmd', $option_ref->{'diff-cmd'})
294        :                             ()
295        ;
296    if ($option_ref->{extensions}) {
297        push(@diff_cmd, '--extensions', shellwords($option_ref->{extensions}));
298    }
299
300    # Target can be a URL/path, default to $PWD.
301    $target ||= q{.};
302    my $target_is_path = !is_url($target);
303
304    # Get repository and branch information
305    my $url = bless(_branch_url($target), 'FCM1::CmBranch');
306
307    # Check that URL is a standard FCM branch
308    if (!$url->is_branch()) {
309        return _cm_err(FCM1::Cm::Exception->INVALID_BRANCH, $url->url_peg());
310    }
311
312    # Save and remove sub-directory part of the URL
313    my $subdir = $url->subdir();
314    $url->url_peg($url->branch_url_peg());
315
316    # Check that $url exists
317    if (!$url->url_exists()) {
318        return _cm_err(FCM1::Cm::Exception->INVALID_URL, $url->url_peg());
319    }
320
321    # Compare current branch with its parent
322    my $parent = FCM1::CmBranch->new(URL => $url->parent()->url());
323    if ($url->pegrev()) {
324      $parent->url_peg($parent->url() . '@' . $url->pegrev());
325    }
326
327    if (!$parent->url_exists()) {
328        return _cm_err(
329            FCM1::Cm::Exception->PARENT_NOT_EXIST, $url->url_peg(), $parent->url(),
330        );
331    }
332
333    my $base = $parent->base_of_merge_from($url);
334
335    # Ensure the correct diff (syntax) is displayed
336    # Reinstate the sub-tree part into the URL
337    if ($subdir) {
338      $url->url_peg($url->branch_url() . '/' . $subdir . '@' . $url->pegrev());
339      $base->url_peg($base->branch_url() . '/' . $subdir . '@' . $base->pegrev());
340    }
341
342    if ($option_ref->{trac} || $option_ref->{wiki}) {
343        if ($target_is_path && _svn_status_get([$target])) {
344            $CLI_MESSAGE->('ST_IN_TRAC_DIFF', $target);
345        }
346
347        # Trac wiki syntax
348        my $wiki_syntax = 'diff:' . $base->path_peg() . '//' . $url->path_peg();
349
350        if ($option_ref->{wiki}) {
351            $CLI_MESSAGE->(q{}, "$wiki_syntax\n");
352        }
353        else { # if $option_ref->{trac}
354            my $browser = $UTIL->external_cfg_get('browser');
355            my $trac_url = FCM1::Keyword::get_browser_url($url->project_url());
356            # FIXME: assuming that the browser URL uses the InterTrac syntax
357            $trac_url =~ s{/intertrac/.*$}{/search?q=$wiki_syntax}xms;
358            my %value_of = %{$UTIL->shell_simple([$browser, $trac_url])};
359            if ($value_of{rc}) {
360                return FCM::System::Exception->throw(
361                    FCM::System::Exception->SHELL,
362                    {command_list => [$browser, $trac_url], %value_of},
363                    $value_of{e},
364                );
365            }
366        }
367    }
368    else {
369        $SVN->call(
370            'diff', @diff_cmd,
371            ($option_ref->{summarize} ? ('--summarize') : ()),
372          ($option_ref->{xml} ? ('--xml') : ()),
373            '--old', $base->url_peg(),
374            '--new', ($target_is_path ? $target : $url->url_peg()),
375        );
376    }
377}
378
379# Branch info.
380sub cm_branch_info {
381    my ($option_ref, $arg) = @_;
382    my $url = _branch_url($arg);
383    FCM1::Config->instance()->verbose($option_ref->{verbose} ? 1 : 0);
384    my $branch = FCM1::CmBranch->new(URL => $url->url_peg());
385    if (!$branch->branch()) {
386        return _cm_err(FCM1::Cm::Exception->INVALID_BRANCH, $branch->url_peg());
387    }
388    if (!$branch->url_exists()) {
389        return _cm_err(FCM1::Cm::Exception->NOT_EXIST, $branch->url_peg());
390    }
391    $branch->url_peg($branch->branch_url_peg());
392    $option_ref->{'show-children'} ||= $option_ref->{'show-all'};
393    $option_ref->{'show-other'   } ||= $option_ref->{'show-all'};
394    $option_ref->{'show-siblings'} ||= $option_ref->{'show-all'};
395    $branch->display_info(
396        SHOW_CHILDREN => $option_ref->{'show-children'},
397        SHOW_OTHER    => $option_ref->{'show-other'   },
398        SHOW_SIBLINGS => $option_ref->{'show-siblings'},
399    );
400    $branch;
401}
402
403# ------------------------------------------------------------------------------
404# SYNOPSIS
405#   &FCM1::Cm::cm_commit ();
406#
407# DESCRIPTION
408#   This is a FCM wrapper to the "svn commit" command.
409# ------------------------------------------------------------------------------
410
411sub cm_commit {
412  my ($option_ref, $path) = @_;
413  $path ||= cwd();
414  if (!-e $path) {
415    return _cm_err(FCM1::Cm::Exception->NOT_EXIST, $path);
416  }
417
418  # Make sure we are in a working copy
419  if (!is_wc($path)) {
420    return _cm_err(FCM1::Cm::Exception->INVALID_WC, $path);
421  }
422
423  # Make sure we are at the top level of the working copy
424  # (otherwise we might miss any template commit message)
425  my $dir = $SVN->get_wc_root($path);
426
427  if ($dir ne cwd ()) {
428    chdir($dir) || return _cm_err(FCM1::Cm::Exception->CHDIR, $dir);
429    $CLI_MESSAGE->('CHDIR_WCT', $dir);
430  }
431
432  # Get update status of working copy
433  # Check working copy files are not in conflict, missing, or out of date
434  my @status = _svn_status_get([], 1);
435  if (!defined($option_ref->{'dry-run'})) {
436    my %st_lines_of = (CONFLICT => [], MISSING => [], OOD => []);
437
438    LINE:
439    for my $line (@status) {
440      for my $key (keys(%st_lines_of)) {
441        if ($line && $ST_MATCHER_FOR{$key}->($line)) {
442          push(@{$st_lines_of{$key}}, $line);
443          next LINE;
444        }
445      }
446      # Check that all files which have been added have the svn:executable
447      # property set correctly (in case the developer adds a script before they
448      # remember to set the execute bit)
449      my ($file) = $line =~ qr/\AA.{8}\s*\d+\s+(.*)/msx;
450      if (!$file || !-f $file) {
451        next LINE;
452      }
453      my ($command, @arguments)
454        = (-x $file && !-l $file) ? ('propset', '*') : ('propdel');
455      $SVN->call($command, qw{-q svn:executable}, @arguments, $file);
456    }
457
458    # Abort commit if files are in conflict, missing, or out of date
459    my @keys = grep {@{$st_lines_of{$_}}} keys(%st_lines_of);
460    if (@keys) {
461      for my $key (sort(@keys)) {
462        my @lines = map {"$_\n"} @{$st_lines_of{$key}};
463        $CLI_MESSAGE->('ST_' . $key, join(q{}, @lines));
464      }
465      return _cm_abort(FCM1::Cm::Abort->FAIL);
466    }
467  }
468
469  # Read in any existing message
470  my $commit_message_ctx = $COMMIT_MESSAGE_UTIL->load();
471
472  # Execute "svn status" for a list of changed items
473  @status = map {$_ . "\n"} grep {$_ =~ qr/\A[^\?]/msx} _svn_status_get();
474
475  # Abort if there is no change in the working copy
476  if (!@status) {
477    return _cm_abort(FCM1::Cm::Abort->NULL);
478  }
479
480  # Abort if attempt to add commit message file
481  my $ci_mesg_file_base = $COMMIT_MESSAGE_UTIL->path_base();
482  my @bad_status = grep {$_ =~ qr{^A.*?\s$ci_mesg_file_base\n}m} @status;
483  if (@bad_status) {
484    for my $bad_status (@bad_status) {
485      $CLI_MESSAGE->('ST_CI_MESG_FILE', $bad_status);
486    }
487    return _cm_abort(FCM1::Cm::Abort->FAIL);
488  }
489
490  # Get associated URL of current working copy
491  my $layout = $SVN->get_layout($SVN->get_info()->[0]->{url});
492
493  # Include URL, or project, branch and sub-directory info in @status
494  unshift @status, "\n";
495
496  if ($layout->get_branch()) {
497    unshift(@status,
498      map {sprintf("[%-7s: %s]\n", @{$_})} (
499        ['Root'   , $layout->get_root()    ],
500        ['Project', $layout->get_project() ],
501        ['Branch' , $layout->get_branch()  ],
502        ['Sub-dir', $layout->get_sub_tree()],
503      ),
504    );
505  }
506  else {
507    unshift(@status,
508      map {sprintf("[%s: %s]\n", @{$_})} (
509        ['Root', $layout->get_root()],
510        ['Path', $layout->get_path()],
511      ),
512    );
513  }
514
515  # Use a temporary file to store the final commit log message
516  $commit_message_ctx->set_info_part(join(q{}, @status));
517  $COMMIT_MESSAGE_UTIL->edit($commit_message_ctx);
518  $COMMIT_MESSAGE_UTIL->notify($commit_message_ctx);
519
520  # Check with the user to see if he/she wants to go ahead
521  my $reply = 'n';
522  if (!defined($option_ref->{'dry-run'})) {
523    $reply = $CLI_PROMPT->('commit', (
524        $layout->is_trunk()         ? ('CI_TRUNK')
525      : !$layout->get_branch_owner()? ('CI')
526      : $layout->is_owned_by_user() ? ('CI')
527      : $layout->is_shared()        ? ('CI_BRANCH_SHARED',
528                                       $layout->get_branch_owner())
529      :                               ('CI_BRANCH_USER')
530    ));
531  }
532
533  if ($reply eq 'y') {
534    # Commit the change if user replies "y" for "yes"
535    my $temp = $COMMIT_MESSAGE_UTIL->temp($commit_message_ctx);
536    eval {$SVN->call(
537      qw{commit -F}, "$temp",
538      ($option_ref->{'svn-non-interactive'} ? '--non-interactive' : ()),
539      (   defined($option_ref->{password})
540          ? ('--password', $option_ref->{password}) : ()
541      ),
542    )};
543    if ($@) {
544      $COMMIT_MESSAGE_UTIL->save($commit_message_ctx);
545      die($@);
546    }
547
548    # Remove commit message file
549    unlink($COMMIT_MESSAGE_UTIL->path());
550
551    # Update the working copy
552    _svn_update();
553
554  } else {
555    $COMMIT_MESSAGE_UTIL->save($commit_message_ctx);
556    if (!$option_ref->{'dry-run'}) {
557      return _cm_abort();
558    }
559  }
560
561  return;
562}
563
564# ------------------------------------------------------------------------------
565# SYNOPSIS
566#   &FCM1::Cm::cm_merge ();
567#
568# DESCRIPTION
569#   This is a wrapper to "svn merge".
570# ------------------------------------------------------------------------------
571
572sub cm_merge {
573  my ($option_ref, @args) = @_;
574  # Find out the URL of the working copy
575  if (!is_wc()) {
576    return _cm_err(FCM1::Cm::Exception->INVALID_WC, '.');
577  }
578  my $wct = $SVN->get_wc_root();
579  if ($wct ne cwd()) {
580    chdir($wct) || return _cm_err(FCM1::Cm::Exception->CHDIR, $wct);
581    $CLI_MESSAGE->('CHDIR_WCT', $wct);
582  }
583  my $target = FCM1::CmBranch->new(URL => get_url_of_wc($wct));
584  if (!$target->url_exists()) {
585    return _cm_err(FCM1::Cm::Exception->WC_URL_NOT_EXIST, '.');
586  }
587
588  # The target must be at the top of a branch
589  # $subdir will be used later to determine whether the merge is allowed or not
590  my $subdir = $target->subdir();
591  if ($subdir) {
592    $target->url_peg($target->branch_url_peg());
593  }
594
595  # Check for any local modifications
596  # ----------------------------------------------------------------------------
597  if (!$option_ref->{'dry-run'} && !$option_ref->{'non-interactive'}) {
598    _svn_status_checker('merge', 'MODIFIED', $CLI_HANDLER_OF{WC_STATUS})->();
599  }
600
601  # Determine the SOURCE URL
602  # ----------------------------------------------------------------------------
603  my $source;
604
605  if ($option_ref->{reverse}) {
606    # Reverse merge, the SOURCE is the working copy URL
607    $source = FCM1::CmBranch->new (URL => $target->url);
608
609  } else {
610    # Automatic/custom merge, argument 1 is the SOURCE of the merge
611    my $source_url = shift (@args);
612    if (!$source_url) {
613      _cli_err('CLI_MERGE_ARG1');
614    }
615
616    $source = _cm_get_source($source_url, $target);
617  }
618
619  # Parse the revision option
620  # ----------------------------------------------------------------------------
621  my @revs
622    = (grep {$option_ref->{$_}} qw{reverse custom}) && $option_ref->{revision}
623    ? split(qr{:}xms, $option_ref->{revision})
624    : ();
625
626  # Determine the merge delta and the commit log message
627  # ----------------------------------------------------------------------------
628  my (@delta, $mesg, @logs);
629  my $separator = '-' x 80 . "\n";
630
631  if ($option_ref->{reverse}) {
632    # Reverse merge
633    # --------------------------------------------------------------------------
634    if (@revs == 0) {
635      my $last_commit_rev = $source->svninfo('FLAG' => 'commit:revision');
636      @revs = ($last_commit_rev, $last_commit_rev - 1);
637    }
638    elsif (@revs == 1) {
639      $revs[1] = ($revs[0] - 1);
640    }
641    else {
642      @revs = sort {$b <=> $a} @revs;
643    }
644
645    # "Delta" of the "svn merge" command
646    @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
647
648    # Template message
649    $mesg = 'Reversed r' . $revs[0];
650    if ($revs[1] < $revs[0] - 1) {
651      $mesg .= ':' . $revs[1];
652    }
653    if ($source->path()) {
654      $mesg .= ' of ' . $source->path();
655    }
656    $mesg .= "\n";
657
658  } elsif ($option_ref->{custom}) {
659    # Custom merge
660    # --------------------------------------------------------------------------
661    if (@revs) {
662      # Revision specified
663      # ------------------------------------------------------------------------
664      # Only one revision N specified, use (N - 1):N as the delta
665      unshift @revs, ($revs[0] - 1) if @revs == 1;
666      $source->url_peg(
667        $source->branch_url() . '/' . $subdir . '@' . $source->pegrev(),
668      );
669      $target->url_peg(
670        $target->branch_url() . '/' . $subdir . '@' . $target->pegrev(),
671      );
672
673      # "Delta" of the "svn merge" command
674      @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
675
676      # Template message
677      $mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] .
678              ' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n";
679
680    } else {
681      # Revision not specified
682      # ------------------------------------------------------------------------
683      # Get second source URL
684      my $source2_url = shift (@args);
685      if (!$source2_url) {
686        _cli_err('CLI_MERGE_ARG2');
687      }
688
689      my $source2 = _cm_get_source($source2_url, $target);
690      for my $item ($source, $source2, $target) {
691        $item->url_peg($item->branch_url() . '/' . $subdir . '@' . $item->pegrev());
692      }
693
694      # "Delta" of the "svn merge" command
695      @delta = ($source->url_peg, $source2->url_peg);
696
697      # Template message
698      $mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg .
699              ' cf. ' . $source2->path_peg . "\n";
700    }
701
702  } else {
703    # Automatic merge
704    # --------------------------------------------------------------------------
705    # Check to ensure source branch is not the same as the target branch
706    if (!$target->branch()) {
707      return _cm_err(FCM1::Cm::Exception->WC_INVALID_BRANCH, $wct);
708    }
709    if ($source->branch() eq $target->branch()) {
710      return _cm_err(FCM1::Cm::Exception->MERGE_SELF, $target->url_peg(), $wct);
711    }
712
713    # Only allow the merge if the source and target are "directly related"
714    # --------------------------------------------------------------------------
715    my $anc = $target->ancestor ($source);
716    return _cm_err(
717      FCM1::Cm::Exception->MERGE_UNRELATED, $target->url_peg(), $source->url_peg
718    ) unless
719      ($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg)
720      or
721      ($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg)
722      or
723      ($anc->url eq $source->parent->url and $anc->url eq $target->parent->url);
724
725    # Check for available merges from the source
726    # --------------------------------------------------------------------------
727    my @revs = $target->avail_merge_from ($source, 1);
728
729    if (@revs) {
730      if ($option_ref->{verbose}) {
731        # Verbose mode, print log messages of available merges
732        $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), q{});
733        for (@revs) {
734          $CLI_MESSAGE->('SEPARATOR');
735          $CLI_MESSAGE->(q{}, $source->display_svnlog($_));
736        }
737        $CLI_MESSAGE->('SEPARATOR');
738      }
739      else {
740        # Normal mode, list revisions of available merges
741        $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), join(q{ }, @revs));
742      }
743
744    } else {
745      return _cm_abort(FCM1::Cm::Abort->NULL);
746    }
747
748    # If more than one merge available, prompt user to enter a revision number
749    # to merge from, default to $revs [0]
750    # --------------------------------------------------------------------------
751    if ($option_ref->{'non-interactive'} || @revs == 1) {
752      $source->url_peg($source->url() . '@' . $revs[0]);
753    }
754    else {
755      my $reply = $CLI_PROMPT->(
756        {type => q{}, default => $revs[0]}, 'merge', 'MERGE_REV',
757      );
758      if (!defined($reply)) {
759        return _cm_abort();
760      }
761      # Expand revision keyword if necessary
762      if ($reply) {
763        $reply = (FCM1::Keyword::expand($target->project_url(), $reply))[1];
764      }
765      # Check that the reply is a number in the available merges list
766      if (!grep {$_ eq $reply} @revs) {
767        return _cm_err(FCM1::Cm::Exception->MERGE_REV_INVALID, $reply)
768      }
769      $source->url_peg($source->url() . '@' . $reply);
770    }
771
772    # If the working copy top is pointing to a sub-directory of a branch,
773    # we need to check whether the merge will result in losing changes made in
774    # other sub-directories of the source.
775    if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) {
776      return _cm_err(FCM1::Cm::Exception->MERGE_UNSAFE, $source->url_peg());
777    }
778
779    # Calculate the base of the merge
780    my $base = $target->base_of_merge_from ($source);
781
782    # $source and $base must take into account the sub-directory
783    my $source_full = FCM1::CmBranch->new (URL => $source->url_peg);
784    my $base_full = FCM1::CmBranch->new (URL => $base->url_peg);
785
786    if ($subdir) {
787      $source_full->url_peg(
788        $source_full->branch_url() . '/' . $subdir . '@' . $source_full->pegrev()
789      );
790      $base_full->url_peg(
791        $base_full->branch_url() . '/' . $subdir . '@' . $base_full->pegrev()
792      );
793    }
794
795    # Diagnostic
796    $CLI_MESSAGE->('SEPARATOR'); 
797    $CLI_MESSAGE->('MERGE_COMPARE', $source->path_peg(), $base->path_peg()); 
798    # Delta of the "svn merge" command
799    @delta = ($base_full->url_peg, $source_full->url_peg);
800
801    # Template message
802    $mesg = sprintf(
803      "Merged into %s: %s cf. %s",
804      $target->path(), $source->path_peg(), $base->path_peg(),
805    );
806
807    if (exists($option_ref->{'auto-log'})) {
808      my $last_merge_from_source = ($target->last_merge_from($source))[1];
809      if (!defined($last_merge_from_source)) {
810        $last_merge_from_source = $target->ancestor($source);
811      }
812      my %log_entries = $source->svnlog(
813        REV => [$last_merge_from_source->pegrev() + 1, $source->pegrev()],
814      );
815      @logs = sort {$b->{'revision'} <=> $a->{'revision'}} values(%log_entries);
816    }
817  }
818
819  # Run "svn merge" in "--dry-run" mode to see the result
820  # ----------------------------------------------------------------------------
821  my $dry_run_output
822    = $SVN->stdout(qw{svn merge --dry-run --non-interactive}, @delta);
823
824  # Abort merge if it will result in no change
825  if (!$dry_run_output) {
826    return _cm_abort(FCM1::Cm::Abort->NULL);
827  }
828
829  # Report result of "svn merge --dry-run"
830  if ($option_ref->{'dry-run'} || !$option_ref->{'non-interactive'}) {
831    $CLI_MESSAGE->('MERGE_DRYRUN', $dry_run_output);
832  }
833
834  return if $option_ref->{'dry-run'};
835
836  # Prompt the user to see if (s)he would like to go ahead
837  # ----------------------------------------------------------------------------
838  # Go ahead with merge only if user replies "y"
839  if (
840    !$option_ref->{'non-interactive'} && $CLI_PROMPT->('merge', 'MERGE') ne 'y'
841  ) {
842    return _cm_abort();
843  }
844  $SVN->call('cleanup');
845  my $output = $SVN->stdout(qw{svn merge --non-interactive}, @delta);
846  $CLI_MESSAGE->('MERGE_OK');
847  if ($output ne $dry_run_output) {
848    $CLI_MESSAGE->('MERGE_ACTUAL', $output);
849  }
850
851  # Prepare the commit log
852  # ----------------------------------------------------------------------------
853  my $commit_message_ctx = $COMMIT_MESSAGE_UTIL->load();
854  my @auto_log = map {
855    my $log_entry = $_;
856    my @msg_list = (
857      map  {q{> } . $_}
858      grep {
859            $_
860        &&  $_ !~ qr{\AMerged\sinto\s\S+:\s(?:\S+)\scf\.\s(?:\S+)\z}msx
861        &&  $_ !~ qr{\A(?:\#\d+(?:,\#\d+)*:\s)?Created\s\S+\sfrom\s\S+\.\z}msx
862        &&  $_ !~ qr{\Ar\d+:\z}msx
863        &&  $_ !~ qr{\A>\s.+\z}msx
864      }
865      split("\n", $log_entry->{'msg'})
866    );
867    @msg_list ? ('----', 'r' . $log_entry->{'revision'} . ':', @msg_list) : ();
868  } @logs;
869  my @messages = (
870    $mesg,
871    (@auto_log ? (@auto_log, '----'): ()),
872    $commit_message_ctx->get_auto_part()
873  );
874  $commit_message_ctx->set_auto_part(join("\n", @messages));
875  $COMMIT_MESSAGE_UTIL->save($commit_message_ctx);
876
877  return;
878}
879
880# ------------------------------------------------------------------------------
881# SYNOPSIS
882#   &FCM1::Cm::cm_mkpatch ();
883#
884# DESCRIPTION
885#   This is a FCM command to create a patching script from particular revisions
886#   of a URL.
887# ------------------------------------------------------------------------------
888
889sub cm_mkpatch {
890  my ($option_ref, $u, $outdir) = @_;
891  # Process command line options and arguments
892  my @exclude = $option_ref->{exclude} ? @{$option_ref->{exclude}} : ();
893  my $organisation = $option_ref->{organisation};
894  my $revision = $option_ref->{revision};
895
896  # Excluded paths, convert glob into regular patterns
897  @exclude = split (/:/, join (':', @exclude));
898  for (@exclude) {
899    s#\*#[^/]*#; # match any number of non-slash character
900    s#\?#[^/]#;  # match a non-slash character
901    s#/*$##;     # remove trailing slash
902  }
903
904  # Organisation prefix
905  $organisation ||= 'original';
906
907  # Make sure revision option is set correctly
908  my @revs = $revision ? split (/:/, $revision) : ();
909  @revs    = @revs [0, 1] if @revs > 2;
910
911  if (!$u) {
912    _cli_err('CLI_USAGE', 'URL');
913  }
914
915  my $url = FCM1::CmUrl->new (URL => $u);
916  if (!$url->is_url()) {
917    return _cm_err(FCM1::Cm::Exception->INVALID_URL, $u);
918  }
919  if (!$url->url_exists()) {
920    return _cm_err(FCM1::Cm::Exception->NOT_EXIST, $u);
921  }
922  if (!$url->branch()) {
923    $CLI_MESSAGE->('INVALID_BRANCH', $u);
924  }
925  elsif ($url->subdir()) {
926    $CLI_MESSAGE->('BRANCH_SUBDIR', $u);
927  }
928
929  if (@revs) {
930    # If HEAD revision is given, convert it into a number
931    # --------------------------------------------------------------------------
932    for my $rev (@revs) {
933      $rev = $url->svninfo(FLAG => 'revision') if uc ($rev) eq 'HEAD';
934    }
935
936  } else {
937    # If no revision is given, use the HEAD
938    # --------------------------------------------------------------------------
939    $revs[0] = $url->svninfo(FLAG => 'revision');
940  }
941
942  $revs[1] = $revs[0] if @revs == 1;
943
944  # Check that output directory is set
945  # ----------------------------------------------------------------------------
946  $outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir;
947
948  if (-e $outdir) {
949    # Ask user to confirm removal of old output directory if it exists
950    if ($CLI_PROMPT->('mkpatch', 'MKPATCH_OVERWRITE', $outdir) ne 'y') {
951      return _cm_abort();
952    }
953
954    rmtree($outdir) || return _cm_err(FCM1::Cm::Exception->RMTREE, $outdir);
955  }
956
957  # (Re-)create output directory
958  mkpath($outdir) || return _cm_err(FCM1::Cm::Exception->MKPATH, $outdir);
959  $CLI_MESSAGE->('OUT_DIR', $outdir);
960
961  # Get and process log of URL
962  # ----------------------------------------------------------------------------
963  my @script   = (); # main output script
964  my %log      = $url->svnlog (REV => \@revs);
965  my $url_path = $url->path;
966
967  for my $rev (sort {$a <=> $b} keys %log) {
968    # Look at the changed paths for each revision
969    my $use_patch     = 1; # OK to use a patch file?
970    my $only_modified = 1; # Change only contains modifications?
971    my @paths;
972    PATH: for my $path (sort keys %{ $log{$rev}{paths} }) {
973      my $file = $path;
974
975      # Skip paths outside of the branch
976      next PATH unless $file =~ s#^$url_path/##;
977
978      # Skip excluded paths
979      for my $exclude (@exclude) {
980        if ($file =~ m#^$exclude(?:/|$)#) {
981          # Can't use a patch file if any files have been excluded
982          $use_patch = 0;
983          next PATH;
984        }
985      }
986
987      # Can't use a patch file if any files have been added or replaced
988      $use_patch = 0 if $log{$rev}{paths}{$path}{action} eq 'A' or
989                        $log{$rev}{paths}{$path}{action} eq 'R';
990
991      $only_modified = 0 unless $log{$rev}{paths}{$path}{action} eq 'M';
992
993      push @paths, $path;
994    }
995
996    # If the change only contains modifications, make sure they aren't
997    # just property changes
998    if ($only_modified) {
999      my @changedpaths;
1000      for my $path (@paths) {
1001        (my $file = $path) =~ s#^$url_path/*##;
1002        my @diff = $SVN->stdout(
1003          qw{svn diff --no-diff-deleted --summarize -c}, $rev,
1004          sprintf("%s/%s@%s", $url->url(), $file, $rev),
1005        );
1006        next unless $diff[-1] =~ /^[A-Z]/;
1007        push @changedpaths, $path;
1008      }
1009      @paths = @changedpaths;
1010    }
1011
1012    next unless @paths;
1013
1014    # Create the patch using "svn diff"
1015    my $patch = ();
1016    if ($use_patch) {
1017      $patch = $SVN->stdout(
1018          qw{svn diff --no-diff-deleted -c}, $rev, $url->url(),
1019      );
1020      if ($patch) {
1021        # Don't use the patch if it may contain subversion keywords or
1022        # any changes to PDF files or any changes to symbolic links or
1023        # any carriage returns in the middle of a line
1024        for (split(qr{\n}msx, $patch)) {
1025          if (/\$[a-zA-Z:]+ *\$/ or /^--- .+\.pdf\t/ or /^\+link / or /\r.+/) {
1026            $use_patch = 0;
1027            last;
1028          }
1029        }
1030      } else {
1031        $use_patch = 0;
1032      }
1033    }
1034
1035    # Create a directory for this revision in the output directory
1036    my $outdir_rev = File::Spec->catfile ($outdir, $rev);
1037    mkpath($outdir_rev)
1038      || return _cm_err(FCM1::Cm::Exception->MKPATH, $outdir_rev);
1039
1040    # Parse commit log message
1041    my @msg = split /\n/, $log{$rev}{msg};
1042    for (@msg) {
1043      # Re-instate line break
1044      $_ .= "\n";
1045
1046      # Remove line if it matches a merge template
1047      $_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/;
1048      $_ = '' if /^Custom merge into \S+:.+$/;
1049      $_ = '' if /^Merged into \S+: \S+ cf\. \S+$/;
1050
1051      # Modify Trac ticket link
1052      s/(?:#|ticket:)(\d+)/${organisation}_ticket:$1/g;
1053
1054      # Modify Trac changeset link
1055      s/(?:r|changeset:)(\d+)/${organisation}_changeset:$1/g;
1056      s/\[(\d+)\]/${organisation}_changeset:$1/g;
1057    }
1058
1059    push @msg, '(' . $organisation . '_changeset:' . $rev . ')' . "\n";
1060
1061    # Write commit log message in a file
1062    my $f_revlog = File::Spec->catfile ($outdir_rev, 'log-message');
1063    open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')';
1064    print FILE @msg;
1065    close FILE or die $f_revlog, ': cannot close (', $!, ')';
1066
1067    # Handle each changed path
1068    my $export_file   = 1;  # name for next exported file (gets incremented)
1069    my $patch_needed  = 0;  # is a patch file required?
1070    my @before_script = (); # patch script to run before patch applied
1071    my @after_script  = (); # patch script to run after patch applied
1072    my @copied_dirs   = (); # copied directories
1073    CHANGED: for my $path (@paths) {
1074      (my $file = $path) =~ s#^$url_path/*##;
1075      my $url_file = $url->url . '/' . $file . '@' . $rev;
1076
1077      # Skip paths within copied directories
1078      for my $copied_dir (@copied_dirs) {
1079        next CHANGED if $file =~ m#^$copied_dir(?:/|$)#;
1080      }
1081
1082      # Handle deleted files
1083      if ($log{$rev}{paths}{$path}{action} eq 'D') {
1084        push @after_script, 'svn delete "' . $file . '"';
1085
1086      } else {
1087        # Skip property changes (if not done earlier)
1088        if (not $only_modified and $log{$rev}{paths}{$path}{action} eq 'M') {
1089          my @diff = $SVN->stdout(
1090            qw{svn diff --no-diff-deleted --summarize -c}, $rev, $url_file,
1091          );
1092          next CHANGED unless $diff[-1] =~ /^[A-Z]/;
1093        }
1094
1095        # Determine if the file is a directory
1096        my $is_dir
1097          =     $log{$rev}{paths}{$path}{action} ne 'M'
1098            &&  $SVN->get_info($url_file)->[0]->{'kind'} eq 'dir';
1099
1100        # Decide how to treat added files
1101        my $export_required = 0;
1102        if ($log{$rev}{paths}{$path}{action} eq 'A') {
1103          my $is_newfile = 0;
1104          # Determine if the file is copied
1105          if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) {
1106            if ($is_dir) {
1107              # A copied directory needs to be exported and added recursively
1108              push @after_script, 'svn add "' . $file . '"';
1109              $export_required = 1;
1110              push @copied_dirs, $file;
1111            } else {
1112              # History exists for this file
1113              my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'};
1114              my $copyfrom_rev  = $log{$rev}{paths}{$path}{'copyfrom-rev'};
1115              my $cp_url = FCM1::CmUrl->new (
1116                URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev,
1117              );
1118
1119              if ($copyfrom_path =~ s#^$url_path/*##) {
1120                # File is copied from a file under the specified URL
1121                # Check source exists
1122                $is_newfile = 1 unless $cp_url->url_exists ($rev - 1);
1123              } else {
1124                # File copied from outside of the specified URL
1125                $is_newfile = 1;
1126
1127                # Check branches can be determined
1128                if ($url->branch and $cp_url->branch) {
1129
1130                  # Follow its history, stop on copy
1131                  my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1);
1132
1133                  # "First" revision of the copied file
1134                  my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0];
1135                  my %attrib = %{ $cp_log{$cp_rev}{paths}{$cp_url->path} }
1136                    if $cp_log{$cp_rev}{paths}{$cp_url->path};
1137
1138                  # Check whether the "first" revision is copied from elsewhere.
1139                  if (exists $attrib{'copyfrom-path'}) {
1140                    # If source exists in the specified URL, set up the copy
1141                    my $cp_cp_url = FCM1::CmUrl->new (
1142                      URL => $url->root . $attrib{'copyfrom-path'} . '@' .
1143                             $attrib{'copyfrom-rev'},
1144                    );
1145                    if ($cp_cp_url->subdir()) {
1146                      $cp_cp_url->url_peg(
1147                        $cp_cp_url->project_url()
1148                        . '/' . $url->branch()
1149                        . '/' . $cp_cp_url->subdir()
1150                        . '@' . $cp_cp_url->pegrev(),
1151                      );
1152                      if ($cp_cp_url->url_exists ($rev - 1)) {
1153                        ($copyfrom_path = $cp_cp_url->path) =~ s#^$url_path/*##;
1154                        # Check path is defined - if not it probably means the
1155                        # branch doesn't follow the FCM naming convention
1156                        $is_newfile = 0 if $copyfrom_path;
1157                      }
1158                    }
1159                  }
1160
1161                  # Note: The logic above does not cover all cases. However, it
1162                  # should do the right thing for the most common case. Even
1163                  # where it gets it wrong the file contents should always be
1164                  # correct even if the file history is not.
1165                }
1166              }
1167
1168              # Check whether file is copied from an excluded or copied path
1169              if (not $is_newfile) {
1170                for my $path (@exclude,@copied_dirs) {
1171                  if ($copyfrom_path =~ m#^$path(?:/|$)#) {
1172                    $is_newfile = 1;
1173                    last;
1174                  }
1175                }
1176              }
1177
1178              # Check whether file is copied from a file which has been replaced
1179              if (not $is_newfile) {
1180                my $copyfrom_fullpath = $url->branch_path . "/" . $copyfrom_path;
1181                $is_newfile = 1 if ($log{$rev}{paths}{$copyfrom_fullpath}{action} and
1182                                    $log{$rev}{paths}{$copyfrom_fullpath}{action} eq 'R');
1183              }
1184
1185              # Copy the file, if required
1186              push @before_script, 'svn copy ' . $copyfrom_path .  ' "' . $file . '"'
1187                if not $is_newfile;
1188            }
1189
1190          } else {
1191            # History does not exist, must be a new file
1192            if ($is_dir) {
1193              # If it's a directory then create it and add it immediately
1194              # (in case it contains any copied files)
1195              push @before_script, 'mkdir "' . $file. '"';
1196              push @before_script, 'svn add "' . $file . '"';
1197            } else {
1198              $is_newfile = 1;
1199       }
1200          }
1201
1202          # Add the file, if required
1203          if ($is_newfile) {
1204            push @after_script, 'svn add "' . $file . '"';
1205          }
1206        }
1207
1208        if ($is_dir and $log{$rev}{paths}{$path}{action} eq 'R') {
1209          # Subversion does not appear to support replacing a directory in a
1210          # single transaction from a working copy (other than as the result
1211          # of a merge). Therefore the delete of the old directory must be
1212          # done in advance as a separate commit.
1213          push @script, 'svn delete -m "Delete directory in preparation for' .
1214            ' replacing it (part of ' . $organisation . '_changeset:' . $rev .
1215            ')" $target/' . $file;
1216          push @script, 'svn update --non-interactive';
1217          # The replaced directory needs to be exported and added recursively
1218          push @after_script, 'svn add "' . $file . '"';
1219          $export_required = 1;
1220          push @copied_dirs, $file;
1221        }
1222
1223        if (not $is_dir and $log{$rev}{paths}{$path}{action} ne 'A') {
1224          my ($was_symlink) = $SVN->stdout(
1225            qw{svn propget svn:special},
1226            sprintf("%s/%s@%d", $url->url(), $file, ($rev - 1)),
1227          );
1228          my ($is_symlink) = $SVN->stdout(
1229            qw{svn propget svn:special}, $url_file,
1230          );
1231          if ($was_symlink and not $is_symlink) {
1232            # A symbolic link has been changed to a normal file
1233            push @before_script, 'svn propdel -q svn:special "' . $file . '"';
1234            push @before_script, 'rm "' . $file . '"';
1235     } elsif ($log{$rev}{paths}{$path}{action} eq 'R') {
1236            # Delete the old file and then add the new file
1237            push @before_script, 'svn delete "' . $file . '"';
1238            push @after_script, 'svn add "' . $file . '"';
1239          } elsif ($is_symlink and not $was_symlink) {
1240            # A normal file has been changed to a symbolic link
1241            push @after_script, 'svn propset -q svn:special \* "' . $file . '"';
1242          } elsif ($is_symlink and $was_symlink) {
1243            # If a symbolic link has been modified then remove the old
1244            # copy first to allow the copy to work
1245            push @before_script, 'rm "' . $file . '"';
1246          }
1247        }
1248
1249        # Decide whether the file needs to be exported
1250        if (not $is_dir) {
1251          if (not $use_patch) {
1252            $export_required = 1;
1253          } else {
1254            # Export the file if it is binary
1255            my @file_diff = $SVN->stdout(
1256              qw{svn diff --no-diff-deleted -c}, $rev, $url_file,
1257            );
1258            for (@file_diff) {
1259              $export_required = 1 if /Cannot display: file marked as a binary type./;
1260            }
1261            # Only create a patch file if necessary
1262            $patch_needed = 1 if not $export_required;
1263          }
1264        }
1265
1266        if ($export_required) {
1267          # Download the file using "svn export"
1268          my $export = File::Spec->catfile ($outdir_rev, $export_file);
1269          $SVN->call(qw{export -q -r}, $rev, $url_file, $export);
1270
1271          # Copy the exported file into the file
1272          push @before_script,
1273               'cp -r ${fcm_patch_dir}/' . $export_file . ' "' . $file . '"';
1274          $export_file++;
1275        }
1276      }
1277    }
1278
1279    # Write the patch file
1280    if ($patch_needed) {
1281      my $patchfile = File::Spec->catfile ($outdir_rev, 'patchfile');
1282      open FILE, '>', $patchfile
1283        or die $patchfile, ': cannot open (', $!, ')';
1284      print FILE $patch;
1285      close FILE or die $patchfile, ': cannot close (', $!, ')';
1286    }
1287
1288    # Add line break to each line in @before_script and @after_script
1289    @before_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")}
1290                     @before_script if (@before_script);
1291    @after_script  = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")}
1292                     @after_script if (@after_script);
1293
1294    # Write patch script to output
1295    my $out = File::Spec->catfile ($outdir_rev, 'apply-patch');
1296    open FILE, '>', $out or die $out, ': cannot open (', $!, ')';
1297
1298    # Script header
1299    print FILE <<EOF;
1300#!/usr/bin/env bash
1301# ------------------------------------------------------------------------------
1302# NAME
1303#   apply-patch
1304#
1305# DESCRIPTION
1306#   This script is generated automatically by the "fcm mkpatch" command. It
1307#   applies the patch to the current working directory which must be a working
1308#   copy of a valid project tree that can accept the import of the patches.
1309#
1310#   Patch created from $organisation URL: $u
1311#   Changeset: $rev
1312# ------------------------------------------------------------------------------
1313
1314this=`basename \$0`
1315echo "\$this: Applying patch for changeset $rev."
1316
1317# Location of the patch, base on the location of this script
1318cd `dirname \$0` || exit 1
1319fcm_patch_dir=\$PWD
1320
1321# Change directory back to the working copy
1322cd \$OLDPWD || exit 1
1323
1324# Check working copy does not have local changes
1325status=`svn status`
1326if [[ -n \$status ]]; then
1327  echo "\$this: working copy contains changes, abort." >&2
1328  exit 1
1329fi
1330if [[ -a "#commit_message#" ]]; then
1331  echo "\$this: existing commit message in "#commit_message#", abort." >&2
1332  exit 1
1333fi
1334
1335# Apply the changes
1336patch_command=\${patch_command:-"patch --no-backup-if-mismatch -p0"}
1337EOF
1338
1339    # Script content
1340    print FILE @before_script if @before_script;
1341    print FILE "\$patch_command <\${fcm_patch_dir}/patchfile || exit 1\n"
1342      if $patch_needed;
1343    print FILE @after_script  if @after_script;
1344
1345    # Script footer
1346    print FILE <<EOF;
1347
1348# Copy in the commit message
1349cp \${fcm_patch_dir}/log-message "#commit_message#"
1350
1351echo "\$this: finished normally."
1352#EOF
1353EOF
1354
1355    close FILE or die $out, ': cannot close (', $!, ')';
1356
1357    # Add executable permission
1358    chmod 0755, $out;
1359
1360    # Script to commit the change
1361    push @script, '${fcm_patches_dir}/' . $rev . '/apply-patch';
1362    push @script, 'svn commit -F "#commit_message#"';
1363    push @script, 'rm -f "#commit_message#"';
1364    push @script, 'svn update --non-interactive';
1365    push @script, '';
1366
1367    $CLI_MESSAGE->('PATCH_REV', $rev);
1368  }
1369
1370  # Write the main output script if necessary. Otherwise remove output directory
1371  # ----------------------------------------------------------------------------
1372  if (@script) {
1373    # Add line break to each line in @script
1374    @script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @script;
1375
1376    # Write script to output
1377    my $out = File::Spec->catfile ($outdir, 'fcm-import-patch');
1378    open FILE, '>', $out or die $out, ': cannot open (', $!, ')';
1379
1380    # Script header
1381    print FILE <<EOF;
1382#!/usr/bin/env bash
1383# ------------------------------------------------------------------------------
1384# NAME
1385#   fcm-import-patch
1386#
1387# SYNOPSIS
1388#   fcm-import-patch TARGET
1389#
1390# DESCRIPTION
1391#   This script is generated automatically by the "fcm mkpatch" command, as are
1392#   the revision "patches" created in the same directory. The script imports the
1393#   patches into TARGET, which must either be a URL or a working copy of a valid
1394#   project tree that can accept the import of the patches.
1395#
1396#   Patch created from $organisation URL: $u
1397# ------------------------------------------------------------------------------
1398
1399this=`basename \$0`
1400
1401# Check argument
1402target=\$1
1403
1404# First argument must be a URL or working copy
1405if [[ -z \$target ]]; then
1406  echo "\$this: the first argument must be a URL or a working copy, abort." >&2
1407  exit 1
1408fi
1409
1410if [[ \$target == svn://*  || \$target == svn+ssh://* || \\
1411      \$target == http://* || \$target == https://*   || \\
1412      \$target == file://* ]]; then
1413  # A URL, checkout a working copy in a temporary location
1414  fcm_tmp_dir=`mktemp -d \${TMPDIR:=/tmp}/\$this.XXXXXX`
1415  fcm_working_copy=\$fcm_tmp_dir
1416  svn checkout -q \$target \$fcm_working_copy || exit 1
1417else
1418  fcm_working_copy=\$target
1419  target=`svn info \$fcm_working_copy | grep "^URL: " | sed 's/URL: //'` || exit 1
1420fi
1421
1422# Location of the patches, base on the location of this script
1423cd `dirname \$0` || exit 1
1424fcm_patches_dir=\$PWD
1425
1426# Change directory to the working copy
1427cd \$fcm_working_copy || exit 1
1428
1429# Set the language to avoid encoding problems
1430if locale -a | grep -q en_GB\$; then
1431  export LANG=en_GB
1432fi
1433
1434# Commands to apply patches
1435EOF
1436
1437    # Script content
1438    print FILE @script;
1439
1440    # Script footer
1441    print FILE <<EOF;
1442# Check working copy does not have local changes
1443status=`svn status`
1444if [[ -n \$status ]]; then
1445  echo "\$this: working copy still contains changes, abort." >&2
1446  exit 1
1447fi
1448
1449# Remove temporary working copy, if necessary
1450if [[ -d \$fcm_tmp_dir && -w \$fcm_tmp_dir ]]; then
1451  rm -rf \$fcm_tmp_dir
1452fi
1453
1454echo "\$this: finished normally."
1455#EOF
1456EOF
1457
1458    close FILE or die $out, ': cannot close (', $!, ')';
1459
1460    # Add executable permission
1461    chmod 0755, $out;
1462
1463    # Diagnostic
1464    $CLI_MESSAGE->('PATCH_DONE', $outdir);
1465
1466  } else {
1467    # Remove output directory
1468    rmtree $outdir or die $outdir, ': cannot remove';
1469
1470    # Diagnostic
1471    return _cm_abort(FCM1::Cm::Abort->NULL);
1472  }
1473
1474  return 1;
1475}
1476
1477# ------------------------------------------------------------------------------
1478# CLI error.
1479sub _cli_err {
1480    my ($key, @args) = @_;
1481    my $message = sprintf($CLI_MESSAGE_FOR_ERROR{$key}, @args);
1482    die(FCM1::CLI::Exception->new({message => $message}));
1483}
1484
1485# ------------------------------------------------------------------------------
1486# The default handler of the "WC_STATUS" event.
1487sub _cli_handler_of_wc_status {
1488    my ($name, $target_list_ref, $status_list_ref) = @_;
1489    $target_list_ref ||= [q{.}];
1490    if (@{$status_list_ref}) {
1491        $CLI_MESSAGE->(
1492            'STATUS',
1493            $name,
1494            q{"} . join(q{", "}, @{$target_list_ref}) . q{"},
1495            join("\n", @{$status_list_ref}),
1496        );
1497        if ($CLI_PROMPT->($name, 'CONTINUE', $name) ne 'y') {
1498            return _cm_abort();
1499        }
1500    }
1501    return @{$status_list_ref};
1502}
1503
1504# ------------------------------------------------------------------------------
1505# The default handler of the "WC_STATUS_PATH" event.
1506sub _cli_handler_of_wc_status_path {
1507    my ($name, $target_list_ref, $status_list_ref) = @_;
1508    my $message
1509        = @{$status_list_ref} ? (join("\n", @{$status_list_ref}) . "\n") : q{};
1510    $CLI_MESSAGE->(q{}, $message);
1511    my @paths = map {chomp(); ($_ =~ $PATTERN_OF{ST_PATH})} @{$status_list_ref};
1512    my @paths_of_interest;
1513    while (my $path = shift(@paths)) {
1514        my %handler_of = (
1515            a => sub {push(@paths_of_interest, $path, @paths); @paths = ()},
1516            n => sub {},
1517            y => sub {push(@paths_of_interest, $path)},
1518        );
1519        my $reply = $CLI_PROMPT->(
1520            {type => 'yna'}, $name, 'RUN_SVN_COMMAND', "$name $path",
1521        );
1522        $handler_of{$reply}->();
1523    }
1524    return @paths_of_interest;
1525}
1526
1527# ------------------------------------------------------------------------------
1528# Expands location keywords in a list.
1529sub _cli_keyword_expand_url {
1530    my ($arg_list_ref) = @_;
1531    ARG:
1532    for my $arg (@{$arg_list_ref}) {
1533        my ($label, $value) = ($arg =~ $PATTERN_OF{CLI_OPT});
1534        if (!$label) {
1535            ($label, $value) = (q{}, $arg);
1536        }
1537        if (!$value) {
1538            next ARG;
1539        }
1540        eval {
1541            $value = FCM1::Util::tidy_url(FCM1::Keyword::expand($value));
1542        };
1543        if ($@) {
1544            if ($value ne 'fcm:revision') {
1545                die($@);
1546            }
1547        }
1548        $arg = $label . $value;
1549    }
1550}
1551
1552# ------------------------------------------------------------------------------
1553# Expands revision keywords in -r and --revision options in a list.
1554sub _cli_keyword_expand_rev {
1555    my ($arg_list_ref) = @_;
1556    my @targets;
1557    for my $arg (@{$arg_list_ref}) {
1558        if (-e $arg && is_wc($arg) || is_url($arg)) {
1559            push(@targets, $arg);
1560        }
1561    }
1562    if (!@targets) {
1563        push(@targets, get_url_of_wc());
1564    }
1565    if (!@targets) {
1566        return;
1567    }
1568    my @old_arg_list = @{$arg_list_ref};
1569    my @new_arg_list = ();
1570    ARG:
1571    while (defined(my $arg = shift(@old_arg_list))) {
1572        my ($key, $value) = $arg =~ $PATTERN_OF{CLI_OPT_REV};
1573        if (!$key) {
1574            push(@new_arg_list, $arg);
1575            next ARG;
1576        }
1577        push(@new_arg_list, '--revision');
1578        if (!$value) {
1579            $value = shift(@old_arg_list);
1580        }
1581        my @revs = grep {defined()} ($value =~ $PATTERN_OF{CLI_OPT_REV_RANGE});
1582        my ($url, @url_list) = @targets;
1583        for my $rev (@revs) {
1584            if ($rev !~ $PATTERN_OF{SVN_REV}) {
1585                $rev = (FCM1::Keyword::expand($url, $rev))[1];
1586            }
1587            if (@url_list) {
1588                $url = shift(@url_list);
1589            }
1590        }
1591        push(@new_arg_list, join(q{:}, @revs));
1592    }
1593    @{$arg_list_ref} = @new_arg_list;
1594}
1595
1596# ------------------------------------------------------------------------------
1597# Prints a message.
1598sub _cli_message {
1599    my ($key, @args) = @_;
1600    for (
1601        [\*STDOUT, \%CLI_MESSAGE_FOR        , q{}          ],
1602        [\*STDERR, \%CLI_MESSAGE_FOR_WARNING, q{[WARNING] }],
1603        [\*STDERR, \%CLI_MESSAGE_FOR_ABORT  , q{[ABORT] }  ],
1604        [\*STDERR, \%CLI_MESSAGE_FOR_ERROR  , q{[ERROR] }  ],
1605    ) {
1606        my ($handle, $hash_ref, $prefix) = @{$_};
1607        if (exists($hash_ref->{$key})) {
1608            return printf({$handle} $prefix . $hash_ref->{$key}, @args);
1609        }
1610    }
1611}
1612
1613# ------------------------------------------------------------------------------
1614# Wrapper for FCM1::Interactive::get_input.
1615sub _cli_prompt {
1616    my %option
1617        = (type => 'yn', default => 'n', (ref($_[0]) ? %{shift(@_)} : ()));
1618    my ($name, $key, @args) = @_;
1619    return FCM1::Interactive::get_input(
1620        title   => $CLI_PROMPT_PREFIX . $name,
1621        message => sprintf($CLI_MESSAGE_FOR_PROMPT{$key}, @args),
1622        %option,
1623    );
1624}
1625
1626# ------------------------------------------------------------------------------
1627# Check missing status and delete.
1628sub cm_check_missing {
1629    my %option = %{shift()};
1630    my $checker
1631        = _svn_status_checker('delete', 'MISSING', $option{st_check_handler});
1632    my @paths = $checker->(\@_);
1633    if (@paths) {
1634        $SVN->call('delete', @paths);
1635    }
1636}
1637
1638# ------------------------------------------------------------------------------
1639# Check unknown status and add.
1640sub cm_check_unknown {
1641    my %option = %{shift()};
1642    my $checker
1643        = _svn_status_checker('add', 'UNKNOWN', $option{st_check_handler});
1644    my @paths = $checker->(\@_);
1645    if (@paths) {
1646        $SVN->call('add', @paths);
1647    }
1648}
1649
1650# ------------------------------------------------------------------------------
1651# FCM wrapper to SVN switch.
1652sub cm_switch {
1653    my %option = %{shift()};
1654    my ($source, $path) = @_;
1655    $path ||= cwd();
1656    if (!$source) {
1657        return _cm_err(FCM1::Cm::Exception->INVALID_TARGET, q{});
1658    }
1659    if (!-e $path) {
1660        return _cm_err(FCM1::Cm::Exception->NOT_EXIST, $path);
1661    }
1662    if (!is_wc($path)) {
1663        return _cm_err(FCM1::Cm::Exception->INVALID_WC, $path);
1664    }
1665
1666    # Check for merge template in the commit log file in the working copy
1667    my $path_of_wc = $SVN->get_wc_root($path);
1668    my $commit_message_file = $COMMIT_MESSAGE_UTIL->path($path_of_wc);
1669    my $commit_message_ctx = $COMMIT_MESSAGE_UTIL->load($commit_message_file);
1670    if ($commit_message_ctx->get_auto_part()) {
1671        return _cm_err(
1672            FCM1::Cm::Exception->SWITCH_UNSAFE,
1673            ($path eq $path_of_wc
1674                ? File::Spec->abs2rel($commit_message_file)
1675                : $commit_message_file
1676            ),
1677        );
1678    }
1679
1680    # Check for any local modifications
1681    if (defined($option{st_check_handler})) {
1682        _svn_status_checker('switch', 'MODIFIED', $option{st_check_handler})->(
1683            [$path_of_wc],
1684        );
1685    }
1686
1687    my @targets = $path_of_wc eq cwd() ? () : ($path_of_wc);
1688    $SVN->call('cleanup', @targets);
1689    $SVN->call(
1690        'switch',
1691        '--non-interactive',
1692        ($option{revision} ? ('-r', $option{revision}) : ()),
1693        ($option{quiet}    ? '--quiet'                 : ()),
1694        _cm_get_source(
1695            $source,
1696            FCM1::CmBranch->new(URL => $path_of_wc),
1697        )->url_peg(),
1698        @targets,
1699    );
1700}
1701
1702# ------------------------------------------------------------------------------
1703# FCM wrapper to SVN update.
1704sub cm_update {
1705    my %option = %{shift()};
1706    my @targets = @_;
1707    if (!@targets) {
1708        @targets = (cwd());
1709    }
1710    for my $target (@targets) {
1711        if (!-e $target) {
1712            return _cm_err(FCM1::Cm::Exception->NOT_EXIST, $target);
1713        }
1714        if (!is_wc($target)) {
1715            return _cm_err(FCM1::Cm::Exception->INVALID_WC, $target);
1716        }
1717        $target = $SVN->get_wc_root($target);
1718        if ($target eq cwd()) {
1719            $target = q{.};
1720        }
1721    }
1722    if (defined($option{st_check_handler})) {
1723        my ($matcher_keys_ref, $show_updates)
1724            = defined($option{revision}) ? (['MODIFIED'       ], undef)
1725            :                              (['MODIFIED', 'OOD'], 1    )
1726            ;
1727        my $matcher = sub {
1728            for my $key (@{$matcher_keys_ref}) {
1729                $ST_MATCHER_FOR{$key}->(@_) && return 1;
1730            }
1731        };
1732        _svn_status_checker(
1733            'update', $matcher, $option{st_check_handler}, $show_updates,
1734        )->(\@targets);
1735    }
1736    if ($option{revision} && $option{revision} !~ $PATTERN_OF{SVN_REV}) {
1737        $option{revision} = (
1738            FCM1::Keyword::expand(get_url_of_wc($targets[0]), $option{revision})
1739        )[1];
1740    }
1741    _svn_update(\@targets, \%option);
1742}
1743
1744# ------------------------------------------------------------------------------
1745# Raises an abort exception.
1746sub _cm_abort {
1747    my ($code) = @_;
1748    $code ||= FCM1::Cm::Abort->USER;
1749    die(bless({code => $code, message => 'abort'}, 'FCM1::Cm::Abort'));
1750}
1751
1752# ------------------------------------------------------------------------------
1753# Raises a failure.
1754sub _cm_err {
1755    my ($code, @targets) = @_;
1756    die(bless(
1757        {code => $code, message => "ERROR: $code", targets => \@targets},
1758        'FCM1::Cm::Exception',
1759    ));
1760}
1761
1762# ------------------------------------------------------------------------------
1763# Return a corresponding FCM1::CmBranch instance for $source_url w.r.t. $target.
1764sub _cm_get_source {
1765    my ($source_url, $target) = @_;
1766    if (!$UTIL->uri_match($source_url)) {
1767        # Source not full URL, construct source URL based on target URL
1768        my ($path, $peg) = $source_url =~ qr{\A(.*?)(@[^@/]+)?\z}msx;
1769        my $project = $target->project_path();
1770        if (index($path, $project . '/') == 0) {
1771            # $path contains the full path under the repository root
1772            $path = substr($path, length($project));
1773        }
1774        my %layout_config = %{$target->layout()->get_config()};
1775        if (!grep {!defined($layout_config{"dir-$_"})} qw{trunk branch tag}) {
1776            # $path must be under the specified sub-directories for the trunk,
1777            # branches and tags
1778            my @dirs = map {$layout_config{"dir-$_"}} qw{trunk branch tag};
1779            my @paths = split(qr{/+}msx, $path);
1780            if (!@paths || !grep {$_ eq $paths[0]} @dirs) {
1781                $path = $layout_config{'dir-branch'} . '/' . $path;
1782            }
1783        }
1784        $peg ||= q{};
1785        $source_url = join('/', $target->project_url(), $path) . $peg;
1786    }
1787    my $source = FCM1::CmBranch->new(URL => $source_url);
1788    my $layout = eval {$source->layout()};
1789    if ($@) {
1790        $@ = undef;
1791        return _cm_err(FCM1::Cm::Exception->INVALID_URL, $source_url);
1792    }
1793    if (!$layout->get_branch()) {
1794        return _cm_err(FCM1::Cm::Exception->INVALID_BRANCH, $source_url);
1795    }
1796    $source->url_peg(
1797        $source->branch_url()
1798        . ($target->subdir() ? '/' . $target->subdir() : q{})
1799        . ('@' . $source->pegrev())
1800    );
1801    # Ensure that the source and target URLs are in the same project
1802    if ($source->project_url() ne $target->project_url()) {
1803        return _cm_err(
1804            FCM1::Cm::Exception->DIFF_PROJECTS,
1805            $target->url_peg(),
1806            $source->url_peg(),
1807        );
1808    }
1809    return $source;
1810}
1811
1812# ------------------------------------------------------------------------------
1813# Returns the results of "svn status".
1814sub _svn_status_get {
1815    my ($targets_ref, $show_updates) = @_;
1816    my @targets = (defined($targets_ref) ? @{$targets_ref} : ());
1817    for my $target (@targets) {
1818        if ($target eq cwd()) {
1819            $target = q{.};
1820        }
1821    }
1822    my @options = ($show_updates ? qw{--show-updates} : ());
1823    $SVN->stdout(qw{svn status --ignore-externals}, @options, @targets);
1824}
1825
1826# ------------------------------------------------------------------------------
1827# Returns a "svn status" checker.
1828sub _svn_status_checker {
1829    my ($name, $matcher, $handler, $show_updates) = @_;
1830    if (!ref($matcher)) {
1831        $matcher = $ST_MATCHER_FOR{$matcher};
1832    }
1833    my $P = $PATTERN_OF{ST_PATH};
1834    sub {
1835        my ($targets_ref) = @_;
1836        my @status = _svn_status_get($targets_ref, $show_updates);
1837        if ($show_updates) {
1838            @status = map {$_ =~ $PATTERN_OF{ST_AGAINST_REV} ? () : $_} @status;
1839        }
1840        my @status_of_interest = grep {$matcher->($_)} @status;
1841        # Note: for future expansion...
1842        #my @paths;
1843        #if (!$show_updates) {
1844        #    @paths = map {chomp(); $_} map {($_ =~ $P)} @status_of_interest;
1845        #}
1846        #defined($handler)
1847        #? $handler->($name, $targets_ref, \@status_of_interest, \@paths)
1848        #: @status_of_interest
1849        #;
1850        defined($handler)
1851        ? $handler->($name, $targets_ref, \@status_of_interest)
1852        : @status_of_interest
1853        ;
1854    };
1855}
1856
1857# ------------------------------------------------------------------------------
1858# Runs "svn update".
1859sub _svn_update {
1860    my ($targets_ref, $option_hash_ref) = @_;
1861    my %option = (defined($option_hash_ref) ? %{$option_hash_ref} : ());
1862    my @targets = defined($targets_ref) ? @{$targets_ref} : ();
1863    $SVN->call('cleanup', @targets);
1864    $SVN->call(
1865        'update',
1866        '--non-interactive',
1867        ($option{revision} ? ('-r', $option{revision}) : ()),
1868        ($option{quiet}    ? '--quiet'                 : ()),
1869        @targets,
1870    );
1871}
1872
1873# ------------------------------------------------------------------------------
1874# CLI exception.
1875package FCM1::CLI::Exception;
1876use base qw{FCM1::Exception};
1877
1878# ------------------------------------------------------------------------------
1879# Abort exception.
1880package FCM1::Cm::Abort;
1881use base qw{FCM1::Exception};
1882use constant {FAIL => 'FAIL', NULL => 'NULL', USER => 'USER'};
1883
1884sub get_code {
1885    return $_[0]->{code};
1886}
1887
1888# ------------------------------------------------------------------------------
1889# Resource exception.
1890package FCM1::Cm::Exception;
1891our @ISA = qw{FCM1::Cm::Abort};
1892use constant {
1893    CHDIR             => 'CHDIR',
1894    DIFF_PROJECTS     => 'DIFF_PROJECTS',
1895    INVALID_BRANCH    => 'INVALID_BRANCH',
1896    INVALID_PROJECT   => 'INVALID_PROJECT',
1897    INVALID_TARGET    => 'INVALID_TARGET',
1898    INVALID_URL       => 'INVALID_URL',
1899    INVALID_WC        => 'INVALID_WC',
1900    MERGE_REV_INVALID => 'MERGE_REV_INVALID',
1901    MERGE_SELF        => 'MERGE_SELF',
1902    MERGE_UNRELATED   => 'MERGE_UNRELATED',
1903    MERGE_UNSAFE      => 'MERGE_UNSAFE',
1904    MKPATH            => 'MKPATH',
1905    NOT_EXIST         => 'NOT_EXIST',
1906    PARENT_NOT_EXIST  => 'PARENT_NOT_EXIST',
1907    RMTREE            => 'RMTREE',
1908    SWITCH_UNSAFE     => 'SWITCH_UNSAFE',
1909    WC_INVALID_BRANCH => 'WC_INVALID_BRANCH',
1910    WC_URL_NOT_EXIST  => 'WC_URL_NOT_EXIST',
1911};
1912
1913sub get_targets {
1914    return @{$_[0]->{targets}};
1915}
1916
19171;
1918__END__
1919
1920=pod
1921
1922=head1 NAME
1923
1924FCM1::Cm
1925
1926=head1 SYNOPSIS
1927
1928    use FCM1::Cm qw{cm_check_missing cm_check_unknown cm_switch cm_update};
1929
1930    # Checks status for "missing" items and "svn delete" them
1931    $missing_st_handler = sub {
1932        my ($name, $targets_ref, $status_list_ref) = @_;
1933        # ...
1934        return @paths_of_interest;
1935    };
1936    cm_check_missing({st_check_handler => $missing_st_handler}, @targets);
1937
1938    # Checks status for "unknown" items and "svn add" them
1939    $unknown_st_handler = sub {
1940        my ($name, $targets_ref, $status_list_ref) = @_;
1941        # ...
1942        return @paths_of_interest;
1943    };
1944    cm_check_unknown({st_check_handler => $unknown_st_handler}, @targets);
1945
1946    # Sets up a status checker
1947    $st_check_handler = sub {
1948        my ($name, $targets_ref, $status_list_ref) = @_;
1949        # ...
1950    };
1951    # Switches a "working copy" at the "root" level to a new URL target
1952    cm_switch(
1953        {
1954            'non-interactive'  => $non_interactive_flag,
1955            'quiet'            => $quiet_flag,
1956            'revision'         => $revision,
1957            'st_check_handler' => $st_check_handler,
1958        },
1959        $target, $path_of_wc,
1960    );
1961    # Runs "svn update" on each working copy from their "root" level
1962    cm_update(
1963        {
1964            'non-interactive'  => $non_interactive_flag,
1965            'quiet'            => $quiet_flag,
1966            'revision'         => $revision,
1967            'st_check_handler' => $st_check_handler,
1968        },
1969        @targets,
1970    );
1971
1972=head1 DESCRIPTION
1973
1974Wraps the Subversion client and implements other FCM code management
1975functionalities.
1976
1977=head1 FUNCTIONS
1978
1979=over 4
1980
1981=item cm_check_missing(\%option,@targets)
1982
1983Use "svn status" to check for missing items in @targets. If @targets is an empty
1984list, the function adds the current working directory to it. Expects
1985$option{st_check_handler} to be a CODE reference. Calls
1986$option{st_check_handler} with ($name, $targets_ref, $status_list_ref) where
1987$name is "delete", $targets_ref is \@targets, and $status_list_ref is an
1988ARRAY reference to a list of "svn status" output with the "missing" status.
1989$option{st_check_handler} should return a list of interesting paths, which will
1990be scheduled for removal using "svn delete".
1991
1992=item cm_check_unknown(\%option,@targets)
1993
1994Similar to cm_check_missing(\%option,@targets) but checks for "unknown" items,
1995which will be scheduled for addition using "svn add".
1996
1997=item cm_switch(\%option,$target,$path_of_wc)
1998
1999Invokes "svn switch" at the root of a working copy specified by $path_of_wc (or
2000the current working directory if $path_of_wc is not specified).
2001$option{'non-interactive'}, $option{quiet}, $option{revision} determines the
2002options (of the same name) that are passed to "svn switch". If
2003$option{st_check_handler} is set, it should be a CODE reference, and will be
2004called with ('switch', [$path_of_wc], $status_list_ref), where $status_list_ref
2005is an ARRAY reference to the output returned by "svn status" on $path_of_wc.
2006This can be used for the application to display the working copy status to the
2007user before prompting him/her to continue. The return value of
2008$option{st_check_handler} is ignored.
2009
2010=item cm_update(\%option,@targets)
2011
2012Invokes "svn update" at the root of each working copy specified by @targets. If
2013@targets is an empty list, the function adds the current working directory to
2014it. $option{'non-interactive'}, $option{quiet}, $option{revision} determines the
2015options (of the same name) that are passed to "svn update". If
2016$option{st_check_handler} is set, it should be a CODE reference, and will be
2017called with ($name, $targets_ref, $status_list_ref), where $name is
2018'update', $targets_ref is \@targets and $status_list_ref is an ARRAY
2019reference to the output returned by "svn status -u" on the @targets. This can be
2020used for the application to display the working copy update status to the user
2021before prompting him/her to continue. The return value of
2022$option{st_check_handler} is ignored.
2023
2024=back
2025
2026=head1 DIAGNOSTICS
2027
2028The following exceptions can be raised:
2029
2030=over 4
2031
2032=item FCM1::Cm::Abort
2033
2034This exception @ISA L<FCM1::Exception|FCM1::Exception>. It is raised if a command
2035is aborted for some reason. The $e->get_code() method can be used to retrieve an
2036error code, which can be one of the following:
2037
2038=over 4
2039
2040=item $e->FAIL
2041
2042The command aborts because of a failure.
2043
2044=item $e->NULL
2045
2046The command aborts because it will result in no change.
2047
2048=item $e->USER
2049
2050The command aborts because of an action by the user.
2051
2052=back
2053
2054=item FCM1::Cm::Exception
2055
2056This exception @ISA L<FCM1::Abort|FCM1::Abort>. It is raised if a command fails
2057with a known reason. The $e->get_targets() method can be used to retrieve a list
2058of targets/resources associated with this exception. The $e->get_code() method
2059can be used to retrieve an error code, which can be one of the following:
2060
2061=over 4
2062
2063=item $e->CHDIR
2064
2065Fails to change directory to a target.
2066
2067=item $e->INVALID_BRANCH
2068
2069A target is not a valid branch URL in the standard FCM project layout.
2070
2071=item $e->INVALID_PROJECT
2072
2073A target is not a valid project URL in the standard FCM project layout.
2074
2075=item $e->INVALID_TARGET
2076
2077A target is not a valid Subversion URL or working copy.
2078
2079=item $e->INVALID_URL
2080
2081A target is not a valid Subversion URL.
2082
2083=item $e->INVALID_WC
2084
2085A target is not a valid Subversion working copy.
2086
2087=item $e->MERGE_REV_INVALID
2088
2089An invalid revision (target element 0) is specified for a merge.
2090
2091=item $e->MERGE_SELF
2092
2093Attempt to merge a URL (target element 0) to its own working copy (target
2094element 1).
2095
2096=item $e->MERGE_UNRELATED
2097
2098The merge target (target element 0) is not directly related to the merge source
2099(target element 1).
2100
2101=item $e->MERGE_UNSAFE
2102
2103A merge source (target element 0) contains changes outside the target
2104sub-directory.
2105
2106=item $e->MKPATH
2107
2108Fail to create a directory (target element 0) recursively.
2109
2110=item $e->NOT_EXIST
2111
2112A target does not exist.
2113
2114=item $e->PARENT_NOT_EXIST
2115
2116The parent of the target no longer exists.
2117
2118=item $e->RMTREE
2119
2120Fail to remove a directory (target element 0) recursively.
2121
2122=item $e->SWITCH_UNSAFE
2123
2124A merge template exists in the commit message file (target element 0) in a
2125working copy target.
2126
2127=item $e->WC_INVALID_BRANCH
2128
2129The URL of the target working copy is not a valid branch URL in the standard FCM
2130project layout.
2131
2132=item $e->WC_URL_NOT_EXIST
2133
2134The URL of the target working copy no longer exists at the HEAD revision.
2135
2136=back
2137
2138=back
2139
2140=head1 TO DO
2141
2142Reintegrate with L<FCM1::CmUrl|FCM1::CmUrl> and L<FCM1::CmBranch|FCM1::CmBranch>,
2143but separate this module into the CLI part and the CM part. Expose the remaining
2144CM functions when this is done.
2145
2146Use L<SVN::Client|SVN::Client> to interface with Subversion.
2147
2148Move C<mkpatch> out of this module.
2149
2150=head1 COPYRIGHT
2151
2152E<169> Crown copyright Met Office. All rights reserved.
2153
2154=cut
2155opy already exists.
2156
2157=item $e->WC_INVALID_BRANCH
2158
2159The URL of the target working copy is not a valid branch URL in the standard FCM
2160project layout.
2161
2162=item $e->WC_URL_NOT_EXIST
2163
2164The URL of the target working copy no longer exists at the HEAD revision.
2165
2166=back
2167
2168=back
2169
2170=head1 TO DO
2171
2172Reintegrate with L<FCM1::CmUrl|FCM1::CmUrl> and L<FCM1::CmBranch|FCM1::CmBranch>,
2173but separate this module into the CLI part and the CM part. Expose the remaining
2174CM functions when this is done.
2175
2176Use L<SVN::Client|SVN::Client> to interface with Subversion.
2177
2178Move C<mkpatch> out of this module.
2179
2180=head1 COPYRIGHT
2181
2182E<169> Crown copyright Met Office. All rights reserved.
2183
2184=cut
2185$e->CHDIR
2186
2187Fails to change directory to a target.
2188
2189=item $e->INVALID_BRANCH
2190
2191A target is not a valid branch URL in the standard FCM project layout.
2192
2193=item $e->INVALID_PROJECT
2194
2195A target is not a valid project URL in the standard FCM project layout.
2196
2197=item $e->INVALID_TARGET
2198
2199A target is not a valid Subversion URL or working copy.
2200
2201=item $e->INVALID_URL
2202
2203A target is not a valid Subversion URL.
2204
2205=item $e->INVALID_WC
2206
2207A target is not a valid Subversion working copy.
2208
2209=item $e->MERGE_REV_INVALID
2210
2211An invalid revision (target element 0) is specified for a merge.
2212
2213=item $e->MERGE_SELF
2214
2215Attempt to merge a URL (target element 0) to its own working copy (target
2216element 1).
2217
2218=item $e->MERGE_UNRELATED
2219
2220The merge target (target element 0) is not directly related to the merge source
2221(target element 1).
2222
2223=item $e->MERGE_UNSAFE
2224
2225A merge source (target element 0) contains changes outside the target
2226sub-directory.
2227
2228=item $e->MKPATH
2229
2230Fail to create a directory (target element 0) recursively.
2231
2232=item $e->NOT_EXIST
2233
2234A target does not exist.
2235
2236=item $e->PARENT_NOT_EXIST
2237
2238The parent of the target no longer exists.
2239
2240=item $e->RMTREE
2241
2242Fail to remove a directory (target element 0) recursively.
2243
2244=item $e->SWITCH_UNSAFE
2245
2246A merge template exists in the commit message file (target element 0) in a
2247working copy target.
2248
2249=item $e->WC_INVALID_BRANCH
2250
2251The URL of the target working copy is not a valid branch URL in the standard FCM
2252project layout.
2253
2254=item $e->WC_URL_NOT_EXIST
2255
2256The URL of the target working copy no longer exists at the HEAD revision.
2257
2258=back
2259
2260=back
2261
2262=head1 TO DO
2263
2264Migrate to FCM::System hierarchy.
2265
2266Move C<mkpatch> out of this module.
2267
2268=head1 COPYRIGHT
2269
2270E<169> Crown copyright Met Office. All rights reserved.
2271
2272=cut
Note: See TracBrowser for help on using the repository browser.