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 branches/UKMO/dev_merge_2017_GC_couple_pkg/NEMOGCM/EXTERNAL/fcm/lib/Fcm – NEMO

source: branches/UKMO/dev_merge_2017_GC_couple_pkg/NEMOGCM/EXTERNAL/fcm/lib/Fcm/Cm.pm @ 9677

Last change on this file since 9677 was 9677, checked in by dancopsey, 6 years ago

Strip out SVN keywords.

File size: 84.8 KB
Line 
1# ------------------------------------------------------------------------------
2# NAME
3#   Fcm::Cm
4#
5# DESCRIPTION
6#   This module contains the FCM code management functionalities and wrappers
7#   to Subversion commands.
8#
9# COPYRIGHT
10#   (C) Crown copyright Met Office. All rights reserved.
11#   For further details please refer to the file COPYRIGHT.txt
12#   which you should have received as part of this distribution.
13# ------------------------------------------------------------------------------
14use strict;
15use warnings;
16
17package Fcm::Cm;
18use base qw{Exporter};
19
20our @EXPORT_OK = qw(cli cm_check_missing cm_check_unknown cm_switch cm_update);
21
22use Cwd            qw{cwd};
23use Getopt::Long   qw{GetOptions :config bundling};
24use Fcm::CLI::Exception;
25use Fcm::Config;
26use Fcm::CmBranch;
27use Fcm::CmUrl;
28use Fcm::Keyword;
29use Fcm::Util      qw{
30    get_url_of_wc
31    get_url_peg_of_wc
32    get_wct
33    is_url
34    is_wc
35    run_command
36    tidy_url
37};
38use File::Basename qw{basename dirname};
39use File::Path     qw{mkpath rmtree};
40use File::Spec;
41use File::Temp     qw{tempfile};
42use Pod::Usage     qw{pod2usage};
43
44# ------------------------------------------------------------------------------
45
46# CLI message handler
47our $CLI_MESSAGE = \&_cli_message;
48
49# List of CLI messages
50our %CLI_MESSAGE_FOR = (
51    q{}         => "%s",
52    BRANCH_LIST => "%s at %s: %d branch(es) found for %s.\n",
53    CHDIR_WCT   => "%s: working directory changed to top of working copy.\n",
54    CF          => "Conflicts in: %s\n",
55    MERGE       => "Performing merge ...\n",
56    MERGE_CF    => "About to merge in changes from %s compared with %s\n",
57    MERGE_CI    => "The following is added to the commit message file:\n%s",
58    MERGE_DRY   => "This merge will result in the following change:\n",
59    MERGE_REVS  => "Merge(s) available from %s: %s\n",
60    OUT_DIR     => "Output directory: %s\n",
61    PATCH_DONE  => "%s: patch generated.\n",
62    PATCH_REV   => "Patch created for changeset %s\n",
63    SEPARATOR   => q{-} x 80 . "\n",
64    STATUS      => "Status of the target working copy(ies):\n%s",
65);
66
67# CLI abort and error messages
68our %CLI_MESSAGE_FOR_ABORT = (
69    FAIL => "%s: command failed.\n",
70    NULL => "%s: command will result in no change.\n",
71    USER => "%s: abort by user.\n",
72);
73
74# CLI abort and error messages
75our %CLI_MESSAGE_FOR_ERROR = (
76    CHDIR               => "%s: cannot change to directory.\n",
77    CLI                 => "%s",
78    CLI_HELP            => "Type 'fcm help %s' for usage.\n",
79    CLI_MERGE_ARG1      => "Arg 1 must be the source in auto/custom mode.\n",
80    CLI_MERGE_ARG2      => "Arg 2 must be the source in custom mode"
81                           . " if --revision not set.\n",
82    CLI_OPT_ARG         => "--%s: invalid argument [%s].\n",
83    CLI_OPT_WITH_OPT    => "--%s: must be specified with --%s.\n",
84    CLI_USAGE           => "incorrect usage",
85    DIFF_PROJECTS       => "%s (target) and %s (source) are not related.\n",
86    INVALID_BRANCH      => "%s: not a valid URL of a standard FCM branch.\n",
87    INVALID_PROJECT     => "%s: not a valid URL of a standard FCM project.\n",
88    INVALID_TARGET      => "%s: not a valid working copy or URL.\n",
89    INVALID_URL         => "%s: not a valid URL.\n",
90    INVALID_WC          => "%s: not a valid working copy.\n",
91    MERGE_REV_INVALID   => "%s: not a revision in the available merge list.\n",
92    MERGE_SELF          => "%s: cannot be merged to its own working copy: %s.\n",
93    MERGE_UNRELATED     => "%s: target and %s: source not directly related.\n",
94    MERGE_UNSAFE        => "%s: source contains changes outside the target"
95                           . " sub-directory. Please merge with a full tree.\n",
96    MKPATH              => "%s: cannot create directory.\n",
97    NOT_EXIST           => "%s: does not exist.\n",
98    PARENT_NOT_EXIST    => "%s: parent %s no longer exists.\n",
99    RMTREE              => "%s: cannot remove.\n",
100    ST_CONFLICT         => "File(s) in conflicts:\n%s",
101    ST_MISSING          => "File(s) missing:\n%s",
102    ST_OUT_OF_DATE      => "File(s) out of date:\n%s",
103    SWITCH_UNSAFE       => "%s: merge template exists."
104                           . " Please remove before retrying.\n",
105    WC_EXIST            => "%s: working copy already exists.\n",
106    WC_INVALID_BRANCH   => "%s: not a working copy of a standard FCM branch.\n",
107    WC_URL_NOT_EXIST    => "%s: working copy URL does not exists at HEAD.\n",
108);
109
110# List of CLI prompt messages
111our %CLI_MESSAGE_FOR_PROMPT = (
112    CF_OVERWRITE      => qq{%s: existing changes will be overwritten.\n}
113                         . qq{ Do you wish to continue?},
114    CI                => qq{Would you like to commit this change?},
115    CI_BRANCH_SHARED  => qq{\n}
116                         . qq{*** WARNING: YOU ARE COMMITTING TO A %s BRANCH.\n}
117                         . qq{*** Please ensure that you have the}
118                         . qq{ owner's permission.\n\n}
119                         . qq{Would you like to commit this change?},
120    CI_BRANCH_USER    => qq{\n}
121                         . qq{*** WARNING: YOU ARE COMMITTING TO A BRANCH}
122                         . qq{ NOT OWNED BY YOU.\n}
123                         . qq{*** Please ensure that you have the}
124                         . qq{ owner's permission.\n\n}
125                         . qq{Would you like to commit this change?},
126    CI_TRUNK          => qq{\n}
127                         . qq{*** WARNING: YOU ARE COMMITTING TO THE TRUNK.\n}
128                         . qq{*** Please ensure that your change conforms to}
129                         . qq{ your project's working practices.\n\n}
130                         . qq{Would you like to commit this change?},
131    CONTINUE          => qq{Are you sure you want to continue?},
132    MERGE             => qq{Would you like to go ahead with the merge?},
133    MERGE_REV         => qq{Please enter the revision you wish to merge from},
134    MKPATCH_OVERWRITE => qq{%s: output location exists. OK to overwrite?},
135    RUN_SVN_COMMAND   => qq{Would you like to run "svn %s"?},
136);
137
138# List of CLI warning messages
139our %CLI_MESSAGE_FOR_WARNING = (
140    BRANCH_SUBDIR   => "%s: is a sub-directory of a branch in a FCM project.\n",
141    CF_BINARY       => "%s: ignoring binary file, please resolve manually.\n",
142    INVALID_BRANCH  => $CLI_MESSAGE_FOR_ERROR{INVALID_BRANCH},
143    ST_IN_TRAC_DIFF => "%s: local changes cannot be displayed in Trac.\n"
144);
145
146# CLI prompt handler and title prefix
147our $CLI_PROMPT = \&_cli_prompt;
148our $CLI_PROMPT_PREFIX = q{fcm };
149
150# List of exception handlers [$class, CODE->($function, $e)]
151our @CLI_EXCEPTION_HANDLERS = (
152    ['Fcm::CLI::Exception', \&_cli_e_handler_of_cli_exception],
153    ['Fcm::Cm::Exception' , \&_cli_e_handler_of_cm_exception],
154    ['Fcm::Cm::Abort'     , \&_cli_e_handler_of_cm_abort],
155);
156
157# Event handlers
158our %CLI_HANDLER_OF = (
159    'WC_STATUS'      => \&_cli_handler_of_wc_status,
160    'WC_STATUS_PATH' => \&_cli_handler_of_wc_status_path,
161);
162
163# Handlers of sub-commands
164our %CLI_IMPL_OF = (
165    'add'       => \&_cli_command_add,
166    'branch'    => \&cm_branch,
167    'commit'    => \&cm_commit,
168    'conflicts' => \&cm_conflicts,
169    'checkout'  => \&_cli_command_checkout,
170    'delete'    => \&_cli_command_delete,
171    'diff'      => \&cm_diff,
172    'merge'     => \&cm_merge,
173    'mkpatch'   => \&cm_mkpatch,
174    'switch'    => \&_cli_command_switch,
175    'update'    => \&_cli_command_update,
176);
177
178# List of overridden subcommands that need to display "svn help"
179our %CLI_MORE_HELP_FOR = map {($_, 1)} qw{add diff delete switch update};
180
181# The preferred name of subcommand aliases
182our %CLI_PREFERRED_NAME_OF = (
183    'ann'      => 'blame',
184    'annotate' => 'blame',
185    'br'       => 'branch',
186    'ci'       => 'commit',
187    'cf'       => 'conflicts',
188    'co'       => 'checkout',
189    'cp'       => 'copy',
190    'del'      => 'delete',
191    'di'       => 'diff',
192    'ls'       => 'list',
193    'mv'       => 'move',
194    'pd'       => 'propdel',
195    'pdel'     => 'propdel',
196    'pe'       => 'propedit',
197    'pedit'    => 'propedit',
198    'pg'       => 'propget',
199    'pget'     => 'propget',
200    'pl'       => 'proplist',
201    'plist'    => 'proplist',
202    'praise'   => 'blame',
203    'ps'       => 'propset',
204    'pset'     => 'propset',
205    'remove'   => 'delete',
206    'ren'      => 'move',
207    'rename'   => 'move',
208    'rm'       => 'delete',
209    'sw'       => 'switch',
210    'up'       => 'update',
211);
212
213# List of subcommands that accept URL inputs
214our %CLI_SUBCOMMAND_URL = map {($_, 1)} qw{
215    blame
216    branch
217    cat
218    checkout
219    copy
220    delete
221    diff
222    export
223    import
224    info
225    list
226    lock
227    log
228    merge
229    mkdir
230    mkpatch
231    move
232    propdel
233    propedit
234    propget
235    proplist
236    propset
237    switch
238    unlock
239};
240
241# List of subcommands that accept revision inputs
242our %CLI_SUBCOMMAND_REV = map {($_, 1)} qw{
243    blame
244    branch
245    cat
246    checkout
247    copy
248    diff
249    export
250    info
251    list
252    log
253    merge
254    mkpatch
255    move
256    propdel
257    propedit
258    propget
259    proplist
260    propset
261    switch
262};
263
264# Common patterns
265our %PATTERN_OF = (
266    # A CLI option
267    CLI_OPT => qr{
268        \A            (?# beginning)
269        (--\w[\w-]*=) (?# capture 1, a long option label)
270        (.*)          (?# capture 2, the value of the option)
271        \z            (?# end)
272    }xms,
273    # A CLI revision option
274    CLI_OPT_REV => qr{
275        \A                      (?# beginning)
276        (--revision(?:=|\z)|-r) (?# capture 1, --revision, --revision= or -r)
277        (.*)                    (?# capture 2, trailing value)
278        \z                      (?# end)
279    }xms,
280    # A CLI revision option range
281    CLI_OPT_REV_RANGE => qr{
282        \A                  (?# beginning)
283        (                   (?# capture 1, begin)
284            (?:\{[^\}]+\}+) (?# a date in curly braces)
285            |               (?# or)
286            [^:]+           (?# anything but a colon)
287        )                   (?# capture 1, end)
288        (?::(.*))?          (?# colon, and capture 2 til the end)
289        \z                  (?# end)
290    }xms,
291    # A FCM branch path look-alike, should be configurable in the future
292    FCM_BRANCH_PATH => qr{
293        \A                            (?# beginning)
294        /*                            (?# some slashes)
295        (?:                           (?# group 1, begin)
296            (?:trunk/*(?:@\d+)?\z)    (?# trunk at a revision)
297            |                         (?# or)
298            (?:trunk|branches|tags)/+ (?# trunk, branch or tags)
299        )                             (?# group 1, end)
300    }xms,
301    # Last line of output from "svn status -u"
302    ST_AGAINST_REV => qr{
303        \A                           (?# beginning)
304        Status\sagainst\srevision:.* (?# output of svn status -u)
305        \z                           (?# end)
306    }xms,
307    # Extract path from "svn status"
308    ST_PATH => qr{
309        \A   (?# beginning)
310        .{6} (?# 6 columns)
311        \s+  (?# spaces)
312        (.+) (?# capture 1, target path)
313        \z   (?# end)
314    }xms,
315    # A legitimate "svn" revision
316    SVN_REV => qr{
317        \A                                      (?# beginning)
318        (?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}) (?# digit, reserved words, date)
319        \z                                      (?# end)
320    }ixms,
321);
322
323# Status matchers
324our %ST_MATCHER_FOR = (
325    MISSING     => sub {substr($_[0], 0, 1) eq '!'},
326    MODIFIED    => sub {substr($_[0], 0, 6) =~ qr{\S}xms},
327    OUT_OF_DATE => sub {substr($_[0], 7, 1) eq '*'},
328    UNKNOWN     => sub {substr($_[0], 0, 1) eq '?'},
329);
330
331# ------------------------------------------------------------------------------
332# Entry function for the FCM code management CLI. Calls the relevant FCM code
333# management function or SVN command based on $function.
334sub cli {
335    my ($function, @args) = @_;
336    if (exists($CLI_PREFERRED_NAME_OF{$function})) {
337        $function = $CLI_PREFERRED_NAME_OF{$function};
338    }
339    if (grep {$_ eq '-h' || $_ eq '--help'} @args) {
340        return _cli_help($function, 'NOEXIT');
341    }
342    if (exists($CLI_SUBCOMMAND_URL{$function})) {
343        _cli_keyword_expand_url(\@args);
344    }
345    if (exists($CLI_SUBCOMMAND_REV{$function})) {
346        _cli_keyword_expand_rev(\@args);
347    }
348    if (exists($CLI_IMPL_OF{$function})) {
349        eval {
350            local(@ARGV) = @args;
351            return $CLI_IMPL_OF{$function}->(@args);
352        };
353        if ($@) {
354            my $e = $@;
355            for (@CLI_EXCEPTION_HANDLERS) {
356                my ($class, $handler) = @{$_};
357                if ($class->caught($e)) {
358                    return $handler->($function, $e);
359                }
360            }
361            die($e);
362        }
363    }
364    else {
365        return _svn($function, @args);
366    }
367}
368
369# ------------------------------------------------------------------------------
370# SYNOPSIS
371#   &Fcm::Cm::cm_branch ();
372#
373# DESCRIPTION
374#   This is a FCM command to check information, create or delete a branch in
375#   a Subversion repository.
376# ------------------------------------------------------------------------------
377
378sub cm_branch {
379  # Process command line options
380  # ----------------------------------------------------------------------------
381  my (
382    $info,
383    $delete,
384    $create,
385    $list,
386    $branch_of_branch,
387    $name,
388    $non_interactive,
389    $password,
390    $rev,
391    $rev_flag,
392    $show_all,
393    $show_children,
394    $show_other,
395    $show_siblings,
396    $svn_non_interactive,
397    @tickets,
398    $type,
399    @userlist,
400    $verbose,
401  );
402  my $rc = GetOptions(
403    'info|i'              => \$info,
404    'delete|d'            => \$delete,
405    'create|c'            => \$create,
406    'list|l'              => \$list,
407    'branch-of-branch'    => \$branch_of_branch,
408    'name|n=s'            => \$name,
409    'non-interactive'     => \$non_interactive,
410    'password=s'          => \$password,
411    'revision|r=s'        => \$rev,
412    'rev-flag=s'          => \$rev_flag,
413    'show-all|a'          => \$show_all,
414    'show-children'       => \$show_children,
415    'show-other'          => \$show_other,
416    'show-siblings'       => \$show_siblings,
417    'svn-non-interactive' => \$svn_non_interactive,
418    'ticket|k=s'          => \@tickets,
419    'type|t=s'            => \$type,
420    'user|u=s'            => \@userlist,
421    'verbose|v'           => \$verbose,
422  );
423  if (!$rc) {
424    _cli_err();
425  }
426
427  my $num_options = 0;
428  $num_options++ if defined $info;
429  $num_options++ if defined $delete;
430  $num_options++ if defined $create;
431  $num_options++ if defined $list;
432  if ($num_options > 1) {
433    _cli_err();
434  }
435
436  # Get URL of repository or branch
437  # ----------------------------------------------------------------------------
438  my $url;
439  if ($ARGV[0]) {
440    $url = Fcm::CmUrl->new (URL => $ARGV[0]);
441
442    if (not $url->is_url) {
443      # An argument is specified and is not a URL
444      # Assume that it is a path with a working copy
445      if (&is_wc ($ARGV[0])) {
446        $url = Fcm::CmUrl->new (URL => &get_url_of_wc ($ARGV[0]));
447
448      } else {
449        return _cm_err(Fcm::Cm::Exception->INVALID_WC, $ARGV[0]);
450      }
451    }
452
453  } else {
454    # An argument is not specified
455    # Assume that the current directory is a working copy
456    if (&is_wc ()) {
457      $url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
458
459    } else {
460      return _cm_err(Fcm::Cm::Exception->INVALID_TARGET, '.');
461    }
462  }
463
464  # Ensure $url->url_peg is a URL of a standard FCM project
465  if (!$url->project_url()) {
466    return _cm_err(Fcm::Cm::Exception->INVALID_PROJECT, $url->url_peg());
467  }
468
469  if ($create) {
470    # The --create option is specified, create a branch
471    # --------------------------------------------------------------------------
472
473    # Check branch type flags
474    if ($type) {
475      $type = uc ($type);
476
477      if ($type =~ /^(USER|SHARE)$/) {
478        $type = 'DEV' . $Fcm::Config::DELIMITER . $1;
479
480      } elsif ($type =~ /^(CONFIG|REL)$/) {
481        $type = 'PKG' . $Fcm::Config::DELIMITER . $1;
482
483      } elsif ($type =~ /^(DEV|TEST|PKG)$/) {
484        $type = $1 . $Fcm::Config::DELIMITER . 'USER';
485
486      } elsif ($type !~ /^(?:DEV|TEST|PKG)$Fcm::Config::DELIMITER(?:USER|SHARE)$/
487               and $type !~ /^PKG$Fcm::Config::DELIMITER(?:CONFIG|REL)/) {
488        _cli_err('CLI_OPT_ARG', 'type', $type);
489      }
490
491    } else {
492      $type = 'DEV' . $Fcm::Config::DELIMITER . 'USER';
493    }
494
495    # Check branch name
496    if (!$name) {
497      _cli_err('CLI_OPT_WITH_OPT', 'name', 'create');
498    }
499
500    if ($name !~ qr{\A[\w.-]+\z}xms) {
501      _cli_err('CLI_OPT_ARG', 'name', $name);
502    }
503
504    # Check revision flag is valid
505    if ($rev_flag) {
506      $rev_flag = uc ($rev_flag);
507      if ($rev_flag !~ qr{\A (?:NORMAL|NUMBER|NONE) \z}xms) {
508        _cli_err('CLI_OPT_ARG', 'rev-flag', $rev_flag);
509      }
510
511    } else {
512      $rev_flag = 'NORMAL';
513    }
514
515    # Handle multiple tickets
516    @tickets = split (
517      /$Fcm::Config::DELIMITER_LIST/,
518      join ($Fcm::Config::DELIMITER_LIST, @tickets)
519    );
520    s/^#// for (@tickets);
521    @tickets = sort {$a <=> $b} @tickets;
522
523    # Determine whether to create a branch of a branch
524    $url->branch ('trunk') unless $branch_of_branch;
525
526    # Create the branch
527    my $branch = Fcm::CmBranch->new;
528    $branch->create (
529      SRC                 => $url,
530      TYPE                => $type,
531      NAME                => $name,
532      PASSWORD            => $password,
533      REV_FLAG            => $rev_flag,
534      TICKET              => \@tickets,
535      REV                 => $rev,
536      NON_INTERACTIVE     => $non_interactive,
537      SVN_NON_INTERACTIVE => $svn_non_interactive,
538    );
539
540  } elsif ($list) {
541    # The option --list is specified
542    # List branches owned by current or specified users
543    # --------------------------------------------------------------------------
544    # Get URL of the project "branches/" sub-directory
545    $url->subdir ('');
546    $url->branch ('');
547
548    my @branches = $url->branch_list($rev);
549    if (!$show_all) {
550      @userlist = split(qr{:}xms, join(q{:}, @userlist));
551      if (!@userlist) {
552        @userlist = (Fcm::Config->instance()->user_id());
553      }
554      my %filter = map {($_, 1)} @userlist;
555      @branches = grep {
556        $filter{Fcm::CmBranch->new(URL => $_)->branch_owner()}
557      } @branches
558    }
559
560    # Output, number of branches found
561    $CLI_MESSAGE->(
562      'BRANCH_LIST',
563      $url->project_url_peg(),
564      $rev ? "r$rev" : 'HEAD',
565      scalar(@branches),
566      ($show_all ? '[--show-all]' : join(q{, }, sort(@userlist))),
567    );
568
569    if (@branches) {
570      # Output the URL of each branch
571      if (not $verbose) {
572        my $project = $url->project_url;
573        @branches = map {Fcm::Keyword::unexpand($_)} @branches;
574      }
575      @branches = map {$_ . "\n"} sort @branches;
576      $CLI_MESSAGE->(q{}, join(q{}, @branches));
577
578    } else {
579      # No branch found, exit with an error code
580      return;
581    }
582
583  } else {
584    # The option --info or --delete is specified
585    # Report branch information (and/or delete a branch)
586    # --------------------------------------------------------------------------
587    # Set verbose level
588    Fcm::Config->instance()->verbose ($verbose ? 1 : 0);
589
590    # Set up the branch, report any error
591    my $branch = Fcm::CmBranch->new (URL => $url->url_peg);
592    if (!$branch->branch()) {
593      return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $branch->url_peg());
594    }
595    if (!$branch->url_exists()) {
596      return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $branch->url_peg());
597    }
598
599    # Remove the sub-directory part of the URL
600    $branch->subdir ('');
601
602    # Report branch info
603    $branch->display_info (
604      SHOW_CHILDREN => ($show_all || $show_children),
605      SHOW_OTHER    => ($show_all || $show_other   ),
606      SHOW_SIBLINGS => ($show_all || $show_siblings),
607    );
608
609    # Delete branch if --delete is specified
610    $branch->del (
611      PASSWORD            => $password,
612      NON_INTERACTIVE     => $non_interactive,
613      SVN_NON_INTERACTIVE => $svn_non_interactive,
614    ) if $delete;
615  }
616
617}
618
619# ------------------------------------------------------------------------------
620# SYNOPSIS
621#   &Fcm::Cm::cm_commit ();
622#
623# DESCRIPTION
624#   This is a FCM wrapper to the "svn commit" command.
625# ------------------------------------------------------------------------------
626
627sub cm_commit {
628  my ($dry_run, $svn_non_interactive, $password);
629  my $rc = GetOptions(
630    'dry-run'             => \$dry_run,
631    'svn-non-interactive' => \$svn_non_interactive,
632    'password=s'          => \$password,
633  );
634  if (!$rc) {
635    _cli_err();
636  }
637
638  # The remaining argument is the path to a working copy
639  my ($path) = @ARGV;
640
641  if ($path) {
642    if (!-e $path) {
643      return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path);
644    }
645
646  } else {
647    # No argument specified, use current working directory
648    $path = cwd ();
649  }
650
651  # Make sure we are in a working copy
652  if (!is_wc($path)) {
653    return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path);
654  }
655
656  # Make sure we are at the top level of the working copy
657  # (otherwise we might miss any template commit message)
658  my $dir = &get_wct ($path);
659
660  if ($dir ne cwd ()) {
661    chdir($dir) || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir);
662    $CLI_MESSAGE->('CHDIR_WCT', $dir);
663  }
664
665  # Get update status of working copy
666  # Check working copy files are not in conflict, missing, or out of date
667  my @status = _svn_status_get([], 1);
668  unless (defined $dry_run) {
669    my (@conflict, @missing, @outdate);
670
671    for (@status) {
672      if (/^C/) {
673        push @conflict, $_;
674        next;
675      }
676
677      if (/^!/) {
678        push @missing, $_;
679        next;
680      }
681
682      if (/^.{7}\*/) {
683        push @outdate, $_;
684        next;
685      }
686
687      # Check that all files which have been added have the svn:executable
688      # property set correctly (in case the developer adds a script before they
689      # remember to set the execute bit)
690      next unless /^A.{7} *\d+ +(.*)/;
691      my $file = $1;
692
693      next unless -f $file;
694      my ($command, @arguments)
695        = (-x $file && !-l $file) ? ('propset', '*') : ('propdel');
696      run_command(['svn', $command, qw{-q svn:executable}, @arguments, $file]);
697    }
698
699    # Abort commit if files are in conflict, missing, or out of date
700    if (@conflict or @missing or @outdate) {
701      for (
702        ['ST_CONFLICT'   , \@conflict],
703        ['ST_MISSING'    , \@missing ],
704        ['ST_OUT_OF_DATE', \@outdate ],
705      ) {
706        my ($key, $array_ref) = @{$_};
707        if (@{$array_ref}) {
708          $CLI_MESSAGE->($key, join(q{}, @{$array_ref}));
709        }
710      }
711      return _cm_abort(Fcm::Cm::Abort->FAIL);
712    }
713  }
714
715  # Read in any existing message
716  my $ci_mesg = Fcm::CmCommitMessage->new;
717  $ci_mesg->read_file;
718
719  # Execute "svn status" for a list of changed items
720  @status = grep !/^\?/, _svn_status_get();
721
722  # Abort if there is no change in the working copy
723  if (!@status) {
724    return _cm_abort(Fcm::Cm::Abort->NULL);
725  }
726
727  # Get associated URL of current working copy
728  my $url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
729
730  # Include URL, or project, branch and sub-directory info in @status
731  unshift @status, "\n";
732
733  if ($url->project and $url->branch) {
734    unshift @status, (
735      '[Project: ' . $url->project                           . ']' . "\n",
736      '[Branch : ' . $url->branch                            . ']' . "\n",
737      '[Sub-dir: ' . ($url->subdir ? $url->subdir : '<top>') . ']' . "\n",
738    );
739
740  } else {
741    unshift @status, '[URL: ' . $url->url . ']' . "\n";
742  }
743
744  # Use a temporary file to store the final commit log message
745  $ci_mesg->ignore_mesg (\@status);
746  my $logfile = $ci_mesg->edit_file (TEMP => 1);
747
748  # Check with the user to see if he/she wants to go ahead
749  my $reply = 'n';
750  if (!defined($dry_run)) {
751    # Add extra warning for trunk commit
752    my @prompt_args;
753    my $user = Fcm::Config->instance()->user_id();
754
755    if ($url->is_trunk()) {
756      @prompt_args = ('CI_TRUNK');
757    }
758    elsif ($user && $url->is_branch() && $url->branch_owner() ne $user) {
759      if (exists $Fcm::CmUrl::owner_keywords{$url->branch_owner}) {
760        @prompt_args = (
761          'CI_BRANCH_SHARED',
762          uc($Fcm::CmUrl::owner_keywords{$url->branch_owner()}),
763        );
764      }
765      else {
766        @prompt_args = ('CI_BRANCH_USER');
767      }
768    }
769    else {
770      @prompt_args = ('CI');
771    }
772    $reply = $CLI_PROMPT->('commit', @prompt_args);
773  }
774
775  if ($reply eq 'y') {
776    # Commit the change if user replies "y" for "yes"
777    my @command = (
778      qw/svn commit -F/, $logfile,
779      ($svn_non_interactive  ? '--non-interactive'       : ()),
780      (defined $password     ? ('--password', $password) : ()),
781    );
782    my $rc;
783    &run_command (\@command, RC => \$rc, ERROR => 'warn');
784
785    if ($rc) {
786      # Commit failed
787      # Write temporary commit log content to commit log message file
788      $ci_mesg->write_file;
789
790      # Fail the command
791      return _cm_abort(Fcm::Cm::Abort->FAIL);
792    }
793
794    # Remove commit message file
795    unlink $ci_mesg->file;
796
797    # Update the working copy
798    $CLI_MESSAGE->(q{}, join(q{}, _svn_update()));
799
800  } else {
801    $ci_mesg->write_file;
802    if (!$dry_run) {
803      return _cm_abort();
804    }
805  }
806
807  return;
808}
809
810# ------------------------------------------------------------------------------
811# SYNOPSIS
812#   &Fcm::Cm::cm_conflicts ();
813#
814# DESCRIPTION
815#   This is a FCM command for resolving conflicts within working copy using a
816#   graphical merge tool.
817# ------------------------------------------------------------------------------
818
819sub cm_conflicts {
820  # Path to the working copy
821  my $path = $ARGV[0];
822  $path    = cwd () if not $path;
823
824  # Check for any files with conflicts
825  my @status = grep /^C.{4} *(.*)/, &run_command (
826    [qw/svn st/, ($path eq cwd () ? () : $path)], METHOD => 'qx',
827  );
828  my @files  = map {m/^C.{4} *(.*)/; $1} @status;
829
830  # Save current working directory
831  my $topdir = cwd ();
832
833  # Set up environment for graphical merge
834  # Use environment variable if set, otherwise use default setting
835  local(%ENV) = %ENV;
836  $ENV{FCM_GRAPHIC_MERGE}
837    ||= Fcm::Config->instance()->setting (qw/TOOL GRAPHIC_MERGE/);
838
839  FILE:
840  for my $file (@files) {
841    # Print name of file in conflicts
842    $CLI_MESSAGE->('CF', $file);
843
844    # Determine directory and base name of file in conflicts
845    my $base = basename $file;
846    my $dir  = dirname $file;
847
848    # Change to container directory of file in conflicts
849    chdir(File::Spec->catfile($topdir, $dir))
850      || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir);
851
852    # Use "svn info" to determine conflict marker files
853    my @info = &run_command ([qw/svn info/, $base], METHOD => 'qx');
854
855    # Ignore if $base is a binary file
856    if (-B $base) {
857      $CLI_MESSAGE->('CF_BINARY', $base);
858      next FILE;
859    }
860
861    # Get conflicts markers files
862    my ($older, $mine, $yours);
863
864    for (@info) {
865      $older = $1 if (/^Conflict Previous Base File: (.*)/);
866      $mine  = $1 if (/^Conflict Previous Working File: (.*)/);
867      $yours = $1 if (/^Conflict Current Base File: (.*)/);
868    }
869
870    if (-f $base and (stat $base)[9] > (stat $mine)[9] + 1) {
871      # If $base is newer (by more than a second), it may contain saved changes
872      if ($CLI_PROMPT->('conflicts', 'CF_OVERWRITE', $base) ne 'y') {
873        next FILE;
874      }
875    }
876
877    # Launch graphic merge tool
878    my $rc;
879    my $command = [qw/fcm_graphic_merge/, $base, $mine, $older, $yours];
880    # $rc == 0: all conflicts resovled
881    # $rc == 1: some conflicts not resolved
882    # $rc == 2: trouble
883    eval {
884      run_command($command, RC => \$rc);
885    };
886    if ($@) {
887      if (!defined($rc) || $rc > 1) {
888        die($@);
889      }
890    }
891    next FILE if $rc;
892
893    # Prompt user to run "svn resolved" on the file
894    if ($CLI_PROMPT->('conflicts', 'RUN_SVN_COMMAND', 'resolved') eq 'y') {
895      run_command([qw{svn resolved}, $base]);
896    }
897  }
898}
899
900# ------------------------------------------------------------------------------
901# SYNOPSIS
902#   &Fcm::Cm::cm_diff ();
903#
904# DESCRIPTION
905#   This is a wrapper to "svn diff". It adds two extra functionalities. The
906#   first one allows the command to show differences relative to the base of
907#   the branch. The second one allows differences to be displayed via a
908#   graphical tool.
909# ------------------------------------------------------------------------------
910
911sub cm_diff {
912  # Set up environment for graphical diff
913  # Use environment variable if set, otherwise use default setting
914  local(%ENV) = %ENV;
915  $ENV{FCM_GRAPHIC_DIFF}
916    ||= Fcm::Config->instance()->setting(qw/TOOL GRAPHIC_DIFF/);
917
918  # Check for the --branch options
919  # ----------------------------------------------------------------------------
920  my $branch = grep {$_ eq '-b' or $_ eq '--branch'} @ARGV;
921
922  if (not $branch) {
923    # The --branch option not specified, just call "svn diff"
924    # Convert the --graphical to qw/--diff-cmd fcm_graphical_diff/
925    # Convert the --summarise to --summarize
926    @ARGV = map {
927      my @return;
928      if ($_ eq '-g' or $_ eq '--graphical') {
929        @return = (qw/--diff-cmd fcm_graphic_diff/)
930
931      } elsif ($_ eq '--summarise') {
932        @return = ('--summarize');
933
934      } else {
935        @return = ($_);
936      }
937      @return;
938    } @ARGV;
939
940    # Execute the command
941    return _svn('diff', @ARGV);
942  }
943
944  # The --branch option is specified
945  # ----------------------------------------------------------------------------
946
947  # Determine whether the --graphical option is specified,
948  # if so set the appropriate command
949  # ----------------------------------------------------------------------------
950  my ($diff_cmd, $extensions, $graphical, $summarise, $trac, $wiki);
951  my $rc = GetOptions (
952    'b|branch'            => \$branch,
953    'diff-cmd=s'          => \$diff_cmd,
954    'x|extensions=s'      => \$extensions,
955    'g|graphical'         => \$graphical,
956    'summarise|summarize' => \$summarise,
957    't|trac'              => \$trac,
958    'wiki'                => \$wiki,
959  );
960  if (!$rc) {
961    _cli_err();
962  }
963
964  my @diff_cmd = ();
965
966  if ($graphical) {
967    @diff_cmd = (qw/--diff-cmd fcm_graphic_diff/);
968
969  } elsif ($diff_cmd) {
970    @diff_cmd = ('--diff-cmd', $diff_cmd);
971
972    push @diff_cmd, '--extensions', split (/\s+/, $extensions) if $extensions;
973  }
974
975  # The remaining argument should either be a URL or a PATH
976  my ($url_arg, $path_arg);
977
978  if (@ARGV) {
979    my $arg = Fcm::CmUrl->new (URL => $ARGV[0]);
980
981    if ($arg->is_url) {
982      $url_arg = $ARGV[0];
983
984    } else {
985      $path_arg = $ARGV[0];
986    }
987  }
988
989  # Get repository and branch information
990  # ----------------------------------------------------------------------------
991  my ($url, $path);
992  if (defined $url_arg) {
993    # If a URL is specified, get repository and branch information from it
994    $url = Fcm::CmBranch->new (URL => $url_arg);
995
996  } else {
997    # Get repository and branch information from the specified path or the
998    # current directory if it is a working copy
999    $path = $path_arg ? $path_arg : cwd ();
1000    if (!is_wc($path)) {
1001      return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path);
1002    }
1003
1004    $url  = Fcm::CmBranch->new (URL => &get_url_peg_of_wc ($path));
1005  }
1006
1007  # Check that URL is a standard FCM branch
1008  if (!$url->is_branch()) {
1009    return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $url->url_peg());
1010  }
1011
1012  # Save and remove sub-directory part of the URL
1013  my $subdir = $url->subdir ();
1014  $url->subdir ('');
1015
1016  # Check that $url exists
1017  if (!$url->url_exists()) {
1018    return _cm_err(Fcm::Cm::Exception->INVALID_URL, $url->url_peg());
1019  }
1020
1021  # Compare current branch with its parent
1022  # ----------------------------------------------------------------------------
1023  my $parent = Fcm::CmBranch->new (URL => $url->parent->url);
1024  $parent->pegrev ($url->pegrev) if $url->pegrev;
1025
1026  if (!$parent->url_exists()) {
1027    return _cm_err(
1028      Fcm::Cm::Exception->PARENT_NOT_EXIST, $url->url_peg(), $parent->url(),
1029    );
1030  }
1031
1032  my $base = $parent->base_of_merge_from ($url);
1033
1034  # Ensure the correct diff (syntax) is displayed
1035  # ----------------------------------------------------------------------------
1036  # Reinstate the sub-tree part into the URL
1037  $url->subdir ($subdir);
1038  $base->subdir ($subdir);
1039
1040  # Ensure the branch URL has a peg revision
1041  $url->pegrev ($url->svninfo (FLAG => 'Last Changed Rev')) if not $url->pegrev;
1042
1043  if ($trac or $wiki) {
1044    # Trac/wiki
1045    # --------------------------------------------------------------------------
1046    if (!$url_arg && _svn_status_get([$path_arg ? $path_arg : q{.}])) {
1047      $CLI_MESSAGE->('ST_IN_TRAC_DIFF', ($path_arg ? $path_arg : q{.}));
1048    }
1049
1050    # Trac wiki syntax
1051    my $wiki_syntax = 'diff:' . $base->path_peg . '//' . $url->path_peg;
1052
1053    if ($wiki) {
1054      # Print Trac wiki syntax only
1055      $CLI_MESSAGE->(q{}, "$wiki_syntax\n");
1056
1057    } else { # if $trac
1058      # Use Trac to view "diff"
1059      my $browser = Fcm::Config->instance()->setting(qw/WEB_BROWSER/);
1060      $browser ||= 'firefox';
1061
1062      my $trac_url = Fcm::Keyword::get_browser_url($url->project_url());
1063      $trac_url =~ s{/intertrac/.*$}{/intertrac/$wiki_syntax}xms;
1064
1065      &run_command ([$browser, $trac_url], METHOD => 'exec', PRINT => 1);
1066    }
1067
1068  } else {
1069    # Execute the "diff" command
1070    # --------------------------------------------------------------------------
1071    my @command = (
1072      qw/svn diff/, @diff_cmd,
1073      ($summarise ? ('--summarize') : ()),
1074      '--old', $base->url_peg,
1075      '--new', ($url_arg ? $url->url_peg : ($path_arg ? $path_arg : '.')),
1076    );
1077    &run_command (\@command, PRINT => 1);
1078  }
1079}
1080
1081# ------------------------------------------------------------------------------
1082# SYNOPSIS
1083#   &Fcm::Cm::cm_merge ();
1084#
1085# DESCRIPTION
1086#   This is a wrapper to "svn merge".
1087# ------------------------------------------------------------------------------
1088
1089sub cm_merge {
1090  # Options
1091  # ----------------------------------------------------------------------------
1092  my ($custom, $dry_run, $non_interactive, $reverse, $rev, $verbose);
1093  my $rc = GetOptions(
1094    'custom'          => \$custom,
1095    'dry-run'         => \$dry_run,
1096    'non-interactive' => \$non_interactive,
1097    'reverse'         => \$reverse,
1098    'revision|r=s'    => \$rev,
1099    'verbose|v'       => \$verbose,
1100  );
1101  if (!$rc) {
1102    _cli_err();
1103  }
1104
1105  # Find out the URL of the working copy
1106  # ----------------------------------------------------------------------------
1107  my ($target, $wct);
1108  if (&is_wc ()) {
1109    $wct = &get_wct ();
1110
1111    if ($wct ne cwd ()) {
1112      chdir($wct) || return _cm_err(Fcm::Cm::Exception->CHDIR, $wct);
1113      $CLI_MESSAGE->('CHDIR_WCT', $wct);
1114    }
1115
1116    $target = Fcm::CmBranch->new (URL => &get_url_of_wc ($wct));
1117
1118  } else {
1119    return _cm_err(Fcm::Cm::Exception->INVALID_WC, '.');
1120  }
1121
1122  if (!$target->url_exists()) {
1123    return _cm_err(Fcm::Cm::Exception->WC_URL_NOT_EXIST, '.');
1124  }
1125
1126  # The target must be at the top of a branch
1127  # $subdir will be used later to determine whether the merge is allowed or not
1128  my $subdir = $target->subdir;
1129  $target->subdir ('') if $subdir;
1130
1131  # Check for any local modifications
1132  # ----------------------------------------------------------------------------
1133  if (!$dry_run && !$non_interactive) {
1134    _svn_status_checker('merge', 'MODIFIED', $CLI_HANDLER_OF{WC_STATUS})->();
1135  }
1136
1137  # Determine the SOURCE URL
1138  # ----------------------------------------------------------------------------
1139  my $source;
1140
1141  if ($reverse) {
1142    # Reverse merge, the SOURCE is the the working copy URL
1143    $source = Fcm::CmBranch->new (URL => $target->url);
1144
1145  } else {
1146    # Automatic/custom merge, argument 1 is the SOURCE of the merge
1147    my $source_url = shift (@ARGV);
1148    if (!$source_url) {
1149      _cli_err('CLI_MERGE_ARG1');
1150    }
1151
1152    $source = _cm_get_source($source_url, $target);
1153  }
1154
1155  # Parse the revision option
1156  # ----------------------------------------------------------------------------
1157  if ($reverse && !$rev) {
1158    _cli_err('CLI_OPT_WITH_OPT', 'revision', 'reverse');
1159  }
1160  my @revs = (($reverse || $custom) && $rev ? split(qr{:}xms, $rev) : ());
1161
1162  # Determine the merge delta and the commit log message
1163  # ----------------------------------------------------------------------------
1164  my (@delta, $mesg);
1165  my $separator = '-' x 80 . "\n";
1166
1167  if ($reverse) {
1168    # Reverse merge
1169    # --------------------------------------------------------------------------
1170    if (@revs == 1) {
1171      $revs[1] = ($revs[0] - 1);
1172
1173    } else {
1174      @revs = sort {$b <=> $a} @revs;
1175    }
1176
1177    $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
1178      unless $source->pegrev;
1179    $source->subdir ($subdir);
1180
1181    # "Delta" of the "svn merge" command
1182    @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
1183
1184    # Template message
1185    $mesg = 'Reversed r' . $revs[0] .
1186            (($revs[1] < $revs[0] - 1) ? ':' . $revs[1] : '') . ' of ' .
1187            $source->path . "\n";
1188
1189  } elsif ($custom) {
1190    # Custom merge
1191    # --------------------------------------------------------------------------
1192    if (@revs) {
1193      # Revision specified
1194      # ------------------------------------------------------------------------
1195      # Only one revision N specified, use (N - 1):N as the delta
1196      unshift @revs, ($revs[0] - 1) if @revs == 1;
1197
1198      $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
1199        unless $source->pegrev;
1200      $source->subdir ($subdir);
1201      $target->subdir ($subdir);
1202
1203      # "Delta" of the "svn merge" command
1204      @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
1205
1206      # Template message
1207      $mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] .
1208              ' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n";
1209
1210    } else {
1211      # Revision not specified
1212      # ------------------------------------------------------------------------
1213      # Get second source URL
1214      my $source2_url = shift (@ARGV);
1215      if (!$source2_url) {
1216        _cli_err('CLI_MERGE_ARG2');
1217      }
1218
1219      my $source2 = _cm_get_source($source2_url, $target);
1220
1221      $source->pegrev  ($source->svninfo  (FLAG => 'Last Changed Rev'))
1222        unless $source->pegrev;
1223      $source2->pegrev ($source2->svninfo (FLAG => 'Last Changed Rev'))
1224        unless $source2->pegrev;
1225      $source->subdir  ($subdir);
1226      $source2->subdir ($subdir);
1227      $target->subdir  ($subdir);
1228
1229      # "Delta" of the "svn merge" command
1230      @delta = ($source->url_peg, $source2->url_peg);
1231
1232      # Template message
1233      $mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg .
1234              ' cf. ' . $source2->path_peg . "\n";
1235    }
1236
1237  } else {
1238    # Automatic merge
1239    # --------------------------------------------------------------------------
1240    # Check to ensure source branch is not the same as the target branch
1241    if (!$target->branch()) {
1242      return _cm_err(Fcm::Cm::Exception->WC_INVALID_BRANCH, $wct);
1243    }
1244    if ($source->branch() eq $target->branch()) {
1245      return _cm_err(Fcm::Cm::Exception->MERGE_SELF, $target->url_peg(), $wct);
1246    }
1247
1248    # Only allow the merge if the source and target are "directly related"
1249    # --------------------------------------------------------------------------
1250    my $anc = $target->ancestor ($source);
1251    return _cm_err(
1252      Fcm::Cm::Exception->MERGE_UNRELATED, $target->url_peg(), $source->url_peg
1253    ) unless
1254      ($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg)
1255      or
1256      ($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg)
1257      or
1258      ($anc->url eq $source->parent->url and $anc->url eq $target->parent->url);
1259
1260    # Check for available merges from the source
1261    # --------------------------------------------------------------------------
1262    my @revs = $target->avail_merge_from ($source, 1);
1263
1264    if (@revs) {
1265      if ($verbose) {
1266        # Verbose mode, print log messages of available merges
1267        $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), q{});
1268        for (@revs) {
1269          $CLI_MESSAGE->('SEPARATOR');
1270          $CLI_MESSAGE->(q{}, $source->display_svnlog($_));
1271        }
1272        $CLI_MESSAGE->('SEPARATOR');
1273      }
1274      else {
1275        # Normal mode, list revisions of available merges
1276        $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), join(q{ }, @revs));
1277      }
1278
1279    } else {
1280      return _cm_abort(Fcm::Cm::Abort->NULL);
1281    }
1282
1283    # If more than one merge available, prompt user to enter a revision number
1284    # to merge from, default to $revs [0]
1285    # --------------------------------------------------------------------------
1286    if ($non_interactive || @revs == 1) {
1287      $source->pegrev($revs[0]);
1288    }
1289    else {
1290      my $reply = $CLI_PROMPT->(
1291        {type => q{}, default => $revs[0]}, 'merge', 'MERGE_REV',
1292      );
1293      if (!defined($reply)) {
1294        return _cm_abort();
1295      }
1296      # Expand revision keyword if necessary
1297      if ($reply) {
1298        $reply = (Fcm::Keyword::expand($target->project_url(), $reply))[1];
1299      }
1300      # Check that the reply is a number in the available merges list
1301      if (!grep {$_ eq $reply} @revs) {
1302        return _cm_err(Fcm::Cm::Exception->MERGE_REV_INVALID, $reply)
1303      }
1304      $source->pegrev($reply);
1305    }
1306
1307    # If the working copy top is pointing to a sub-directory of a branch,
1308    # we need to check whether the merge will result in losing changes made in
1309    # other sub-directories of the source.
1310    if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) {
1311      return _cm_err(Fcm::Cm::Exception->MERGE_UNSAFE, $source->url_peg());
1312    }
1313
1314    # Calculate the base of the merge
1315    my $base = $target->base_of_merge_from ($source);
1316
1317    # $source and $base must take into account the sub-directory
1318    my $s = Fcm::CmBranch->new (URL => $source->url_peg);
1319    my $b = Fcm::CmBranch->new (URL => $base->url_peg);
1320
1321    $s->subdir ($subdir) if $subdir;
1322    $b->subdir ($subdir) if $subdir;
1323
1324    # Diagnostic
1325    $CLI_MESSAGE->('MERGE_CF', $s->path_peg(), $b->path_peg());
1326
1327    # Delta of the "svn merge" command
1328    @delta = ($b->url_peg, $s->url_peg);
1329
1330    # Template message
1331    $mesg = 'Merged into ' . $target->path . ': ' . $source->path_peg .
1332            ' cf. ' . $base->path_peg . "\n";
1333  }
1334
1335  # Run "svn merge" in "--dry-run" mode to see the result
1336  # ----------------------------------------------------------------------------
1337  my @out   = &run_command (
1338    [qw/svn merge --dry-run/, @delta],
1339    METHOD => 'qx', PRINT => ($dry_run and $verbose),
1340  );
1341
1342  # Abort merge if it will result in no change
1343  if (not @out) {
1344    return _cm_abort(Fcm::Cm::Abort->NULL);
1345  }
1346
1347  # Report result of "svn merge --dry-run"
1348  if ($dry_run || !$non_interactive) {
1349    $CLI_MESSAGE->('MERGE_DRY');
1350    $CLI_MESSAGE->('SEPARATOR');
1351    $CLI_MESSAGE->(q{}, join(q{}, @out));
1352    $CLI_MESSAGE->('SEPARATOR');
1353  }
1354
1355  return if $dry_run;
1356
1357  # Prompt the user to see if (s)he would like to go ahead
1358  # ----------------------------------------------------------------------------
1359  # Go ahead with merge only if user replies "y"
1360  if (!$non_interactive && $CLI_PROMPT->('merge', 'MERGE') ne 'y') {
1361    return _cm_abort();
1362  }
1363  $CLI_MESSAGE->('MERGE');
1364  run_command([qw/svn merge/, @delta], PRINT => $verbose);
1365
1366  # Prepare the commit log
1367  # ----------------------------------------------------------------------------
1368  # Read in any existing message
1369  my $ci_mesg = Fcm::CmCommitMessage->new;
1370  $ci_mesg->read_file;
1371  $ci_mesg->auto_mesg ([$mesg, @{ $ci_mesg->auto_mesg }]);
1372  $ci_mesg->write_file;
1373
1374  if ($verbose) {
1375    $CLI_MESSAGE->('SEPARATOR');
1376    $CLI_MESSAGE->('MERGE_CI', $mesg);
1377  }
1378
1379  return;
1380}
1381
1382# ------------------------------------------------------------------------------
1383# SYNOPSIS
1384#   &Fcm::Cm::cm_mkpatch ();
1385#
1386# DESCRIPTION
1387#   This is a FCM command to create a patching script from particular revisions
1388#   of a URL.
1389# ------------------------------------------------------------------------------
1390
1391sub cm_mkpatch {
1392  # Process command line options and arguments
1393  # ----------------------------------------------------------------------------
1394  my (@exclude, $organisation, $revision);
1395  my $rc = GetOptions(
1396    'exclude=s'      => \@exclude,
1397    'organisation=s' => \$organisation,
1398    'r|revision=s'   => \$revision,
1399  );
1400  if (!$rc) {
1401    _cli_err();
1402  }
1403
1404  # Excluded paths, convert glob into regular patterns
1405  @exclude = split (/:/, join (':', @exclude));
1406  for (@exclude) {
1407    s#\*#[^/]*#; # match any number of non-slash character
1408    s#\?#[^/]#;  # match a non-slash character
1409    s#/*$##;     # remove trailing slash
1410  }
1411
1412  # Organisation prefix
1413  $organisation = $organisation ? $organisation : 'original';
1414
1415  # Make sure revision option is set correctly
1416  my @revs = $revision ? split (/:/, $revision) : ();
1417  @revs    = @revs [0, 1] if @revs > 2;
1418
1419  # Arguments
1420  my ($u, $outdir) = @ARGV;
1421
1422  if (!$u) {
1423    _cli_err();
1424  }
1425
1426  my $url = Fcm::CmUrl->new (URL => $u);
1427  if (!$url->is_url()) {
1428    return _cm_err(Fcm::Cm::Exception->INVALID_URL, $u);
1429  }
1430  if (!$url->url_exists()) {
1431    return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $u);
1432  }
1433  if (!$url->branch()) {
1434    $CLI_MESSAGE->('INVALID_BRANCH', $u);
1435  }
1436  elsif ($url->subdir()) {
1437    $CLI_MESSAGE->('BRANCH_SUBDIR', $u);
1438  }
1439
1440  if (@revs) {
1441    # If HEAD revision is given, convert it into a number
1442    # --------------------------------------------------------------------------
1443    for my $rev (@revs) {
1444      $rev = $url->svninfo (FLAG => 'Revision') if uc ($rev) eq 'HEAD';
1445    }
1446
1447  } else {
1448    # If no revision is given, use the HEAD
1449    # --------------------------------------------------------------------------
1450    $revs[0] = $url->svninfo (FLAG => 'Revision');
1451  }
1452
1453  $revs[1] = $revs[0] if @revs == 1;
1454
1455  # Check that output directory is set
1456  # ----------------------------------------------------------------------------
1457  $outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir;
1458
1459  if (-e $outdir) {
1460    # Ask user to confirm removal of old output directory if it exists
1461    if ($CLI_PROMPT->('mkpatch', 'MKPATCH_OVERWRITE') ne 'y') {
1462      return _cm_abort();
1463    }
1464
1465    rmtree($outdir) || return _cm_err(Fcm::Cm::Exception->RMTREE, $outdir);
1466  }
1467
1468  # (Re-)create output directory
1469  mkpath($outdir) || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir);
1470  $CLI_MESSAGE->('OUT_DIR', $outdir);
1471
1472  # Get and process log of URL
1473  # ----------------------------------------------------------------------------
1474  my @script   = (); # main output script
1475  my %log      = $url->svnlog (REV => \@revs);
1476  my $url_path = $url->path;
1477
1478  for my $rev (sort {$a <=> $b} keys %log) {
1479    # Look at the changed paths for each revision
1480    my $use_patch = 1;  # OK to use a patch file?
1481    my @paths;
1482    PATH: for my $path (sort keys %{ $log{$rev}{paths} }) {
1483      my $file = $path;
1484
1485      # Skip paths outside of the branch
1486      next PATH unless $file =~ s#^$url_path/*##;
1487
1488      # Skip excluded paths
1489      for my $exclude (@exclude) {
1490        if ($file =~ m#^$exclude(?:/*|$)#) {
1491          # Can't use a patch file if any files have been excluded
1492          $use_patch = 0;
1493          next PATH;
1494        }
1495      }
1496
1497      # Can't use a patch file if any files have been added or replaced
1498      $use_patch = 0 if $log{$rev}{paths}{$path}{action} eq 'A' or
1499                        $log{$rev}{paths}{$path}{action} eq 'R';
1500
1501      push @paths, $path;
1502    }
1503
1504    # If a patch is being used, make sure it isn't just property changes
1505    if ($use_patch) {
1506      my @changedpaths;
1507      for my $path (@paths) {
1508        (my $file = $path) =~ s#^$url_path/*##;
1509        if ($log{$rev}{paths}{$path}{action} eq 'M') {
1510          my ($diff) = &run_command (
1511                         [qw/svn diff --no-diff-deleted --summarize -c/,
1512                          $rev, $url->url . '/' . $file. '@' . $rev],
1513                         METHOD => 'qx');
1514          next unless $diff =~ /^[A-Z]/;
1515        }
1516        push @changedpaths, $path;
1517      }
1518      @paths = @changedpaths;
1519    }
1520
1521    next unless @paths;
1522
1523    # Create the patch using "svn diff"
1524    my @patch = ();
1525    if ($use_patch) {
1526      @patch = &run_command ([qw/svn diff --no-diff-deleted -c/, $rev,
1527                              $url->url], METHOD => 'qx');
1528      if (@patch) {
1529        # Don't use the patch if it may contain subversion keywords
1530        for (@patch) {
1531          $use_patch = 0 if /\$[a-zA-Z:]+ *\$/;
1532        }
1533      } else {
1534        $use_patch = 0;
1535      }
1536    }
1537
1538    # Create a directory for this revision in the output directory
1539    my $outdir_rev = File::Spec->catfile ($outdir, $rev);
1540    mkpath($outdir_rev)
1541      || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir_rev);
1542
1543    # Parse commit log message
1544    my @msg = split /\n/, $log{$rev}{msg};
1545    for (@msg) {
1546      # Re-instate line break
1547      $_ .= "\n";
1548
1549      # Remove line if it matches a merge template
1550      $_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/;
1551      $_ = '' if /^Custom merge into \S+:.+$/;
1552      $_ = '' if /^Merged into \S+: \S+ cf\. \S+$/;
1553
1554      # Modify Trac ticket link
1555      s/(?:#|ticket:)(\d+)/${organisation}_ticket:$1/g;
1556
1557      # Modify Trac changeset link
1558      s/(?:r|changeset:)(\d+)/${organisation}_changeset:$1/g;
1559      s/\[(\d+)\]/${organisation}_changeset:$1/g;
1560    }
1561
1562    push @msg, '(' . $organisation . '_changeset:' . $rev . ')' . "\n";
1563
1564    # Write commit log message in a file
1565    my $f_revlog = File::Spec->catfile ($outdir_rev, 'log-message');
1566    open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')';
1567    print FILE @msg;
1568    close FILE or die $f_revlog, ': cannot close (', $!, ')';
1569
1570    # Handle each changed path
1571    my $export_file   = 1;  # name for next exported file (gets incremented)
1572    my $patch_needed  = 0;  # is a patch file required?
1573    my @before_script = (); # patch script to run before patch applied
1574    my @after_script  = (); # patch script to run after patch applied
1575    my @copied_dirs   = (); # copied directories
1576    CHANGED: for my $path (@paths) {
1577      (my $file = $path) =~ s#^$url_path/*##;
1578      my $url_file = $url->url . '/' . $file . '@' . $rev;
1579
1580      # Skip paths within copied directories
1581      for my $copied_dir (@copied_dirs) {
1582        next CHANGED if $file =~ m#^$copied_dir(?:/*|$)#;
1583      }
1584
1585      if ($log{$rev}{paths}{$path}{action} eq 'D') {
1586        # Script to delete file
1587        push @after_script, 'svn delete ' . $file;
1588
1589      } else {
1590        my $export_required = 0;
1591        my $recursive_add   = 0;
1592        my $is_newfile      = 0;
1593
1594        # Skip property changes
1595        if ($log{$rev}{paths}{$path}{action} eq 'M') {
1596          my ($diff) = &run_command (
1597                         [qw/svn diff --no-diff-deleted --summarize -c/,
1598                          $rev, $url->url . '/' . $file. '@' . $rev],
1599                         METHOD => 'qx');
1600          next CHANGED unless $diff =~ /^[A-Z]/;
1601        }
1602
1603        # Determine if the file is a directory
1604        my $is_dir = 0;
1605        if ($log{$rev}{paths}{$path}{action} ne 'M') {
1606          my @info = &run_command ([qw/svn info/, $url_file], METHOD => 'qx');
1607          for (@info) {
1608            if (/^Node Kind: (\w+)/) {
1609              $is_dir = 1 if $1 eq 'directory';
1610              last;
1611            }
1612          }
1613        }
1614
1615        # Decide how to treat added files
1616        if ($log{$rev}{paths}{$path}{action} eq 'A') {
1617          # Determine if the file is copied
1618          if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) {
1619            if ($is_dir) {
1620              # A copied directory needs to be treated as a new file, exported
1621              # and added recursively
1622              $is_newfile      = 1;
1623              $export_required = 1;
1624              $recursive_add   = 1;
1625              push @copied_dirs, $file;
1626            } else {
1627              # History exists for this file
1628              my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'};
1629              my $copyfrom_rev  = $log{$rev}{paths}{$path}{'copyfrom-rev'};
1630              my $cp_url = Fcm::CmUrl->new (
1631                URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev,
1632              );
1633
1634              if ($copyfrom_path =~ s#^$url_path/*##) {
1635                # File is copied from a file under the specified URL
1636                # Check source exists
1637                $is_newfile = 1 unless $cp_url->url_exists ($rev - 1);
1638              } else {
1639                # File copied from outside of the specified URL
1640                $is_newfile = 1;
1641
1642                # Check branches can be determined
1643                if ($url->branch and $cp_url->branch) {
1644
1645                  # Follow its history, stop on copy
1646                  my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1);
1647
1648                  # "First" revision of the copied file
1649                  my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0];
1650                  my %attrib = %{ $cp_log{$cp_rev}{paths}{$cp_url->path} }
1651                    if $cp_log{$cp_rev}{paths}{$cp_url->path};
1652
1653                  # Check whether the "first" revision is copied from elsewhere.
1654                  if (exists $attrib{'copyfrom-path'}) {
1655                    # If source exists in the specified URL, set up the copy
1656                    my $cp_cp_url = Fcm::CmUrl->new (
1657                      URL => $url->root . $attrib{'copyfrom-path'} . '@' .
1658                             $attrib{'copyfrom-rev'},
1659                    );
1660                    $cp_cp_url->branch ($url->branch);
1661                    if ($cp_cp_url->url_exists ($rev - 1)) {
1662                      ($copyfrom_path = $cp_cp_url->path) =~ s#^$url_path/*##;
1663                      # Check path is defined - if not it probably means the
1664                      # branch doesn't follow the FCM naming convention
1665                      $is_newfile = 0 if $copyfrom_path;
1666                    }
1667                  }
1668
1669                  # Note: The logic above does not cover all cases. However, it
1670                  # should do the right thing for the most common case. Even
1671                  # where it gets it wrong the file contents should always be
1672                  # correct even if the file history is not.
1673                }
1674              }
1675
1676              # Check whether file is copied from an excluded path
1677              if (not $is_newfile) {
1678                for my $exclude (@exclude) {
1679                  if ($copyfrom_path =~ m#^$exclude(?:/*|$)#) {
1680                    $is_newfile = 1;
1681                    last;
1682                  }
1683                }
1684              }
1685
1686              # Script to copy file, if required
1687              push @before_script, 'svn copy ' . $copyfrom_path .  ' ' . $file
1688                if not $is_newfile;
1689            }
1690
1691          } else {
1692            # History does not exist, must be a new file
1693            $is_newfile = 1;
1694            # If it's a directory then create it (in case patch doesn't)
1695            push @before_script, 'mkdir ' . $file if $is_dir;
1696          }
1697        }
1698
1699        if ($log{$rev}{paths}{$path}{action} eq 'R') {
1700          # Script to delete file
1701          push @before_script, 'svn delete ' . $file;
1702
1703          # Now treat as new file
1704          $is_newfile = 1;
1705        }
1706
1707        # Script to add the file, if required
1708        if ($is_newfile) {
1709          if ($recursive_add) {
1710            push @after_script, 'svn add ' . $file;
1711          } else {
1712            push @after_script, 'svn add --non-recursive ' . $file;
1713          }
1714        }
1715
1716        # Decide whether the file needs to be exported
1717        if (not $is_dir) {
1718          if (not $use_patch) {
1719            $export_required = 1;
1720          } else {
1721            # Export the file if it is binary
1722            my @mime_type = &run_command
1723             ([qw/svn propget svn:mime-type/, $url_file], METHOD => 'qx');
1724            for (@mime_type) {
1725              $export_required = 1 if not /^text\//;
1726            }
1727            # Only create a patch file if necessary
1728            $patch_needed = 1 if not $export_required;
1729          }
1730        }
1731
1732        if ($export_required) {
1733          # Download the file using "svn export"
1734          my $export = File::Spec->catfile ($outdir_rev, $export_file);
1735          &run_command ([qw/svn export -q -r/, $rev, $url_file, $export]);
1736
1737          # Copy the exported file into the file
1738          push @before_script,
1739               'cp -r ${fcm_patch_dir}/' . $export_file . ' ' . $file;
1740          $export_file++;
1741        }
1742      }
1743    }
1744
1745    # Write the patch file
1746    if ($patch_needed) {
1747      my $patchfile = File::Spec->catfile ($outdir_rev, 'patchfile');
1748      open FILE, '>', $patchfile
1749        or die $patchfile, ': cannot open (', $!, ')';
1750      print FILE @patch;
1751      close FILE or die $patchfile, ': cannot close (', $!, ')';
1752    }
1753
1754    # Add line break to each line in @before_script and @after_script
1755    @before_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")}
1756                     @before_script if (@before_script);
1757    @after_script  = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")}
1758                     @after_script if (@after_script);
1759
1760    # Write patch script to output
1761    my $out = File::Spec->catfile ($outdir_rev, 'apply-patch');
1762    open FILE, '>', $out or die $out, ': cannot open (', $!, ')';
1763
1764    # Script header
1765    my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/);
1766    print FILE <<EOF;
1767#!$shell
1768# ------------------------------------------------------------------------------
1769# NAME
1770#   apply-patch
1771#
1772# DESCRIPTION
1773#   This script is generated automatically by the "fcm mkpatch" command. It
1774#   applies the patch to the current working directory which must be a working
1775#   copy of a valid project tree that can accept the import of the patches.
1776#
1777#   Patch created from $organisation URL: $u
1778#   Changeset: $rev
1779# ------------------------------------------------------------------------------
1780
1781this=`basename \$0`
1782echo "\$this: Applying patch for changeset $rev."
1783
1784# Location of the patch, base on the location of this script
1785cd `dirname \$0` || exit 1
1786fcm_patch_dir=\$PWD
1787
1788# Change directory back to the working copy
1789cd \$OLDPWD || exit 1
1790
1791# Check working copy does not have local changes
1792status=`svn status`
1793if [[ -n \$status ]]; then
1794  echo "\$this: working copy contains changes, abort." >&2
1795  exit 1
1796fi
1797if [[ -a "#commit_message#" ]]; then
1798  echo "\$this: existing commit message in "#commit_message#", abort." >&2
1799  exit 1
1800fi
1801
1802# Apply the changes
1803EOF
1804
1805    # Script content
1806    print FILE @before_script if @before_script;
1807    print FILE "patch -p0 <\${fcm_patch_dir}/patchfile || exit 1\n"
1808      if $patch_needed;
1809    print FILE @after_script  if @after_script;
1810
1811    # Script footer
1812    print FILE <<EOF;
1813
1814# Copy in the commit message
1815cp \${fcm_patch_dir}/log-message "#commit_message#"
1816
1817echo "\$this: finished normally."
1818#EOF
1819EOF
1820
1821    close FILE or die $out, ': cannot close (', $!, ')';
1822
1823    # Add executable permission
1824    chmod 0755, $out;
1825
1826    # Script to commit the change
1827    push @script, '${fcm_patches_dir}/' . $rev . '/apply-patch';
1828    push @script, 'svn commit -F "#commit_message#"';
1829    push @script, 'rm -f "#commit_message#"';
1830    push @script, 'svn update';
1831    push @script, '';
1832
1833    $CLI_MESSAGE->('PATCH_REV', $rev);
1834  }
1835
1836  # Write the main output script if necessary. Otherwise remove output directory
1837  # ----------------------------------------------------------------------------
1838  if (@script) {
1839    # Add line break to each line in @script
1840    @script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @script;
1841
1842    # Write script to output
1843    my $out = File::Spec->catfile ($outdir, 'fcm-import-patch');
1844    open FILE, '>', $out or die $out, ': cannot open (', $!, ')';
1845
1846    # Script header
1847    my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/);
1848    print FILE <<EOF;
1849#!$shell
1850# ------------------------------------------------------------------------------
1851# NAME
1852#   fcm-import-patch
1853#
1854# SYNOPSIS
1855#   fcm-import-patch TARGET
1856#
1857# DESCRIPTION
1858#   This script is generated automatically by the "fcm mkpatch" command, as are
1859#   the revision "patches" created in the same directory. The script imports the
1860#   patches into TARGET, which must either be a URL or a working copy of a valid
1861#   project tree that can accept the import of the patches.
1862#
1863#   Patch created from $organisation URL: $u
1864# ------------------------------------------------------------------------------
1865
1866this=`basename \$0`
1867
1868# Check argument
1869target=\$1
1870
1871# First argument must be a URL or working copy
1872if [[ -z \$target ]]; then
1873  echo "\$this: the first argument must be a URL or a working copy, abort." >&2
1874  exit 1
1875fi
1876
1877if [[ \$target == svn://*  || \$target == svn+ssh://* || \\
1878      \$target == http://* || \$target == https://*   || \\
1879      \$target == file://* ]]; then
1880  # A URL, checkout a working copy in a temporary location
1881  fcm_tmp_dir=`mktemp -d \${TMPDIR:=/tmp}/\$this.XXXXXX`
1882  fcm_working_copy=\$fcm_tmp_dir
1883  svn checkout -q \$target \$fcm_working_copy || exit 1
1884else
1885  fcm_working_copy=\$target
1886fi
1887
1888# Location of the patches, base on the location of this script
1889cd `dirname \$0` || exit 1
1890fcm_patches_dir=\$PWD
1891
1892# Change directory to the working copy
1893cd \$fcm_working_copy || exit 1
1894
1895# Set the language to avoid encoding problems
1896export LANG=en_GB
1897
1898# Commands to apply patches
1899EOF
1900
1901    # Script content
1902    print FILE @script;
1903
1904    # Script footer
1905    print FILE <<EOF;
1906# Remove temporary working copy, if necessary
1907if [[ -d \$fcm_tmp_dir && -w \$fcm_tmp_dir ]]; then
1908  rm -rf \$fcm_tmp_dir
1909fi
1910
1911echo "\$this: finished normally."
1912#EOF
1913EOF
1914
1915    close FILE or die $out, ': cannot close (', $!, ')';
1916
1917    # Add executable permission
1918    chmod 0755, $out;
1919
1920    # Diagnostic
1921    $CLI_MESSAGE->('PATCH_DONE', $outdir);
1922
1923  } else {
1924    # Remove output directory
1925    rmtree $outdir or die $outdir, ': cannot remove';
1926
1927    # Diagnostic
1928    return _cm_abort(Fcm::Cm::Abort->NULL);
1929  }
1930
1931  return 1;
1932}
1933
1934# ------------------------------------------------------------------------------
1935# CLI: fcm add.
1936sub _cli_command_add {
1937    my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_;
1938    my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'});
1939    return (
1940        @args == @_ ? _svn("add", @args) : cm_check_unknown(\%option, @args)
1941    );
1942}
1943
1944# ------------------------------------------------------------------------------
1945# CLI: fcm checkout.
1946sub _cli_command_checkout {
1947    if (@ARGV) {
1948        my $target = is_url($ARGV[-1]) ? cwd() : $ARGV[-1];
1949        if (-d $target && is_wc($target)) {
1950            return _cm_err(Fcm::Cm::Exception->WC_EXIST, $target);
1951        }
1952    }
1953    return _svn('checkout', @ARGV);
1954}
1955
1956# ------------------------------------------------------------------------------
1957# CLI: fcm delete.
1958sub _cli_command_delete {
1959    my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_;
1960    my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'});
1961    return (
1962        @args == @_ ? _svn("delete", @args) : cm_check_missing(\%option, @args)
1963    );
1964}
1965
1966# ------------------------------------------------------------------------------
1967# CLI: fcm switch.
1968sub _cli_command_switch {
1969    local(@ARGV) = @_;
1970    if (grep {$_ eq '--relocate'} @ARGV) {
1971        return _svn('switch', @ARGV);
1972    }
1973    my %option;
1974    if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) {
1975        _cli_err();
1976    }
1977    if (!$option{'non-interactive'}) {
1978        $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS};
1979    }
1980    if (!@ARGV) {
1981        _cli_err();
1982    }
1983    $CLI_MESSAGE->(q{}, join(q{}, cm_switch(\%option, @ARGV)));
1984}
1985
1986# ------------------------------------------------------------------------------
1987# CLI: fcm update.
1988sub _cli_command_update {
1989    local(@ARGV) = @_;
1990    my %option;
1991    if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) {
1992        _cli_err();
1993    }
1994    if (!$option{'non-interactive'}) {
1995        $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS};
1996    }
1997    $CLI_MESSAGE->(q{}, join(q{}, cm_update(\%option, @ARGV)));
1998}
1999
2000# ------------------------------------------------------------------------------
2001# CLI error.
2002sub _cli_err {
2003    my ($key, @args) = @_;
2004    $key ||= 'CLI_USAGE';
2005    my $message = sprintf($CLI_MESSAGE_FOR_ERROR{$key}, @args);
2006    die(Fcm::CLI::Exception->new({message => $message}));
2007}
2008
2009# ------------------------------------------------------------------------------
2010# Handles abort exception.
2011sub _cli_e_handler_of_cm_abort {
2012    my ($function, $e) = @_;
2013    if ($e->get_code() eq $e->FAIL) {
2014        die(sprintf($CLI_MESSAGE_FOR_ABORT{FAIL}, $function));
2015    }
2016    else {
2017        $CLI_MESSAGE->($e->get_code(), $function);
2018    }
2019}
2020
2021# ------------------------------------------------------------------------------
2022# Handles CM exception.
2023sub _cli_e_handler_of_cm_exception {
2024    my ($function, $e) = @_;
2025    die(sprintf($CLI_MESSAGE_FOR_ERROR{$e->get_code()}, $e->get_targets()));
2026}
2027
2028# ------------------------------------------------------------------------------
2029# Handles CLI exception.
2030sub _cli_e_handler_of_cli_exception {
2031    my ($function, $e) = @_;
2032    $CLI_MESSAGE->('CLI', $e);
2033    $CLI_MESSAGE->('CLI_HELP', $function);
2034}
2035
2036# ------------------------------------------------------------------------------
2037# The default handler of the "WC_STATUS" event.
2038sub _cli_handler_of_wc_status {
2039    my ($name, $target_list_ref, $status_list_ref) = @_;
2040    if (@{$status_list_ref}) {
2041        $CLI_MESSAGE->('STATUS', join(q{}, @{$status_list_ref}));
2042        if ($CLI_PROMPT->($name, 'CONTINUE') ne 'y') {
2043            return _cm_abort();
2044        }
2045    }
2046    return @{$status_list_ref};
2047}
2048
2049# ------------------------------------------------------------------------------
2050# The default handler of the "WC_STATUS_PATH" event.
2051sub _cli_handler_of_wc_status_path {
2052    my ($name, $target_list_ref, $status_list_ref) = @_;
2053    $CLI_MESSAGE->(q{}, join(q{}, @{$status_list_ref}));
2054    my @paths = map {chomp(); ($_ =~ $PATTERN_OF{ST_PATH})} @{$status_list_ref};
2055    my @paths_of_interest;
2056    while (my $path = shift(@paths)) {
2057        my %handler_of = (
2058            a => sub {push(@paths_of_interest, $path, @paths); @paths = ()},
2059            n => sub {},
2060            y => sub {push(@paths_of_interest, $path)},
2061        );
2062        my $reply = $CLI_PROMPT->(
2063            {type => 'yna'}, $name, 'RUN_SVN_COMMAND', "$name $path",
2064        );
2065        $handler_of{$reply}->();
2066    }
2067    return @paths_of_interest;
2068}
2069
2070# ------------------------------------------------------------------------------
2071# Prints help for a given $subcommand.
2072sub _cli_help {
2073    my ($key, $exit_val) = @_;
2074    my $pod
2075        = File::Spec->catfile(dirname($INC{'Fcm/Cm.pm'}), 'CLI', "fcm-$key.pod");
2076    my $has_pod = -f $pod;
2077    if ($has_pod) {
2078        pod2usage({
2079            '-exitval' => defined($exit_val) ? $exit_val : 2,
2080            '-input'   => $pod,
2081            '-verbose' => 1,
2082        });
2083    }
2084    if (!$has_pod || exists($CLI_MORE_HELP_FOR{$key})) {
2085        local(@ARGV) = ($key);
2086        return _svn('help', $key);
2087    }
2088}
2089
2090# ------------------------------------------------------------------------------
2091# Expands location keywords in a list.
2092sub _cli_keyword_expand_url {
2093    my ($arg_list_ref) = @_;
2094    ARG:
2095    for my $arg (@{$arg_list_ref}) {
2096        my ($label, $value) = ($arg =~ $PATTERN_OF{CLI_OPT});
2097        if (!$label) {
2098            ($label, $value) = (q{}, $arg);
2099        }
2100        if (!$value) {
2101            next ARG;
2102        }
2103        eval {
2104            $value = Fcm::Util::tidy_url(Fcm::Keyword::expand($value));
2105        };
2106        if ($@) {
2107            if ($value ne 'fcm:revision') {
2108                die($@);
2109            }
2110        }
2111        $arg = $label . $value;
2112    }
2113}
2114
2115# ------------------------------------------------------------------------------
2116# Expands revision keywords in -r and --revision options in a list.
2117sub _cli_keyword_expand_rev {
2118    my ($arg_list_ref) = @_;
2119    my @targets;
2120    for my $arg (@{$arg_list_ref}) {
2121        if (-e $arg && is_wc($arg) || is_url($arg)) {
2122            push(@targets, $arg);
2123        }
2124    }
2125    if (!@targets) {
2126        push(@targets, get_url_of_wc());
2127    }
2128    if (!@targets) {
2129        return;
2130    }
2131    my @old_arg_list = @{$arg_list_ref};
2132    my @new_arg_list = ();
2133    ARG:
2134    while (defined(my $arg = shift(@old_arg_list))) {
2135        my ($key, $value) = $arg =~ $PATTERN_OF{CLI_OPT_REV};
2136        if (!$key) {
2137            push(@new_arg_list, $arg);
2138            next ARG;
2139        }
2140        push(@new_arg_list, '--revision');
2141        if (!$value) {
2142            $value = shift(@old_arg_list);
2143        }
2144        my @revs = grep {defined()} ($value =~ $PATTERN_OF{CLI_OPT_REV_RANGE});
2145        my ($url, @url_list) = @targets;
2146        for my $rev (@revs) {
2147            if ($rev !~ $PATTERN_OF{SVN_REV}) {
2148                $rev = (Fcm::Keyword::expand($url, $rev))[1];
2149            }
2150            if (@url_list) {
2151                $url = shift(@url_list);
2152            }
2153        }
2154        push(@new_arg_list, join(q{:}, @revs));
2155    }
2156    @{$arg_list_ref} = @new_arg_list;
2157}
2158
2159# ------------------------------------------------------------------------------
2160# Prints a message.
2161sub _cli_message {
2162    my ($key, @args) = @_;
2163    for (
2164        [\*STDOUT, \%CLI_MESSAGE_FOR        , q{}          ],
2165        [\*STDERR, \%CLI_MESSAGE_FOR_WARNING, q{[WARNING] }],
2166        [\*STDERR, \%CLI_MESSAGE_FOR_ABORT  , q{[ABORT] }  ],
2167        [\*STDERR, \%CLI_MESSAGE_FOR_ERROR  , q{[ERROR] }  ],
2168    ) {
2169        my ($handle, $hash_ref, $prefix) = @{$_};
2170        if (exists($hash_ref->{$key})) {
2171            return printf({$handle} $prefix . $hash_ref->{$key}, @args);
2172        }
2173    }
2174}
2175
2176# ------------------------------------------------------------------------------
2177# Wrapper for Fcm::Interactive::get_input.
2178sub _cli_prompt {
2179    my %option
2180        = (type => 'yn', default => 'n', (ref($_[0]) ? %{shift(@_)} : ()));
2181    my ($name, $key, @args) = @_;
2182    return Fcm::Interactive::get_input(
2183        title   => $CLI_PROMPT_PREFIX . $name,
2184        message => sprintf($CLI_MESSAGE_FOR_PROMPT{$key}, @args),
2185        %option,
2186    );
2187}
2188
2189# ------------------------------------------------------------------------------
2190# Check missing status and delete.
2191sub cm_check_missing {
2192    my %option = %{shift()};
2193    my $checker
2194        = _svn_status_checker('delete', 'MISSING', $option{st_check_handler});
2195    my @paths = $checker->(\@_);
2196    if (@paths) {
2197        run_command([qw{svn delete}, @paths]);
2198    }
2199}
2200
2201# ------------------------------------------------------------------------------
2202# Check unknown status and add.
2203sub cm_check_unknown {
2204    my %option = %{shift()};
2205    my $checker
2206        = _svn_status_checker('add', 'UNKNOWN', $option{st_check_handler});
2207    my @paths = $checker->(\@_);
2208    if (@paths) {
2209        run_command([qw{svn add}, @paths]);
2210    }
2211}
2212
2213# ------------------------------------------------------------------------------
2214# FCM wrapper to SVN switch.
2215sub cm_switch {
2216    my %option = %{shift()};
2217    my ($target, $path) = @_;
2218    $path ||= cwd();
2219    if (!-e $path) {
2220        return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path);
2221    }
2222    if (!is_wc($path)) {
2223        return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path);
2224    }
2225
2226    # Check for merge template in the commit log file in the working copy
2227    my $path_of_wc = get_wct($path);
2228    my $ci_mesg = Fcm::CmCommitMessage->new();
2229    $ci_mesg->dir($path_of_wc);
2230    $ci_mesg->read_file();
2231    if (@{$ci_mesg->auto_mesg()}) {
2232        return _cm_err(
2233            Fcm::Cm::Exception->SWITCH_UNSAFE,
2234            $path eq $path_of_wc ? $ci_mesg->base() : $ci_mesg->file(),
2235        );
2236    }
2237
2238    # Check for any local modifications
2239    if (defined($option{st_check_handler})) {
2240        my $handler = $CLI_HANDLER_OF{WC_STATUS};
2241        _svn_status_checker('switch', 'MODIFIED', $handler)->([$path_of_wc]);
2242    }
2243
2244    # Invokes "svn switch"
2245    _svn(
2246        {METHOD => 'qx', PRINT => !$option{quiet}},
2247        'switch',
2248        ($option{'non-interactive'} ? '--non-interactive'       : ()),
2249        ($option{revision}          ? ('-r', $option{revision}) : ()),
2250        ($option{quiet}             ? '--quiet'                 : ()),
2251        _cm_get_source(
2252            $target,
2253            Fcm::CmBranch->new(URL => get_url_of_wc($path_of_wc)),
2254        )->url_peg(),
2255        ($path_of_wc eq cwd() ? () : $path_of_wc),
2256    );
2257}
2258
2259# ------------------------------------------------------------------------------
2260# FCM wrapper to SVN update.
2261sub cm_update {
2262    my %option = %{shift()};
2263    my @targets = @_;
2264    if (!@targets) {
2265        @targets = (cwd());
2266    }
2267    for my $target (@targets) {
2268        if (!-e $target) {
2269            return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $target);
2270        }
2271        if (!is_wc($target)) {
2272            return _cm_err(Fcm::Cm::Exception->INVALID_WC, $target);
2273        }
2274        $target = get_wct($target);
2275        if ($target eq cwd()) {
2276            $target = q{.};
2277        }
2278    }
2279    if (defined($option{st_check_handler})) {
2280        my ($matcher_keys_ref, $show_updates)
2281            = defined($option{revision}) ? (['MODIFIED'               ], undef)
2282            :                              (['MODIFIED', 'OUT_OF_DATE'], 1    )
2283            ;
2284        my $matcher = sub {
2285            for my $key (@{$matcher_keys_ref}) {
2286                $ST_MATCHER_FOR{$key}->(@_) && return 1;
2287            }
2288        };
2289        _svn_status_checker(
2290            'update', $matcher, $option{st_check_handler}, $show_updates,
2291        )->(\@targets);
2292    }
2293    if ($option{revision} && $option{revision} !~ $PATTERN_OF{SVN_REV}) {
2294        $option{revision} = (
2295            Fcm::Keyword::expand(get_url_of_wc($targets[0]), $option{revision})
2296        )[1];
2297    }
2298    return _svn_update(\@targets, \%option);
2299}
2300
2301# ------------------------------------------------------------------------------
2302# Raises an abort exception.
2303sub _cm_abort {
2304    my ($code) = @_;
2305    $code ||= Fcm::Cm::Abort->USER;
2306    die(bless({code => $code, message => 'abort'}, 'Fcm::Cm::Abort'));
2307}
2308
2309# ------------------------------------------------------------------------------
2310# Raises a failure.
2311sub _cm_err {
2312    my ($code, @targets) = @_;
2313    die(bless(
2314        {code => $code, message => "ERROR: $code", targets => \@targets},
2315        'Fcm::Cm::Exception',
2316    ));
2317}
2318
2319# ------------------------------------------------------------------------------
2320# Returns the corresponding Fcm::CmBranch instance for $src_url w.r.t. $target.
2321sub _cm_get_source {
2322    my ($src_url, $target) = @_;
2323    my $source = Fcm::CmBranch->new(URL => $src_url);
2324    if (!$source->is_url()) {
2325        # Not a full URL, construct full URL based on current URL
2326        $source->url_peg($target->url_peg());
2327        my $project = $target->project();
2328        my ($path) = $src_url =~ qr{\A/*(.*)\z}xms;
2329        if (index($path, $project) == 0) {
2330            # Argument contains the full path under the repository root
2331            $path = substr($path, length($project));
2332        }
2333        if ($path =~ $PATTERN_OF{FCM_BRANCH_PATH}) {
2334            # Argument contains the full branch name
2335            $path = join(q{/}, $target->project_path(), $path);
2336        }
2337        else {
2338            # Argument contains the shorter branch name
2339            $path = join(q{/}, $target->project_path(), 'branches', $path);
2340        }
2341        $source->path_peg($path);
2342    }
2343    # Replace source sub-directory with the target sub-directory
2344    $source->subdir($target->subdir());
2345    # Ensure that the branch name exists
2346    if (!$source->url_exists()) {
2347        return _cm_err(Fcm::Cm::Exception->INVALID_URL, $src_url);
2348    }
2349    # Ensure that the branch name is valid
2350    if (!$source->branch()) {
2351        return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $src_url);
2352    }
2353    # Ensure that the source and target URLs are in the same project
2354    if ($source->project_url() ne $target->project_url()) {
2355        return _cm_err(
2356            Fcm::Cm::Exception->DIFF_PROJECTS,
2357            $target->url_peg(),
2358            $source->url_peg(),
2359        );
2360    }
2361    return $source;
2362}
2363
2364# ------------------------------------------------------------------------------
2365# Runs "svn".
2366sub _svn {
2367    my @args = @_;
2368    my %option;
2369    if (@args && ref($args[0])) {
2370        %option = %{shift(@args)};
2371    }
2372    return run_command(
2373        ['svn', @args],
2374        PRINT => ($args[0] ne 'cat' && !grep {$_ eq '--xml'} @args),
2375        %option,
2376    );
2377}
2378
2379# ------------------------------------------------------------------------------
2380# Returns the results of "svn status".
2381sub _svn_status_get {
2382    my ($target_list_ref, $show_updates) = @_;
2383    my @targets = (defined($target_list_ref) ? @{$target_list_ref} : ());
2384    for my $target (@targets) {
2385        if ($target eq cwd()) {
2386            $target = q{.};
2387        }
2388    }
2389    my @options = ($show_updates ? qw{--show-updates} : ());
2390    return _svn({METHOD => 'qx', PRINT => 0}, 'status', @options, @targets);
2391}
2392
2393# ------------------------------------------------------------------------------
2394# Returns a "svn status" checker.
2395sub _svn_status_checker {
2396    my ($name, $matcher, $handler, $show_updates) = @_;
2397    if (!ref($matcher)) {
2398        $matcher = $ST_MATCHER_FOR{$matcher};
2399    }
2400    return sub {
2401        my ($target_list_ref) = @_;
2402        my @status = _svn_status_get($target_list_ref, $show_updates);
2403        if ($show_updates) {
2404            @status = map {$_ =~ $PATTERN_OF{ST_AGAINST_REV} ? () : $_} @status;
2405        }
2406        my @status_of_interest = grep {$matcher->($_)} @status;
2407        if (defined($handler)) {
2408            return $handler->($name, $target_list_ref, \@status_of_interest);
2409        }
2410        return @status_of_interest;
2411    }
2412}
2413
2414# ------------------------------------------------------------------------------
2415# Runs "svn update".
2416sub _svn_update {
2417    my ($target_list_ref, $option_hash_ref) = @_;
2418    my %option = (defined($option_hash_ref) ? %{$option_hash_ref} : ());
2419    _svn(
2420        {METHOD => 'qx', PRINT => !$option{quiet}},
2421        'update',
2422        ($option{'non-interactive'} ? '--non-interactive'       : ()),
2423        ($option{revision}          ? ('-r', $option{revision}) : ()),
2424        ($option{quiet}             ? '--quiet'                 : ()),
2425        (defined($target_list_ref) ? @{$target_list_ref} : ()),
2426    );
2427}
2428
2429# ------------------------------------------------------------------------------
2430# Abort exception.
2431package Fcm::Cm::Abort;
2432use base qw{Fcm::Exception};
2433use constant {FAIL => 'FAIL', NULL => 'NULL', USER => 'USER'};
2434
2435sub get_code {
2436    return $_[0]->{code};
2437}
2438
2439# ------------------------------------------------------------------------------
2440# Resource exception.
2441package Fcm::Cm::Exception;
2442our @ISA = qw{Fcm::Cm::Abort};
2443use constant {
2444    CHDIR             => 'CHDIR',
2445    INVALID_BRANCH    => 'INVALID_BRANCH',
2446    INVALID_PROJECT   => 'INVALID_PROJECT',
2447    INVALID_TARGET    => 'INVALID_TARGET',
2448    INVALID_URL       => 'INVALID_URL',
2449    INVALID_WC        => 'INVALID_WC',
2450    MERGE_REV_INVALID => 'MERGE_REV_INVALID',
2451    MERGE_SELF        => 'MERGE_SELF',
2452    MERGE_UNRELATED   => 'MERGE_UNRELATED',
2453    MERGE_UNSAFE      => 'MERGE_UNSAFE',
2454    MKPATH            => 'MKPATH',
2455    NOT_EXIST         => 'NOT_EXIST',
2456    PARENT_NOT_EXIST  => 'PARENT_NOT_EXIST',
2457    RMTREE            => 'RMTREE',
2458    SWITCH_UNSAFE     => 'SWITCH_UNSAFE',
2459    WC_EXIST          => 'WC_EXIST',
2460    WC_INVALID_BRANCH => 'WC_INVALID_BRANCH',
2461    WC_URL_NOT_EXIST  => 'WC_URL_NOT_EXIST',
2462};
2463
2464sub get_targets {
2465    return @{$_[0]->{targets}};
2466}
2467
24681;
2469__END__
2470
2471=pod
2472
2473=head1 NAME
2474
2475Fcm::Cm
2476
2477=head1 SYNOPSIS
2478
2479    use Fcm::Cm qw{cli};
2480
2481    # Use as a wrapper to Subversion, and other FCM code management commands
2482    cli('info', '--revision', 'HEAD', $url);
2483
2484    use Fcm::Cm qw{cm_check_missing cm_check_unknown cm_switch cm_update};
2485
2486    # Checks status for "missing" items and "svn delete" them
2487    $missing_st_handler = sub {
2488        my ($name, $target_list_ref, $status_list_ref) = @_;
2489        # ...
2490        return @paths_of_interest;
2491    };
2492    cm_check_missing({st_check_handler => $missing_st_handler}, @targets);
2493
2494    # Checks status for "unknown" items and "svn add" them
2495    $unknown_st_handler = sub {
2496        my ($name, $target_list_ref, $status_list_ref) = @_;
2497        # ...
2498        return @paths_of_interest;
2499    };
2500    cm_check_unknown({st_check_handler => $unknown_st_handler}, @targets);
2501
2502    # Sets up a status checker
2503    $st_check_handler = sub {
2504        my ($name, $target_list_ref, $status_list_ref) = @_;
2505        # ...
2506    };
2507    # Switches a "working copy" at the "root" level to a new URL target
2508    cm_switch(
2509        {
2510            'non-interactive'  => $non_interactive_flag,
2511            'quiet'            => $quiet_flag,
2512            'revision'         => $revision,
2513            'st_check_handler' => $st_check_handler,
2514        },
2515        $target, $path_of_wc,
2516    );
2517    # Runs "svn update" on each working copy from their "root" level
2518    cm_update(
2519        {
2520            'non-interactive'  => $non_interactive_flag,
2521            'quiet'            => $quiet_flag,
2522            'revision'         => $revision,
2523            'st_check_handler' => $st_check_handler,
2524        },
2525        @targets,
2526    );
2527
2528=head1 DESCRIPTION
2529
2530Wraps the Subversion client and implements other FCM code management
2531functionalities.
2532
2533=head1 FUNCTIONS
2534
2535=over 4
2536
2537=item cli($function,@args)
2538
2539Implements the FCM code management CLI. If --help or -h is specified in @args,
2540it displays help and returns.  Otherwise, it attempts to expand any FCM location
2541and revision keywords in @args. Calls the relevant FCM code management function
2542according to $function, or a SVN command if $function is not modified by FCM.
2543
2544=item cm_check_missing(\%option,@targets)
2545
2546Use "svn status" to check for missing items in @targets. If @targets is an empty
2547list, the function adds the current working directory to it. Expects
2548$option{st_check_handler} to be a CODE reference. Calls
2549$option{st_check_handler} with ($name, $target_list_ref, $status_list_ref) where
2550$name is "delete", $target_list_ref is \@targets, and $status_list_ref is an
2551ARRAY reference to a list of "svn status" output with the "missing" status.
2552$option{st_check_handler} should return a list of interesting paths, which will
2553be scheduled for removal using "svn delete".
2554
2555=item cm_check_unknown(\%option,@targets)
2556
2557Similar to cm_check_missing(\%option,@targets) but checks for "unknown" items,
2558which will be scheduled for addition using "svn add".
2559
2560=item cm_switch(\%option,$target,$path_of_wc)
2561
2562Invokes "svn switch" at the root of a working copy specified by $path_of_wc (or
2563the current working directory if $path_of_wc is not specified).
2564$option{'non-interactive'}, $option{quiet}, $option{revision} determines the
2565options (of the same name) that are passed to "svn switch". If
2566$option{st_check_handler} is set, it should be a CODE reference, and will be
2567called with ('switch', [$path_of_wc], $status_list_ref), where $status_list_ref
2568is an ARRAY reference to the output returned by "svn status" on $path_of_wc.
2569This can be used for the application to display the working copy status to the
2570user before prompting him/her to continue. The return value of
2571$option{st_check_handler} is ignored.
2572
2573=item cm_update(\%option,@targets)
2574
2575Invokes "svn update" at the root of each working copy specified by @targets. If
2576@targets is an empty list, the function adds the current working directory to
2577it. $option{'non-interactive'}, $option{quiet}, $option{revision} determines the
2578options (of the same name) that are passed to "svn update". If
2579$option{st_check_handler} is set, it should be a CODE reference, and will be
2580called with ($name, $target_list_ref, $status_list_ref), where $name is
2581'update', $target_list_ref is \@targets and $status_list_ref is an ARRAY
2582reference to the output returned by "svn status -u" on the @targets. This can be
2583used for the application to display the working copy update status to the user
2584before prompting him/her to continue. The return value of
2585$option{st_check_handler} is ignored.
2586
2587=back
2588
2589=head1 DIAGNOSTICS
2590
2591The following exceptions can be raised:
2592
2593=over 4
2594
2595=item Fcm::Cm::Abort
2596
2597This exception @ISA L<Fcm::Exception|Fcm::Exception>. It is raised if a command
2598is aborted for some reason. The $e->get_code() method can be used to retrieve an
2599error code, which can be one of the following:
2600
2601=over 4
2602
2603=item $e->FAIL
2604
2605The command aborts because of a failure.
2606
2607=item $e->NULL
2608
2609The command aborts because it will result in no change.
2610
2611=item $e->USER
2612
2613The command aborts because of an action by the user.
2614
2615=back
2616
2617=item Fcm::Cm::Exception
2618
2619This exception @ISA L<Fcm::Abort|Fcm::Abort>. It is raised if a command fails
2620with a known reason. The $e->get_targets() method can be used to retrieve a list
2621of targets/resources associated with this exception. The $e->get_code() method
2622can be used to retrieve an error code, which can be one of the following:
2623
2624=over 4
2625
2626=item $e->CHDIR
2627
2628Fails to change directory to a target.
2629
2630=item $e->INVALID_BRANCH
2631
2632A target is not a valid branch URL in the standard FCM project layout.
2633
2634=item $e->INVALID_PROJECT
2635
2636A target is not a valid project URL in the standard FCM project layout.
2637
2638=item $e->INVALID_TARGET
2639
2640A target is not a valid Subversion URL or working copy.
2641
2642=item $e->INVALID_URL
2643
2644A target is not a valid Subversion URL.
2645
2646=item $e->INVALID_WC
2647
2648A target is not a valid Subversion working copy.
2649
2650=item $e->MERGE_REV_INVALID
2651
2652An invalid revision (target element 0) is specified for a merge.
2653
2654=item $e->MERGE_SELF
2655
2656Attempt to merge a URL (target element 0) to its own working copy (target
2657element 1).
2658
2659=item $e->MERGE_UNRELATED
2660
2661The merge target (target element 0) is not directly related to the merge source
2662(target element 1).
2663
2664=item $e->MERGE_UNSAFE
2665
2666A merge source (target element 0) contains changes outside the target
2667sub-directory.
2668
2669=item $e->MKPATH
2670
2671Fail to create a directory (target element 0) recursively.
2672
2673=item $e->NOT_EXIST
2674
2675A target does not exist.
2676
2677=item $e->PARENT_NOT_EXIST
2678
2679The parent of the target no longer exists.
2680
2681=item $e->RMTREE
2682
2683Fail to remove a directory (target element 0) recursively.
2684
2685=item $e->SWITCH_UNSAFE
2686
2687A merge template exists in the commit message file (target element 0) in a
2688working copy target.
2689
2690=item $e->WC_EXIST
2691
2692The target working copy already exists.
2693
2694=item $e->WC_INVALID_BRANCH
2695
2696The URL of the target working copy is not a valid branch URL in the standard FCM
2697project layout.
2698
2699=item $e->WC_URL_NOT_EXIST
2700
2701The URL of the target working copy no longer exists at the HEAD revision.
2702
2703=back
2704
2705=back
2706
2707=head1 TO DO
2708
2709Reintegrate with L<Fcm::CmUrl|Fcm::CmUrl> and L<Fcm::CmBranch|Fcm::CmBranch>,
2710but separate this module into the CLI part and the CM part. Expose the remaining
2711CM functions when this is done.
2712
2713Use L<SVN::Client|SVN::Client> to interface with Subversion.
2714
2715Move C<mkpatch> out of this module.
2716
2717=head1 COPYRIGHT
2718
2719E<169> Crown copyright Met Office. All rights reserved.
2720
2721=cut
Note: See TracBrowser for help on using the repository browser.