# ------------------------------------------------------------------------------ # NAME # Fcm::Cm # # DESCRIPTION # This module contains the FCM code management functionalities and wrappers # to Subversion commands. # # COPYRIGHT # (C) Crown copyright Met Office. All rights reserved. # For further details please refer to the file COPYRIGHT.txt # which you should have received as part of this distribution. # ------------------------------------------------------------------------------ use strict; use warnings; package Fcm::Cm; use base qw{Exporter}; our @EXPORT_OK = qw(cli cm_check_missing cm_check_unknown cm_switch cm_update); use Cwd qw{cwd}; use Getopt::Long qw{GetOptions :config bundling}; use Fcm::CLI::Exception; use Fcm::Config; use Fcm::CmBranch; use Fcm::CmUrl; use Fcm::Keyword; use Fcm::Util qw{ get_url_of_wc get_url_peg_of_wc get_wct is_url is_wc run_command tidy_url }; use File::Basename qw{basename dirname}; use File::Path qw{mkpath rmtree}; use File::Spec; use File::Temp qw{tempfile}; use Pod::Usage qw{pod2usage}; # ------------------------------------------------------------------------------ # CLI message handler our $CLI_MESSAGE = \&_cli_message; # List of CLI messages our %CLI_MESSAGE_FOR = ( q{} => "%s", BRANCH_LIST => "%s at %s: %d branch(es) found for %s.\n", CHDIR_WCT => "%s: working directory changed to top of working copy.\n", CF => "Conflicts in: %s\n", MERGE => "Performing merge ...\n", MERGE_CF => "About to merge in changes from %s compared with %s\n", MERGE_CI => "The following is added to the commit message file:\n%s", MERGE_DRY => "This merge will result in the following change:\n", MERGE_REVS => "Merge(s) available from %s: %s\n", OUT_DIR => "Output directory: %s\n", PATCH_DONE => "%s: patch generated.\n", PATCH_REV => "Patch created for changeset %s\n", SEPARATOR => q{-} x 80 . "\n", STATUS => "Status of the target working copy(ies):\n%s", ); # CLI abort and error messages our %CLI_MESSAGE_FOR_ABORT = ( FAIL => "%s: command failed.\n", NULL => "%s: command will result in no change.\n", USER => "%s: abort by user.\n", ); # CLI abort and error messages our %CLI_MESSAGE_FOR_ERROR = ( CHDIR => "%s: cannot change to directory.\n", CLI => "%s", CLI_HELP => "Type 'fcm help %s' for usage.\n", CLI_MERGE_ARG1 => "Arg 1 must be the source in auto/custom mode.\n", CLI_MERGE_ARG2 => "Arg 2 must be the source in custom mode" . " if --revision not set.\n", CLI_OPT_ARG => "--%s: invalid argument [%s].\n", CLI_OPT_WITH_OPT => "--%s: must be specified with --%s.\n", CLI_USAGE => "incorrect usage", DIFF_PROJECTS => "%s (target) and %s (source) are not related.\n", INVALID_BRANCH => "%s: not a valid URL of a standard FCM branch.\n", INVALID_PROJECT => "%s: not a valid URL of a standard FCM project.\n", INVALID_TARGET => "%s: not a valid working copy or URL.\n", INVALID_URL => "%s: not a valid URL.\n", INVALID_WC => "%s: not a valid working copy.\n", MERGE_REV_INVALID => "%s: not a revision in the available merge list.\n", MERGE_SELF => "%s: cannot be merged to its own working copy: %s.\n", MERGE_UNRELATED => "%s: target and %s: source not directly related.\n", MERGE_UNSAFE => "%s: source contains changes outside the target" . " sub-directory. Please merge with a full tree.\n", MKPATH => "%s: cannot create directory.\n", NOT_EXIST => "%s: does not exist.\n", PARENT_NOT_EXIST => "%s: parent %s no longer exists.\n", RMTREE => "%s: cannot remove.\n", ST_CONFLICT => "File(s) in conflicts:\n%s", ST_MISSING => "File(s) missing:\n%s", ST_OUT_OF_DATE => "File(s) out of date:\n%s", SWITCH_UNSAFE => "%s: merge template exists." . " Please remove before retrying.\n", WC_EXIST => "%s: working copy already exists.\n", WC_INVALID_BRANCH => "%s: not a working copy of a standard FCM branch.\n", WC_URL_NOT_EXIST => "%s: working copy URL does not exists at HEAD.\n", ); # List of CLI prompt messages our %CLI_MESSAGE_FOR_PROMPT = ( CF_OVERWRITE => qq{%s: existing changes will be overwritten.\n} . qq{ Do you wish to continue?}, CI => qq{Would you like to commit this change?}, CI_BRANCH_SHARED => qq{\n} . qq{*** WARNING: YOU ARE COMMITTING TO A %s BRANCH.\n} . qq{*** Please ensure that you have the} . qq{ owner's permission.\n\n} . qq{Would you like to commit this change?}, CI_BRANCH_USER => qq{\n} . qq{*** WARNING: YOU ARE COMMITTING TO A BRANCH} . qq{ NOT OWNED BY YOU.\n} . qq{*** Please ensure that you have the} . qq{ owner's permission.\n\n} . qq{Would you like to commit this change?}, CI_TRUNK => qq{\n} . qq{*** WARNING: YOU ARE COMMITTING TO THE TRUNK.\n} . qq{*** Please ensure that your change conforms to} . qq{ your project's working practices.\n\n} . qq{Would you like to commit this change?}, CONTINUE => qq{Are you sure you want to continue?}, MERGE => qq{Would you like to go ahead with the merge?}, MERGE_REV => qq{Please enter the revision you wish to merge from}, MKPATCH_OVERWRITE => qq{%s: output location exists. OK to overwrite?}, RUN_SVN_COMMAND => qq{Would you like to run "svn %s"?}, ); # List of CLI warning messages our %CLI_MESSAGE_FOR_WARNING = ( BRANCH_SUBDIR => "%s: is a sub-directory of a branch in a FCM project.\n", CF_BINARY => "%s: ignoring binary file, please resolve manually.\n", INVALID_BRANCH => $CLI_MESSAGE_FOR_ERROR{INVALID_BRANCH}, ST_IN_TRAC_DIFF => "%s: local changes cannot be displayed in Trac.\n" ); # CLI prompt handler and title prefix our $CLI_PROMPT = \&_cli_prompt; our $CLI_PROMPT_PREFIX = q{fcm }; # List of exception handlers [$class, CODE->($function, $e)] our @CLI_EXCEPTION_HANDLERS = ( ['Fcm::CLI::Exception', \&_cli_e_handler_of_cli_exception], ['Fcm::Cm::Exception' , \&_cli_e_handler_of_cm_exception], ['Fcm::Cm::Abort' , \&_cli_e_handler_of_cm_abort], ); # Event handlers our %CLI_HANDLER_OF = ( 'WC_STATUS' => \&_cli_handler_of_wc_status, 'WC_STATUS_PATH' => \&_cli_handler_of_wc_status_path, ); # Handlers of sub-commands our %CLI_IMPL_OF = ( 'add' => \&_cli_command_add, 'branch' => \&cm_branch, 'commit' => \&cm_commit, 'conflicts' => \&cm_conflicts, 'checkout' => \&_cli_command_checkout, 'delete' => \&_cli_command_delete, 'diff' => \&cm_diff, 'merge' => \&cm_merge, 'mkpatch' => \&cm_mkpatch, 'switch' => \&_cli_command_switch, 'update' => \&_cli_command_update, ); # List of overridden subcommands that need to display "svn help" our %CLI_MORE_HELP_FOR = map {($_, 1)} qw{add diff delete switch update}; # The preferred name of subcommand aliases our %CLI_PREFERRED_NAME_OF = ( 'ann' => 'blame', 'annotate' => 'blame', 'br' => 'branch', 'ci' => 'commit', 'cf' => 'conflicts', 'co' => 'checkout', 'cp' => 'copy', 'del' => 'delete', 'di' => 'diff', 'ls' => 'list', 'mv' => 'move', 'pd' => 'propdel', 'pdel' => 'propdel', 'pe' => 'propedit', 'pedit' => 'propedit', 'pg' => 'propget', 'pget' => 'propget', 'pl' => 'proplist', 'plist' => 'proplist', 'praise' => 'blame', 'ps' => 'propset', 'pset' => 'propset', 'remove' => 'delete', 'ren' => 'move', 'rename' => 'move', 'rm' => 'delete', 'sw' => 'switch', 'up' => 'update', ); # List of subcommands that accept URL inputs our %CLI_SUBCOMMAND_URL = map {($_, 1)} qw{ blame branch cat checkout copy delete diff export import info list lock log merge mkdir mkpatch move propdel propedit propget proplist propset switch unlock }; # List of subcommands that accept revision inputs our %CLI_SUBCOMMAND_REV = map {($_, 1)} qw{ blame branch cat checkout copy diff export info list log merge mkpatch move propdel propedit propget proplist propset switch }; # Common patterns our %PATTERN_OF = ( # A CLI option CLI_OPT => qr{ \A (?# beginning) (--\w[\w-]*=) (?# capture 1, a long option label) (.*) (?# capture 2, the value of the option) \z (?# end) }xms, # A CLI revision option CLI_OPT_REV => qr{ \A (?# beginning) (--revision(?:=|\z)|-r) (?# capture 1, --revision, --revision= or -r) (.*) (?# capture 2, trailing value) \z (?# end) }xms, # A CLI revision option range CLI_OPT_REV_RANGE => qr{ \A (?# beginning) ( (?# capture 1, begin) (?:\{[^\}]+\}+) (?# a date in curly braces) | (?# or) [^:]+ (?# anything but a colon) ) (?# capture 1, end) (?::(.*))? (?# colon, and capture 2 til the end) \z (?# end) }xms, # A FCM branch path look-alike, should be configurable in the future FCM_BRANCH_PATH => qr{ \A (?# beginning) /* (?# some slashes) (?: (?# group 1, begin) (?:trunk/*(?:@\d+)?\z) (?# trunk at a revision) | (?# or) (?:trunk|branches|tags)/+ (?# trunk, branch or tags) ) (?# group 1, end) }xms, # Last line of output from "svn status -u" ST_AGAINST_REV => qr{ \A (?# beginning) Status\sagainst\srevision:.* (?# output of svn status -u) \z (?# end) }xms, # Extract path from "svn status" ST_PATH => qr{ \A (?# beginning) .{6} (?# 6 columns) \s+ (?# spaces) (.+) (?# capture 1, target path) \z (?# end) }xms, # A legitimate "svn" revision SVN_REV => qr{ \A (?# beginning) (?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}) (?# digit, reserved words, date) \z (?# end) }ixms, ); # Status matchers our %ST_MATCHER_FOR = ( MISSING => sub {substr($_[0], 0, 1) eq '!'}, MODIFIED => sub {substr($_[0], 0, 6) =~ qr{\S}xms}, OUT_OF_DATE => sub {substr($_[0], 7, 1) eq '*'}, UNKNOWN => sub {substr($_[0], 0, 1) eq '?'}, ); # ------------------------------------------------------------------------------ # Entry function for the FCM code management CLI. Calls the relevant FCM code # management function or SVN command based on $function. sub cli { my ($function, @args) = @_; if (exists($CLI_PREFERRED_NAME_OF{$function})) { $function = $CLI_PREFERRED_NAME_OF{$function}; } if (grep {$_ eq '-h' || $_ eq '--help'} @args) { return _cli_help($function, 'NOEXIT'); } if (exists($CLI_SUBCOMMAND_URL{$function})) { _cli_keyword_expand_url(\@args); } if (exists($CLI_SUBCOMMAND_REV{$function})) { _cli_keyword_expand_rev(\@args); } if (exists($CLI_IMPL_OF{$function})) { eval { local(@ARGV) = @args; return $CLI_IMPL_OF{$function}->(@args); }; if ($@) { my $e = $@; for (@CLI_EXCEPTION_HANDLERS) { my ($class, $handler) = @{$_}; if ($class->caught($e)) { return $handler->($function, $e); } } die($e); } } else { return _svn($function, @args); } } # ------------------------------------------------------------------------------ # SYNOPSIS # &Fcm::Cm::cm_branch (); # # DESCRIPTION # This is a FCM command to check information, create or delete a branch in # a Subversion repository. # ------------------------------------------------------------------------------ sub cm_branch { # Process command line options # ---------------------------------------------------------------------------- my ( $info, $delete, $create, $list, $branch_of_branch, $name, $non_interactive, $password, $rev, $rev_flag, $show_all, $show_children, $show_other, $show_siblings, $svn_non_interactive, @tickets, $type, @userlist, $verbose, ); my $rc = GetOptions( 'info|i' => \$info, 'delete|d' => \$delete, 'create|c' => \$create, 'list|l' => \$list, 'branch-of-branch' => \$branch_of_branch, 'name|n=s' => \$name, 'non-interactive' => \$non_interactive, 'password=s' => \$password, 'revision|r=s' => \$rev, 'rev-flag=s' => \$rev_flag, 'show-all|a' => \$show_all, 'show-children' => \$show_children, 'show-other' => \$show_other, 'show-siblings' => \$show_siblings, 'svn-non-interactive' => \$svn_non_interactive, 'ticket|k=s' => \@tickets, 'type|t=s' => \$type, 'user|u=s' => \@userlist, 'verbose|v' => \$verbose, ); if (!$rc) { _cli_err(); } my $num_options = 0; $num_options++ if defined $info; $num_options++ if defined $delete; $num_options++ if defined $create; $num_options++ if defined $list; if ($num_options > 1) { _cli_err(); } # Get URL of repository or branch # ---------------------------------------------------------------------------- my $url; if ($ARGV[0]) { $url = Fcm::CmUrl->new (URL => $ARGV[0]); if (not $url->is_url) { # An argument is specified and is not a URL # Assume that it is a path with a working copy if (&is_wc ($ARGV[0])) { $url = Fcm::CmUrl->new (URL => &get_url_of_wc ($ARGV[0])); } else { return _cm_err(Fcm::Cm::Exception->INVALID_WC, $ARGV[0]); } } } else { # An argument is not specified # Assume that the current directory is a working copy if (&is_wc ()) { $url = Fcm::CmUrl->new (URL => &get_url_of_wc ()); } else { return _cm_err(Fcm::Cm::Exception->INVALID_TARGET, '.'); } } # Ensure $url->url_peg is a URL of a standard FCM project if (!$url->project_url()) { return _cm_err(Fcm::Cm::Exception->INVALID_PROJECT, $url->url_peg()); } if ($create) { # The --create option is specified, create a branch # -------------------------------------------------------------------------- # Check branch type flags if ($type) { $type = uc ($type); if ($type =~ /^(USER|SHARE)$/) { $type = 'DEV' . $Fcm::Config::DELIMITER . $1; } elsif ($type =~ /^(CONFIG|REL)$/) { $type = 'PKG' . $Fcm::Config::DELIMITER . $1; } elsif ($type =~ /^(DEV|TEST|PKG)$/) { $type = $1 . $Fcm::Config::DELIMITER . 'USER'; } elsif ($type !~ /^(?:DEV|TEST|PKG)$Fcm::Config::DELIMITER(?:USER|SHARE)$/ and $type !~ /^PKG$Fcm::Config::DELIMITER(?:CONFIG|REL)/) { _cli_err('CLI_OPT_ARG', 'type', $type); } } else { $type = 'DEV' . $Fcm::Config::DELIMITER . 'USER'; } # Check branch name if (!$name) { _cli_err('CLI_OPT_WITH_OPT', 'name', 'create'); } if ($name !~ qr{\A[\w.-]+\z}xms) { _cli_err('CLI_OPT_ARG', 'name', $name); } # Check revision flag is valid if ($rev_flag) { $rev_flag = uc ($rev_flag); if ($rev_flag !~ qr{\A (?:NORMAL|NUMBER|NONE) \z}xms) { _cli_err('CLI_OPT_ARG', 'rev-flag', $rev_flag); } } else { $rev_flag = 'NORMAL'; } # Handle multiple tickets @tickets = split ( /$Fcm::Config::DELIMITER_LIST/, join ($Fcm::Config::DELIMITER_LIST, @tickets) ); s/^#// for (@tickets); @tickets = sort {$a <=> $b} @tickets; # Determine whether to create a branch of a branch $url->branch ('trunk') unless $branch_of_branch; # Create the branch my $branch = Fcm::CmBranch->new; $branch->create ( SRC => $url, TYPE => $type, NAME => $name, PASSWORD => $password, REV_FLAG => $rev_flag, TICKET => \@tickets, REV => $rev, NON_INTERACTIVE => $non_interactive, SVN_NON_INTERACTIVE => $svn_non_interactive, ); } elsif ($list) { # The option --list is specified # List branches owned by current or specified users # -------------------------------------------------------------------------- # Get URL of the project "branches/" sub-directory $url->subdir (''); $url->branch (''); my @branches = $url->branch_list($rev); if (!$show_all) { @userlist = split(qr{:}xms, join(q{:}, @userlist)); if (!@userlist) { @userlist = (Fcm::Config->instance()->user_id()); } my %filter = map {($_, 1)} @userlist; @branches = grep { $filter{Fcm::CmBranch->new(URL => $_)->branch_owner()} } @branches } # Output, number of branches found $CLI_MESSAGE->( 'BRANCH_LIST', $url->project_url_peg(), $rev ? "r$rev" : 'HEAD', scalar(@branches), ($show_all ? '[--show-all]' : join(q{, }, sort(@userlist))), ); if (@branches) { # Output the URL of each branch if (not $verbose) { my $project = $url->project_url; @branches = map {Fcm::Keyword::unexpand($_)} @branches; } @branches = map {$_ . "\n"} sort @branches; $CLI_MESSAGE->(q{}, join(q{}, @branches)); } else { # No branch found, exit with an error code return; } } else { # The option --info or --delete is specified # Report branch information (and/or delete a branch) # -------------------------------------------------------------------------- # Set verbose level Fcm::Config->instance()->verbose ($verbose ? 1 : 0); # Set up the branch, report any error my $branch = Fcm::CmBranch->new (URL => $url->url_peg); if (!$branch->branch()) { return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $branch->url_peg()); } if (!$branch->url_exists()) { return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $branch->url_peg()); } # Remove the sub-directory part of the URL $branch->subdir (''); # Report branch info $branch->display_info ( SHOW_CHILDREN => ($show_all || $show_children), SHOW_OTHER => ($show_all || $show_other ), SHOW_SIBLINGS => ($show_all || $show_siblings), ); # Delete branch if --delete is specified $branch->del ( PASSWORD => $password, NON_INTERACTIVE => $non_interactive, SVN_NON_INTERACTIVE => $svn_non_interactive, ) if $delete; } } # ------------------------------------------------------------------------------ # SYNOPSIS # &Fcm::Cm::cm_commit (); # # DESCRIPTION # This is a FCM wrapper to the "svn commit" command. # ------------------------------------------------------------------------------ sub cm_commit { my ($dry_run, $svn_non_interactive, $password); my $rc = GetOptions( 'dry-run' => \$dry_run, 'svn-non-interactive' => \$svn_non_interactive, 'password=s' => \$password, ); if (!$rc) { _cli_err(); } # The remaining argument is the path to a working copy my ($path) = @ARGV; if ($path) { if (!-e $path) { return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path); } } else { # No argument specified, use current working directory $path = cwd (); } # Make sure we are in a working copy if (!is_wc($path)) { return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); } # Make sure we are at the top level of the working copy # (otherwise we might miss any template commit message) my $dir = &get_wct ($path); if ($dir ne cwd ()) { chdir($dir) || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir); $CLI_MESSAGE->('CHDIR_WCT', $dir); } # Get update status of working copy # Check working copy files are not in conflict, missing, or out of date my @status = _svn_status_get([], 1); unless (defined $dry_run) { my (@conflict, @missing, @outdate); for (@status) { if (/^C/) { push @conflict, $_; next; } if (/^!/) { push @missing, $_; next; } if (/^.{7}\*/) { push @outdate, $_; next; } # Check that all files which have been added have the svn:executable # property set correctly (in case the developer adds a script before they # remember to set the execute bit) next unless /^A.{7} *\d+ +(.*)/; my $file = $1; next unless -f $file; my ($command, @arguments) = (-x $file && !-l $file) ? ('propset', '*') : ('propdel'); run_command(['svn', $command, qw{-q svn:executable}, @arguments, $file]); } # Abort commit if files are in conflict, missing, or out of date if (@conflict or @missing or @outdate) { for ( ['ST_CONFLICT' , \@conflict], ['ST_MISSING' , \@missing ], ['ST_OUT_OF_DATE', \@outdate ], ) { my ($key, $array_ref) = @{$_}; if (@{$array_ref}) { $CLI_MESSAGE->($key, join(q{}, @{$array_ref})); } } return _cm_abort(Fcm::Cm::Abort->FAIL); } } # Read in any existing message my $ci_mesg = Fcm::CmCommitMessage->new; $ci_mesg->read_file; # Execute "svn status" for a list of changed items @status = grep !/^\?/, _svn_status_get(); # Abort if there is no change in the working copy if (!@status) { return _cm_abort(Fcm::Cm::Abort->NULL); } # Get associated URL of current working copy my $url = Fcm::CmUrl->new (URL => &get_url_of_wc ()); # Include URL, or project, branch and sub-directory info in @status unshift @status, "\n"; if ($url->project and $url->branch) { unshift @status, ( '[Project: ' . $url->project . ']' . "\n", '[Branch : ' . $url->branch . ']' . "\n", '[Sub-dir: ' . ($url->subdir ? $url->subdir : '') . ']' . "\n", ); } else { unshift @status, '[URL: ' . $url->url . ']' . "\n"; } # Use a temporary file to store the final commit log message $ci_mesg->ignore_mesg (\@status); my $logfile = $ci_mesg->edit_file (TEMP => 1); # Check with the user to see if he/she wants to go ahead my $reply = 'n'; if (!defined($dry_run)) { # Add extra warning for trunk commit my @prompt_args; my $user = Fcm::Config->instance()->user_id(); if ($url->is_trunk()) { @prompt_args = ('CI_TRUNK'); } elsif ($user && $url->is_branch() && $url->branch_owner() ne $user) { if (exists $Fcm::CmUrl::owner_keywords{$url->branch_owner}) { @prompt_args = ( 'CI_BRANCH_SHARED', uc($Fcm::CmUrl::owner_keywords{$url->branch_owner()}), ); } else { @prompt_args = ('CI_BRANCH_USER'); } } else { @prompt_args = ('CI'); } $reply = $CLI_PROMPT->('commit', @prompt_args); } if ($reply eq 'y') { # Commit the change if user replies "y" for "yes" my @command = ( qw/svn commit -F/, $logfile, ($svn_non_interactive ? '--non-interactive' : ()), (defined $password ? ('--password', $password) : ()), ); my $rc; &run_command (\@command, RC => \$rc, ERROR => 'warn'); if ($rc) { # Commit failed # Write temporary commit log content to commit log message file $ci_mesg->write_file; # Fail the command return _cm_abort(Fcm::Cm::Abort->FAIL); } # Remove commit message file unlink $ci_mesg->file; # Update the working copy $CLI_MESSAGE->(q{}, join(q{}, _svn_update())); } else { $ci_mesg->write_file; if (!$dry_run) { return _cm_abort(); } } return; } # ------------------------------------------------------------------------------ # SYNOPSIS # &Fcm::Cm::cm_conflicts (); # # DESCRIPTION # This is a FCM command for resolving conflicts within working copy using a # graphical merge tool. # ------------------------------------------------------------------------------ sub cm_conflicts { # Path to the working copy my $path = $ARGV[0]; $path = cwd () if not $path; # Check for any files with conflicts my @status = grep /^C.{4} *(.*)/, &run_command ( [qw/svn st/, ($path eq cwd () ? () : $path)], METHOD => 'qx', ); my @files = map {m/^C.{4} *(.*)/; $1} @status; # Save current working directory my $topdir = cwd (); # Set up environment for graphical merge # Use environment variable if set, otherwise use default setting local(%ENV) = %ENV; $ENV{FCM_GRAPHIC_MERGE} ||= Fcm::Config->instance()->setting (qw/TOOL GRAPHIC_MERGE/); FILE: for my $file (@files) { # Print name of file in conflicts $CLI_MESSAGE->('CF', $file); # Determine directory and base name of file in conflicts my $base = basename $file; my $dir = dirname $file; # Change to container directory of file in conflicts chdir(File::Spec->catfile($topdir, $dir)) || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir); # Use "svn info" to determine conflict marker files my @info = &run_command ([qw/svn info/, $base], METHOD => 'qx'); # Ignore if $base is a binary file if (-B $base) { $CLI_MESSAGE->('CF_BINARY', $base); next FILE; } # Get conflicts markers files my ($older, $mine, $yours); for (@info) { $older = $1 if (/^Conflict Previous Base File: (.*)/); $mine = $1 if (/^Conflict Previous Working File: (.*)/); $yours = $1 if (/^Conflict Current Base File: (.*)/); } if (-f $base and (stat $base)[9] > (stat $mine)[9] + 1) { # If $base is newer (by more than a second), it may contain saved changes if ($CLI_PROMPT->('conflicts', 'CF_OVERWRITE', $base) ne 'y') { next FILE; } } # Launch graphic merge tool my $rc; my $command = [qw/fcm_graphic_merge/, $base, $mine, $older, $yours]; # $rc == 0: all conflicts resovled # $rc == 1: some conflicts not resolved # $rc == 2: trouble eval { run_command($command, RC => \$rc); }; if ($@) { if (!defined($rc) || $rc > 1) { die($@); } } next FILE if $rc; # Prompt user to run "svn resolved" on the file if ($CLI_PROMPT->('conflicts', 'RUN_SVN_COMMAND', 'resolved') eq 'y') { run_command([qw{svn resolved}, $base]); } } } # ------------------------------------------------------------------------------ # SYNOPSIS # &Fcm::Cm::cm_diff (); # # DESCRIPTION # This is a wrapper to "svn diff". It adds two extra functionalities. The # first one allows the command to show differences relative to the base of # the branch. The second one allows differences to be displayed via a # graphical tool. # ------------------------------------------------------------------------------ sub cm_diff { # Set up environment for graphical diff # Use environment variable if set, otherwise use default setting local(%ENV) = %ENV; $ENV{FCM_GRAPHIC_DIFF} ||= Fcm::Config->instance()->setting(qw/TOOL GRAPHIC_DIFF/); # Check for the --branch options # ---------------------------------------------------------------------------- my $branch = grep {$_ eq '-b' or $_ eq '--branch'} @ARGV; if (not $branch) { # The --branch option not specified, just call "svn diff" # Convert the --graphical to qw/--diff-cmd fcm_graphical_diff/ # Convert the --summarise to --summarize @ARGV = map { my @return; if ($_ eq '-g' or $_ eq '--graphical') { @return = (qw/--diff-cmd fcm_graphic_diff/) } elsif ($_ eq '--summarise') { @return = ('--summarize'); } else { @return = ($_); } @return; } @ARGV; # Execute the command return _svn('diff', @ARGV); } # The --branch option is specified # ---------------------------------------------------------------------------- # Determine whether the --graphical option is specified, # if so set the appropriate command # ---------------------------------------------------------------------------- my ($diff_cmd, $extensions, $graphical, $summarise, $trac, $wiki); my $rc = GetOptions ( 'b|branch' => \$branch, 'diff-cmd=s' => \$diff_cmd, 'x|extensions=s' => \$extensions, 'g|graphical' => \$graphical, 'summarise|summarize' => \$summarise, 't|trac' => \$trac, 'wiki' => \$wiki, ); if (!$rc) { _cli_err(); } my @diff_cmd = (); if ($graphical) { @diff_cmd = (qw/--diff-cmd fcm_graphic_diff/); } elsif ($diff_cmd) { @diff_cmd = ('--diff-cmd', $diff_cmd); push @diff_cmd, '--extensions', split (/\s+/, $extensions) if $extensions; } # The remaining argument should either be a URL or a PATH my ($url_arg, $path_arg); if (@ARGV) { my $arg = Fcm::CmUrl->new (URL => $ARGV[0]); if ($arg->is_url) { $url_arg = $ARGV[0]; } else { $path_arg = $ARGV[0]; } } # Get repository and branch information # ---------------------------------------------------------------------------- my ($url, $path); if (defined $url_arg) { # If a URL is specified, get repository and branch information from it $url = Fcm::CmBranch->new (URL => $url_arg); } else { # Get repository and branch information from the specified path or the # current directory if it is a working copy $path = $path_arg ? $path_arg : cwd (); if (!is_wc($path)) { return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); } $url = Fcm::CmBranch->new (URL => &get_url_peg_of_wc ($path)); } # Check that URL is a standard FCM branch if (!$url->is_branch()) { return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $url->url_peg()); } # Save and remove sub-directory part of the URL my $subdir = $url->subdir (); $url->subdir (''); # Check that $url exists if (!$url->url_exists()) { return _cm_err(Fcm::Cm::Exception->INVALID_URL, $url->url_peg()); } # Compare current branch with its parent # ---------------------------------------------------------------------------- my $parent = Fcm::CmBranch->new (URL => $url->parent->url); $parent->pegrev ($url->pegrev) if $url->pegrev; if (!$parent->url_exists()) { return _cm_err( Fcm::Cm::Exception->PARENT_NOT_EXIST, $url->url_peg(), $parent->url(), ); } my $base = $parent->base_of_merge_from ($url); # Ensure the correct diff (syntax) is displayed # ---------------------------------------------------------------------------- # Reinstate the sub-tree part into the URL $url->subdir ($subdir); $base->subdir ($subdir); # Ensure the branch URL has a peg revision $url->pegrev ($url->svninfo (FLAG => 'Last Changed Rev')) if not $url->pegrev; if ($trac or $wiki) { # Trac/wiki # -------------------------------------------------------------------------- if (!$url_arg && _svn_status_get([$path_arg ? $path_arg : q{.}])) { $CLI_MESSAGE->('ST_IN_TRAC_DIFF', ($path_arg ? $path_arg : q{.})); } # Trac wiki syntax my $wiki_syntax = 'diff:' . $base->path_peg . '//' . $url->path_peg; if ($wiki) { # Print Trac wiki syntax only $CLI_MESSAGE->(q{}, "$wiki_syntax\n"); } else { # if $trac # Use Trac to view "diff" my $browser = Fcm::Config->instance()->setting(qw/WEB_BROWSER/); $browser ||= 'firefox'; my $trac_url = Fcm::Keyword::get_browser_url($url->project_url()); $trac_url =~ s{/intertrac/.*$}{/intertrac/$wiki_syntax}xms; &run_command ([$browser, $trac_url], METHOD => 'exec', PRINT => 1); } } else { # Execute the "diff" command # -------------------------------------------------------------------------- my @command = ( qw/svn diff/, @diff_cmd, ($summarise ? ('--summarize') : ()), '--old', $base->url_peg, '--new', ($url_arg ? $url->url_peg : ($path_arg ? $path_arg : '.')), ); &run_command (\@command, PRINT => 1); } } # ------------------------------------------------------------------------------ # SYNOPSIS # &Fcm::Cm::cm_merge (); # # DESCRIPTION # This is a wrapper to "svn merge". # ------------------------------------------------------------------------------ sub cm_merge { # Options # ---------------------------------------------------------------------------- my ($custom, $dry_run, $non_interactive, $reverse, $rev, $verbose); my $rc = GetOptions( 'custom' => \$custom, 'dry-run' => \$dry_run, 'non-interactive' => \$non_interactive, 'reverse' => \$reverse, 'revision|r=s' => \$rev, 'verbose|v' => \$verbose, ); if (!$rc) { _cli_err(); } # Find out the URL of the working copy # ---------------------------------------------------------------------------- my ($target, $wct); if (&is_wc ()) { $wct = &get_wct (); if ($wct ne cwd ()) { chdir($wct) || return _cm_err(Fcm::Cm::Exception->CHDIR, $wct); $CLI_MESSAGE->('CHDIR_WCT', $wct); } $target = Fcm::CmBranch->new (URL => &get_url_of_wc ($wct)); } else { return _cm_err(Fcm::Cm::Exception->INVALID_WC, '.'); } if (!$target->url_exists()) { return _cm_err(Fcm::Cm::Exception->WC_URL_NOT_EXIST, '.'); } # The target must be at the top of a branch # $subdir will be used later to determine whether the merge is allowed or not my $subdir = $target->subdir; $target->subdir ('') if $subdir; # Check for any local modifications # ---------------------------------------------------------------------------- if (!$dry_run && !$non_interactive) { _svn_status_checker('merge', 'MODIFIED', $CLI_HANDLER_OF{WC_STATUS})->(); } # Determine the SOURCE URL # ---------------------------------------------------------------------------- my $source; if ($reverse) { # Reverse merge, the SOURCE is the the working copy URL $source = Fcm::CmBranch->new (URL => $target->url); } else { # Automatic/custom merge, argument 1 is the SOURCE of the merge my $source_url = shift (@ARGV); if (!$source_url) { _cli_err('CLI_MERGE_ARG1'); } $source = _cm_get_source($source_url, $target); } # Parse the revision option # ---------------------------------------------------------------------------- if ($reverse && !$rev) { _cli_err('CLI_OPT_WITH_OPT', 'revision', 'reverse'); } my @revs = (($reverse || $custom) && $rev ? split(qr{:}xms, $rev) : ()); # Determine the merge delta and the commit log message # ---------------------------------------------------------------------------- my (@delta, $mesg); my $separator = '-' x 80 . "\n"; if ($reverse) { # Reverse merge # -------------------------------------------------------------------------- if (@revs == 1) { $revs[1] = ($revs[0] - 1); } else { @revs = sort {$b <=> $a} @revs; } $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) unless $source->pegrev; $source->subdir ($subdir); # "Delta" of the "svn merge" command @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg); # Template message $mesg = 'Reversed r' . $revs[0] . (($revs[1] < $revs[0] - 1) ? ':' . $revs[1] : '') . ' of ' . $source->path . "\n"; } elsif ($custom) { # Custom merge # -------------------------------------------------------------------------- if (@revs) { # Revision specified # ------------------------------------------------------------------------ # Only one revision N specified, use (N - 1):N as the delta unshift @revs, ($revs[0] - 1) if @revs == 1; $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) unless $source->pegrev; $source->subdir ($subdir); $target->subdir ($subdir); # "Delta" of the "svn merge" command @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg); # Template message $mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] . ' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n"; } else { # Revision not specified # ------------------------------------------------------------------------ # Get second source URL my $source2_url = shift (@ARGV); if (!$source2_url) { _cli_err('CLI_MERGE_ARG2'); } my $source2 = _cm_get_source($source2_url, $target); $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) unless $source->pegrev; $source2->pegrev ($source2->svninfo (FLAG => 'Last Changed Rev')) unless $source2->pegrev; $source->subdir ($subdir); $source2->subdir ($subdir); $target->subdir ($subdir); # "Delta" of the "svn merge" command @delta = ($source->url_peg, $source2->url_peg); # Template message $mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg . ' cf. ' . $source2->path_peg . "\n"; } } else { # Automatic merge # -------------------------------------------------------------------------- # Check to ensure source branch is not the same as the target branch if (!$target->branch()) { return _cm_err(Fcm::Cm::Exception->WC_INVALID_BRANCH, $wct); } if ($source->branch() eq $target->branch()) { return _cm_err(Fcm::Cm::Exception->MERGE_SELF, $target->url_peg(), $wct); } # Only allow the merge if the source and target are "directly related" # -------------------------------------------------------------------------- my $anc = $target->ancestor ($source); return _cm_err( Fcm::Cm::Exception->MERGE_UNRELATED, $target->url_peg(), $source->url_peg ) unless ($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg) or ($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg) or ($anc->url eq $source->parent->url and $anc->url eq $target->parent->url); # Check for available merges from the source # -------------------------------------------------------------------------- my @revs = $target->avail_merge_from ($source, 1); if (@revs) { if ($verbose) { # Verbose mode, print log messages of available merges $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), q{}); for (@revs) { $CLI_MESSAGE->('SEPARATOR'); $CLI_MESSAGE->(q{}, $source->display_svnlog($_)); } $CLI_MESSAGE->('SEPARATOR'); } else { # Normal mode, list revisions of available merges $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), join(q{ }, @revs)); } } else { return _cm_abort(Fcm::Cm::Abort->NULL); } # If more than one merge available, prompt user to enter a revision number # to merge from, default to $revs [0] # -------------------------------------------------------------------------- if ($non_interactive || @revs == 1) { $source->pegrev($revs[0]); } else { my $reply = $CLI_PROMPT->( {type => q{}, default => $revs[0]}, 'merge', 'MERGE_REV', ); if (!defined($reply)) { return _cm_abort(); } # Expand revision keyword if necessary if ($reply) { $reply = (Fcm::Keyword::expand($target->project_url(), $reply))[1]; } # Check that the reply is a number in the available merges list if (!grep {$_ eq $reply} @revs) { return _cm_err(Fcm::Cm::Exception->MERGE_REV_INVALID, $reply) } $source->pegrev($reply); } # If the working copy top is pointing to a sub-directory of a branch, # we need to check whether the merge will result in losing changes made in # other sub-directories of the source. if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) { return _cm_err(Fcm::Cm::Exception->MERGE_UNSAFE, $source->url_peg()); } # Calculate the base of the merge my $base = $target->base_of_merge_from ($source); # $source and $base must take into account the sub-directory my $s = Fcm::CmBranch->new (URL => $source->url_peg); my $b = Fcm::CmBranch->new (URL => $base->url_peg); $s->subdir ($subdir) if $subdir; $b->subdir ($subdir) if $subdir; # Diagnostic $CLI_MESSAGE->('MERGE_CF', $s->path_peg(), $b->path_peg()); # Delta of the "svn merge" command @delta = ($b->url_peg, $s->url_peg); # Template message $mesg = 'Merged into ' . $target->path . ': ' . $source->path_peg . ' cf. ' . $base->path_peg . "\n"; } # Run "svn merge" in "--dry-run" mode to see the result # ---------------------------------------------------------------------------- my @out = &run_command ( [qw/svn merge --dry-run/, @delta], METHOD => 'qx', PRINT => ($dry_run and $verbose), ); # Abort merge if it will result in no change if (not @out) { return _cm_abort(Fcm::Cm::Abort->NULL); } # Report result of "svn merge --dry-run" if ($dry_run || !$non_interactive) { $CLI_MESSAGE->('MERGE_DRY'); $CLI_MESSAGE->('SEPARATOR'); $CLI_MESSAGE->(q{}, join(q{}, @out)); $CLI_MESSAGE->('SEPARATOR'); } return if $dry_run; # Prompt the user to see if (s)he would like to go ahead # ---------------------------------------------------------------------------- # Go ahead with merge only if user replies "y" if (!$non_interactive && $CLI_PROMPT->('merge', 'MERGE') ne 'y') { return _cm_abort(); } $CLI_MESSAGE->('MERGE'); run_command([qw/svn merge/, @delta], PRINT => $verbose); # Prepare the commit log # ---------------------------------------------------------------------------- # Read in any existing message my $ci_mesg = Fcm::CmCommitMessage->new; $ci_mesg->read_file; $ci_mesg->auto_mesg ([$mesg, @{ $ci_mesg->auto_mesg }]); $ci_mesg->write_file; if ($verbose) { $CLI_MESSAGE->('SEPARATOR'); $CLI_MESSAGE->('MERGE_CI', $mesg); } return; } # ------------------------------------------------------------------------------ # SYNOPSIS # &Fcm::Cm::cm_mkpatch (); # # DESCRIPTION # This is a FCM command to create a patching script from particular revisions # of a URL. # ------------------------------------------------------------------------------ sub cm_mkpatch { # Process command line options and arguments # ---------------------------------------------------------------------------- my (@exclude, $organisation, $revision); my $rc = GetOptions( 'exclude=s' => \@exclude, 'organisation=s' => \$organisation, 'r|revision=s' => \$revision, ); if (!$rc) { _cli_err(); } # Excluded paths, convert glob into regular patterns @exclude = split (/:/, join (':', @exclude)); for (@exclude) { s#\*#[^/]*#; # match any number of non-slash character s#\?#[^/]#; # match a non-slash character s#/*$##; # remove trailing slash } # Organisation prefix $organisation = $organisation ? $organisation : 'original'; # Make sure revision option is set correctly my @revs = $revision ? split (/:/, $revision) : (); @revs = @revs [0, 1] if @revs > 2; # Arguments my ($u, $outdir) = @ARGV; if (!$u) { _cli_err(); } my $url = Fcm::CmUrl->new (URL => $u); if (!$url->is_url()) { return _cm_err(Fcm::Cm::Exception->INVALID_URL, $u); } if (!$url->url_exists()) { return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $u); } if (!$url->branch()) { $CLI_MESSAGE->('INVALID_BRANCH', $u); } elsif ($url->subdir()) { $CLI_MESSAGE->('BRANCH_SUBDIR', $u); } if (@revs) { # If HEAD revision is given, convert it into a number # -------------------------------------------------------------------------- for my $rev (@revs) { $rev = $url->svninfo (FLAG => 'Revision') if uc ($rev) eq 'HEAD'; } } else { # If no revision is given, use the HEAD # -------------------------------------------------------------------------- $revs[0] = $url->svninfo (FLAG => 'Revision'); } $revs[1] = $revs[0] if @revs == 1; # Check that output directory is set # ---------------------------------------------------------------------------- $outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir; if (-e $outdir) { # Ask user to confirm removal of old output directory if it exists if ($CLI_PROMPT->('mkpatch', 'MKPATCH_OVERWRITE') ne 'y') { return _cm_abort(); } rmtree($outdir) || return _cm_err(Fcm::Cm::Exception->RMTREE, $outdir); } # (Re-)create output directory mkpath($outdir) || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir); $CLI_MESSAGE->('OUT_DIR', $outdir); # Get and process log of URL # ---------------------------------------------------------------------------- my @script = (); # main output script my %log = $url->svnlog (REV => \@revs); my $url_path = $url->path; for my $rev (sort {$a <=> $b} keys %log) { # Look at the changed paths for each revision my $use_patch = 1; # OK to use a patch file? my @paths; PATH: for my $path (sort keys %{ $log{$rev}{paths} }) { my $file = $path; # Skip paths outside of the branch next PATH unless $file =~ s#^$url_path/*##; # Skip excluded paths for my $exclude (@exclude) { if ($file =~ m#^$exclude(?:/*|$)#) { # Can't use a patch file if any files have been excluded $use_patch = 0; next PATH; } } # Can't use a patch file if any files have been added or replaced $use_patch = 0 if $log{$rev}{paths}{$path}{action} eq 'A' or $log{$rev}{paths}{$path}{action} eq 'R'; push @paths, $path; } # If a patch is being used, make sure it isn't just property changes if ($use_patch) { my @changedpaths; for my $path (@paths) { (my $file = $path) =~ s#^$url_path/*##; if ($log{$rev}{paths}{$path}{action} eq 'M') { my ($diff) = &run_command ( [qw/svn diff --no-diff-deleted --summarize -c/, $rev, $url->url . '/' . $file. '@' . $rev], METHOD => 'qx'); next unless $diff =~ /^[A-Z]/; } push @changedpaths, $path; } @paths = @changedpaths; } next unless @paths; # Create the patch using "svn diff" my @patch = (); if ($use_patch) { @patch = &run_command ([qw/svn diff --no-diff-deleted -c/, $rev, $url->url], METHOD => 'qx'); if (@patch) { # Don't use the patch if it may contain subversion keywords for (@patch) { $use_patch = 0 if /\$[a-zA-Z:]+ *\$/; } } else { $use_patch = 0; } } # Create a directory for this revision in the output directory my $outdir_rev = File::Spec->catfile ($outdir, $rev); mkpath($outdir_rev) || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir_rev); # Parse commit log message my @msg = split /\n/, $log{$rev}{msg}; for (@msg) { # Re-instate line break $_ .= "\n"; # Remove line if it matches a merge template $_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/; $_ = '' if /^Custom merge into \S+:.+$/; $_ = '' if /^Merged into \S+: \S+ cf\. \S+$/; # Modify Trac ticket link s/(?:#|ticket:)(\d+)/${organisation}_ticket:$1/g; # Modify Trac changeset link s/(?:r|changeset:)(\d+)/${organisation}_changeset:$1/g; s/\[(\d+)\]/${organisation}_changeset:$1/g; } push @msg, '(' . $organisation . '_changeset:' . $rev . ')' . "\n"; # Write commit log message in a file my $f_revlog = File::Spec->catfile ($outdir_rev, 'log-message'); open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')'; print FILE @msg; close FILE or die $f_revlog, ': cannot close (', $!, ')'; # Handle each changed path my $export_file = 1; # name for next exported file (gets incremented) my $patch_needed = 0; # is a patch file required? my @before_script = (); # patch script to run before patch applied my @after_script = (); # patch script to run after patch applied my @copied_dirs = (); # copied directories CHANGED: for my $path (@paths) { (my $file = $path) =~ s#^$url_path/*##; my $url_file = $url->url . '/' . $file . '@' . $rev; # Skip paths within copied directories for my $copied_dir (@copied_dirs) { next CHANGED if $file =~ m#^$copied_dir(?:/*|$)#; } if ($log{$rev}{paths}{$path}{action} eq 'D') { # Script to delete file push @after_script, 'svn delete ' . $file; } else { my $export_required = 0; my $recursive_add = 0; my $is_newfile = 0; # Skip property changes if ($log{$rev}{paths}{$path}{action} eq 'M') { my ($diff) = &run_command ( [qw/svn diff --no-diff-deleted --summarize -c/, $rev, $url->url . '/' . $file. '@' . $rev], METHOD => 'qx'); next CHANGED unless $diff =~ /^[A-Z]/; } # Determine if the file is a directory my $is_dir = 0; if ($log{$rev}{paths}{$path}{action} ne 'M') { my @info = &run_command ([qw/svn info/, $url_file], METHOD => 'qx'); for (@info) { if (/^Node Kind: (\w+)/) { $is_dir = 1 if $1 eq 'directory'; last; } } } # Decide how to treat added files if ($log{$rev}{paths}{$path}{action} eq 'A') { # Determine if the file is copied if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) { if ($is_dir) { # A copied directory needs to be treated as a new file, exported # and added recursively $is_newfile = 1; $export_required = 1; $recursive_add = 1; push @copied_dirs, $file; } else { # History exists for this file my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'}; my $copyfrom_rev = $log{$rev}{paths}{$path}{'copyfrom-rev'}; my $cp_url = Fcm::CmUrl->new ( URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev, ); if ($copyfrom_path =~ s#^$url_path/*##) { # File is copied from a file under the specified URL # Check source exists $is_newfile = 1 unless $cp_url->url_exists ($rev - 1); } else { # File copied from outside of the specified URL $is_newfile = 1; # Check branches can be determined if ($url->branch and $cp_url->branch) { # Follow its history, stop on copy my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1); # "First" revision of the copied file my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0]; my %attrib = %{ $cp_log{$cp_rev}{paths}{$cp_url->path} } if $cp_log{$cp_rev}{paths}{$cp_url->path}; # Check whether the "first" revision is copied from elsewhere. if (exists $attrib{'copyfrom-path'}) { # If source exists in the specified URL, set up the copy my $cp_cp_url = Fcm::CmUrl->new ( URL => $url->root . $attrib{'copyfrom-path'} . '@' . $attrib{'copyfrom-rev'}, ); $cp_cp_url->branch ($url->branch); if ($cp_cp_url->url_exists ($rev - 1)) { ($copyfrom_path = $cp_cp_url->path) =~ s#^$url_path/*##; # Check path is defined - if not it probably means the # branch doesn't follow the FCM naming convention $is_newfile = 0 if $copyfrom_path; } } # Note: The logic above does not cover all cases. However, it # should do the right thing for the most common case. Even # where it gets it wrong the file contents should always be # correct even if the file history is not. } } # Check whether file is copied from an excluded path if (not $is_newfile) { for my $exclude (@exclude) { if ($copyfrom_path =~ m#^$exclude(?:/*|$)#) { $is_newfile = 1; last; } } } # Script to copy file, if required push @before_script, 'svn copy ' . $copyfrom_path . ' ' . $file if not $is_newfile; } } else { # History does not exist, must be a new file $is_newfile = 1; # If it's a directory then create it (in case patch doesn't) push @before_script, 'mkdir ' . $file if $is_dir; } } if ($log{$rev}{paths}{$path}{action} eq 'R') { # Script to delete file push @before_script, 'svn delete ' . $file; # Now treat as new file $is_newfile = 1; } # Script to add the file, if required if ($is_newfile) { if ($recursive_add) { push @after_script, 'svn add ' . $file; } else { push @after_script, 'svn add --non-recursive ' . $file; } } # Decide whether the file needs to be exported if (not $is_dir) { if (not $use_patch) { $export_required = 1; } else { # Export the file if it is binary my @mime_type = &run_command ([qw/svn propget svn:mime-type/, $url_file], METHOD => 'qx'); for (@mime_type) { $export_required = 1 if not /^text\//; } # Only create a patch file if necessary $patch_needed = 1 if not $export_required; } } if ($export_required) { # Download the file using "svn export" my $export = File::Spec->catfile ($outdir_rev, $export_file); &run_command ([qw/svn export -q -r/, $rev, $url_file, $export]); # Copy the exported file into the file push @before_script, 'cp -r ${fcm_patch_dir}/' . $export_file . ' ' . $file; $export_file++; } } } # Write the patch file if ($patch_needed) { my $patchfile = File::Spec->catfile ($outdir_rev, 'patchfile'); open FILE, '>', $patchfile or die $patchfile, ': cannot open (', $!, ')'; print FILE @patch; close FILE or die $patchfile, ': cannot close (', $!, ')'; } # Add line break to each line in @before_script and @after_script @before_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @before_script if (@before_script); @after_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @after_script if (@after_script); # Write patch script to output my $out = File::Spec->catfile ($outdir_rev, 'apply-patch'); open FILE, '>', $out or die $out, ': cannot open (', $!, ')'; # Script header my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/); print FILE <&2 exit 1 fi if [[ -a "#commit_message#" ]]; then echo "\$this: existing commit message in "#commit_message#", abort." >&2 exit 1 fi # Apply the changes EOF # Script content print FILE @before_script if @before_script; print FILE "patch -p0 <\${fcm_patch_dir}/patchfile || exit 1\n" if $patch_needed; print FILE @after_script if @after_script; # Script footer print FILE <('PATCH_REV', $rev); } # Write the main output script if necessary. Otherwise remove output directory # ---------------------------------------------------------------------------- if (@script) { # Add line break to each line in @script @script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @script; # Write script to output my $out = File::Spec->catfile ($outdir, 'fcm-import-patch'); open FILE, '>', $out or die $out, ': cannot open (', $!, ')'; # Script header my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/); print FILE <&2 exit 1 fi if [[ \$target == svn://* || \$target == svn+ssh://* || \\ \$target == http://* || \$target == https://* || \\ \$target == file://* ]]; then # A URL, checkout a working copy in a temporary location fcm_tmp_dir=`mktemp -d \${TMPDIR:=/tmp}/\$this.XXXXXX` fcm_working_copy=\$fcm_tmp_dir svn checkout -q \$target \$fcm_working_copy || exit 1 else fcm_working_copy=\$target fi # Location of the patches, base on the location of this script cd `dirname \$0` || exit 1 fcm_patches_dir=\$PWD # Change directory to the working copy cd \$fcm_working_copy || exit 1 # Set the language to avoid encoding problems export LANG=en_GB # Commands to apply patches EOF # Script content print FILE @script; # Script footer print FILE <('PATCH_DONE', $outdir); } else { # Remove output directory rmtree $outdir or die $outdir, ': cannot remove'; # Diagnostic return _cm_abort(Fcm::Cm::Abort->NULL); } return 1; } # ------------------------------------------------------------------------------ # CLI: fcm add. sub _cli_command_add { my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_; my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'}); return ( @args == @_ ? _svn("add", @args) : cm_check_unknown(\%option, @args) ); } # ------------------------------------------------------------------------------ # CLI: fcm checkout. sub _cli_command_checkout { if (@ARGV) { my $target = is_url($ARGV[-1]) ? cwd() : $ARGV[-1]; if (-d $target && is_wc($target)) { return _cm_err(Fcm::Cm::Exception->WC_EXIST, $target); } } return _svn('checkout', @ARGV); } # ------------------------------------------------------------------------------ # CLI: fcm delete. sub _cli_command_delete { my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_; my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'}); return ( @args == @_ ? _svn("delete", @args) : cm_check_missing(\%option, @args) ); } # ------------------------------------------------------------------------------ # CLI: fcm switch. sub _cli_command_switch { local(@ARGV) = @_; if (grep {$_ eq '--relocate'} @ARGV) { return _svn('switch', @ARGV); } my %option; if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) { _cli_err(); } if (!$option{'non-interactive'}) { $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS}; } if (!@ARGV) { _cli_err(); } $CLI_MESSAGE->(q{}, join(q{}, cm_switch(\%option, @ARGV))); } # ------------------------------------------------------------------------------ # CLI: fcm update. sub _cli_command_update { local(@ARGV) = @_; my %option; if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) { _cli_err(); } if (!$option{'non-interactive'}) { $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS}; } $CLI_MESSAGE->(q{}, join(q{}, cm_update(\%option, @ARGV))); } # ------------------------------------------------------------------------------ # CLI error. sub _cli_err { my ($key, @args) = @_; $key ||= 'CLI_USAGE'; my $message = sprintf($CLI_MESSAGE_FOR_ERROR{$key}, @args); die(Fcm::CLI::Exception->new({message => $message})); } # ------------------------------------------------------------------------------ # Handles abort exception. sub _cli_e_handler_of_cm_abort { my ($function, $e) = @_; if ($e->get_code() eq $e->FAIL) { die(sprintf($CLI_MESSAGE_FOR_ABORT{FAIL}, $function)); } else { $CLI_MESSAGE->($e->get_code(), $function); } } # ------------------------------------------------------------------------------ # Handles CM exception. sub _cli_e_handler_of_cm_exception { my ($function, $e) = @_; die(sprintf($CLI_MESSAGE_FOR_ERROR{$e->get_code()}, $e->get_targets())); } # ------------------------------------------------------------------------------ # Handles CLI exception. sub _cli_e_handler_of_cli_exception { my ($function, $e) = @_; $CLI_MESSAGE->('CLI', $e); $CLI_MESSAGE->('CLI_HELP', $function); } # ------------------------------------------------------------------------------ # The default handler of the "WC_STATUS" event. sub _cli_handler_of_wc_status { my ($name, $target_list_ref, $status_list_ref) = @_; if (@{$status_list_ref}) { $CLI_MESSAGE->('STATUS', join(q{}, @{$status_list_ref})); if ($CLI_PROMPT->($name, 'CONTINUE') ne 'y') { return _cm_abort(); } } return @{$status_list_ref}; } # ------------------------------------------------------------------------------ # The default handler of the "WC_STATUS_PATH" event. sub _cli_handler_of_wc_status_path { my ($name, $target_list_ref, $status_list_ref) = @_; $CLI_MESSAGE->(q{}, join(q{}, @{$status_list_ref})); my @paths = map {chomp(); ($_ =~ $PATTERN_OF{ST_PATH})} @{$status_list_ref}; my @paths_of_interest; while (my $path = shift(@paths)) { my %handler_of = ( a => sub {push(@paths_of_interest, $path, @paths); @paths = ()}, n => sub {}, y => sub {push(@paths_of_interest, $path)}, ); my $reply = $CLI_PROMPT->( {type => 'yna'}, $name, 'RUN_SVN_COMMAND', "$name $path", ); $handler_of{$reply}->(); } return @paths_of_interest; } # ------------------------------------------------------------------------------ # Prints help for a given $subcommand. sub _cli_help { my ($key, $exit_val) = @_; my $pod = File::Spec->catfile(dirname($INC{'Fcm/Cm.pm'}), 'CLI', "fcm-$key.pod"); my $has_pod = -f $pod; if ($has_pod) { pod2usage({ '-exitval' => defined($exit_val) ? $exit_val : 2, '-input' => $pod, '-verbose' => 1, }); } if (!$has_pod || exists($CLI_MORE_HELP_FOR{$key})) { local(@ARGV) = ($key); return _svn('help', $key); } } # ------------------------------------------------------------------------------ # Expands location keywords in a list. sub _cli_keyword_expand_url { my ($arg_list_ref) = @_; ARG: for my $arg (@{$arg_list_ref}) { my ($label, $value) = ($arg =~ $PATTERN_OF{CLI_OPT}); if (!$label) { ($label, $value) = (q{}, $arg); } if (!$value) { next ARG; } eval { $value = Fcm::Util::tidy_url(Fcm::Keyword::expand($value)); }; if ($@) { if ($value ne 'fcm:revision') { die($@); } } $arg = $label . $value; } } # ------------------------------------------------------------------------------ # Expands revision keywords in -r and --revision options in a list. sub _cli_keyword_expand_rev { my ($arg_list_ref) = @_; my @targets; for my $arg (@{$arg_list_ref}) { if (-e $arg && is_wc($arg) || is_url($arg)) { push(@targets, $arg); } } if (!@targets) { push(@targets, get_url_of_wc()); } if (!@targets) { return; } my @old_arg_list = @{$arg_list_ref}; my @new_arg_list = (); ARG: while (defined(my $arg = shift(@old_arg_list))) { my ($key, $value) = $arg =~ $PATTERN_OF{CLI_OPT_REV}; if (!$key) { push(@new_arg_list, $arg); next ARG; } push(@new_arg_list, '--revision'); if (!$value) { $value = shift(@old_arg_list); } my @revs = grep {defined()} ($value =~ $PATTERN_OF{CLI_OPT_REV_RANGE}); my ($url, @url_list) = @targets; for my $rev (@revs) { if ($rev !~ $PATTERN_OF{SVN_REV}) { $rev = (Fcm::Keyword::expand($url, $rev))[1]; } if (@url_list) { $url = shift(@url_list); } } push(@new_arg_list, join(q{:}, @revs)); } @{$arg_list_ref} = @new_arg_list; } # ------------------------------------------------------------------------------ # Prints a message. sub _cli_message { my ($key, @args) = @_; for ( [\*STDOUT, \%CLI_MESSAGE_FOR , q{} ], [\*STDERR, \%CLI_MESSAGE_FOR_WARNING, q{[WARNING] }], [\*STDERR, \%CLI_MESSAGE_FOR_ABORT , q{[ABORT] } ], [\*STDERR, \%CLI_MESSAGE_FOR_ERROR , q{[ERROR] } ], ) { my ($handle, $hash_ref, $prefix) = @{$_}; if (exists($hash_ref->{$key})) { return printf({$handle} $prefix . $hash_ref->{$key}, @args); } } } # ------------------------------------------------------------------------------ # Wrapper for Fcm::Interactive::get_input. sub _cli_prompt { my %option = (type => 'yn', default => 'n', (ref($_[0]) ? %{shift(@_)} : ())); my ($name, $key, @args) = @_; return Fcm::Interactive::get_input( title => $CLI_PROMPT_PREFIX . $name, message => sprintf($CLI_MESSAGE_FOR_PROMPT{$key}, @args), %option, ); } # ------------------------------------------------------------------------------ # Check missing status and delete. sub cm_check_missing { my %option = %{shift()}; my $checker = _svn_status_checker('delete', 'MISSING', $option{st_check_handler}); my @paths = $checker->(\@_); if (@paths) { run_command([qw{svn delete}, @paths]); } } # ------------------------------------------------------------------------------ # Check unknown status and add. sub cm_check_unknown { my %option = %{shift()}; my $checker = _svn_status_checker('add', 'UNKNOWN', $option{st_check_handler}); my @paths = $checker->(\@_); if (@paths) { run_command([qw{svn add}, @paths]); } } # ------------------------------------------------------------------------------ # FCM wrapper to SVN switch. sub cm_switch { my %option = %{shift()}; my ($target, $path) = @_; $path ||= cwd(); if (!-e $path) { return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path); } if (!is_wc($path)) { return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); } # Check for merge template in the commit log file in the working copy my $path_of_wc = get_wct($path); my $ci_mesg = Fcm::CmCommitMessage->new(); $ci_mesg->dir($path_of_wc); $ci_mesg->read_file(); if (@{$ci_mesg->auto_mesg()}) { return _cm_err( Fcm::Cm::Exception->SWITCH_UNSAFE, $path eq $path_of_wc ? $ci_mesg->base() : $ci_mesg->file(), ); } # Check for any local modifications if (defined($option{st_check_handler})) { my $handler = $CLI_HANDLER_OF{WC_STATUS}; _svn_status_checker('switch', 'MODIFIED', $handler)->([$path_of_wc]); } # Invokes "svn switch" _svn( {METHOD => 'qx', PRINT => !$option{quiet}}, 'switch', ($option{'non-interactive'} ? '--non-interactive' : ()), ($option{revision} ? ('-r', $option{revision}) : ()), ($option{quiet} ? '--quiet' : ()), _cm_get_source( $target, Fcm::CmBranch->new(URL => get_url_of_wc($path_of_wc)), )->url_peg(), ($path_of_wc eq cwd() ? () : $path_of_wc), ); } # ------------------------------------------------------------------------------ # FCM wrapper to SVN update. sub cm_update { my %option = %{shift()}; my @targets = @_; if (!@targets) { @targets = (cwd()); } for my $target (@targets) { if (!-e $target) { return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $target); } if (!is_wc($target)) { return _cm_err(Fcm::Cm::Exception->INVALID_WC, $target); } $target = get_wct($target); if ($target eq cwd()) { $target = q{.}; } } if (defined($option{st_check_handler})) { my ($matcher_keys_ref, $show_updates) = defined($option{revision}) ? (['MODIFIED' ], undef) : (['MODIFIED', 'OUT_OF_DATE'], 1 ) ; my $matcher = sub { for my $key (@{$matcher_keys_ref}) { $ST_MATCHER_FOR{$key}->(@_) && return 1; } }; _svn_status_checker( 'update', $matcher, $option{st_check_handler}, $show_updates, )->(\@targets); } if ($option{revision} && $option{revision} !~ $PATTERN_OF{SVN_REV}) { $option{revision} = ( Fcm::Keyword::expand(get_url_of_wc($targets[0]), $option{revision}) )[1]; } return _svn_update(\@targets, \%option); } # ------------------------------------------------------------------------------ # Raises an abort exception. sub _cm_abort { my ($code) = @_; $code ||= Fcm::Cm::Abort->USER; die(bless({code => $code, message => 'abort'}, 'Fcm::Cm::Abort')); } # ------------------------------------------------------------------------------ # Raises a failure. sub _cm_err { my ($code, @targets) = @_; die(bless( {code => $code, message => "ERROR: $code", targets => \@targets}, 'Fcm::Cm::Exception', )); } # ------------------------------------------------------------------------------ # Returns the corresponding Fcm::CmBranch instance for $src_url w.r.t. $target. sub _cm_get_source { my ($src_url, $target) = @_; my $source = Fcm::CmBranch->new(URL => $src_url); if (!$source->is_url()) { # Not a full URL, construct full URL based on current URL $source->url_peg($target->url_peg()); my $project = $target->project(); my ($path) = $src_url =~ qr{\A/*(.*)\z}xms; if (index($path, $project) == 0) { # Argument contains the full path under the repository root $path = substr($path, length($project)); } if ($path =~ $PATTERN_OF{FCM_BRANCH_PATH}) { # Argument contains the full branch name $path = join(q{/}, $target->project_path(), $path); } else { # Argument contains the shorter branch name $path = join(q{/}, $target->project_path(), 'branches', $path); } $source->path_peg($path); } # Replace source sub-directory with the target sub-directory $source->subdir($target->subdir()); # Ensure that the branch name exists if (!$source->url_exists()) { return _cm_err(Fcm::Cm::Exception->INVALID_URL, $src_url); } # Ensure that the branch name is valid if (!$source->branch()) { return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $src_url); } # Ensure that the source and target URLs are in the same project if ($source->project_url() ne $target->project_url()) { return _cm_err( Fcm::Cm::Exception->DIFF_PROJECTS, $target->url_peg(), $source->url_peg(), ); } return $source; } # ------------------------------------------------------------------------------ # Runs "svn". sub _svn { my @args = @_; my %option; if (@args && ref($args[0])) { %option = %{shift(@args)}; } return run_command( ['svn', @args], PRINT => ($args[0] ne 'cat' && !grep {$_ eq '--xml'} @args), %option, ); } # ------------------------------------------------------------------------------ # Returns the results of "svn status". sub _svn_status_get { my ($target_list_ref, $show_updates) = @_; my @targets = (defined($target_list_ref) ? @{$target_list_ref} : ()); for my $target (@targets) { if ($target eq cwd()) { $target = q{.}; } } my @options = ($show_updates ? qw{--show-updates} : ()); return _svn({METHOD => 'qx', PRINT => 0}, 'status', @options, @targets); } # ------------------------------------------------------------------------------ # Returns a "svn status" checker. sub _svn_status_checker { my ($name, $matcher, $handler, $show_updates) = @_; if (!ref($matcher)) { $matcher = $ST_MATCHER_FOR{$matcher}; } return sub { my ($target_list_ref) = @_; my @status = _svn_status_get($target_list_ref, $show_updates); if ($show_updates) { @status = map {$_ =~ $PATTERN_OF{ST_AGAINST_REV} ? () : $_} @status; } my @status_of_interest = grep {$matcher->($_)} @status; if (defined($handler)) { return $handler->($name, $target_list_ref, \@status_of_interest); } return @status_of_interest; } } # ------------------------------------------------------------------------------ # Runs "svn update". sub _svn_update { my ($target_list_ref, $option_hash_ref) = @_; my %option = (defined($option_hash_ref) ? %{$option_hash_ref} : ()); _svn( {METHOD => 'qx', PRINT => !$option{quiet}}, 'update', ($option{'non-interactive'} ? '--non-interactive' : ()), ($option{revision} ? ('-r', $option{revision}) : ()), ($option{quiet} ? '--quiet' : ()), (defined($target_list_ref) ? @{$target_list_ref} : ()), ); } # ------------------------------------------------------------------------------ # Abort exception. package Fcm::Cm::Abort; use base qw{Fcm::Exception}; use constant {FAIL => 'FAIL', NULL => 'NULL', USER => 'USER'}; sub get_code { return $_[0]->{code}; } # ------------------------------------------------------------------------------ # Resource exception. package Fcm::Cm::Exception; our @ISA = qw{Fcm::Cm::Abort}; use constant { CHDIR => 'CHDIR', INVALID_BRANCH => 'INVALID_BRANCH', INVALID_PROJECT => 'INVALID_PROJECT', INVALID_TARGET => 'INVALID_TARGET', INVALID_URL => 'INVALID_URL', INVALID_WC => 'INVALID_WC', MERGE_REV_INVALID => 'MERGE_REV_INVALID', MERGE_SELF => 'MERGE_SELF', MERGE_UNRELATED => 'MERGE_UNRELATED', MERGE_UNSAFE => 'MERGE_UNSAFE', MKPATH => 'MKPATH', NOT_EXIST => 'NOT_EXIST', PARENT_NOT_EXIST => 'PARENT_NOT_EXIST', RMTREE => 'RMTREE', SWITCH_UNSAFE => 'SWITCH_UNSAFE', WC_EXIST => 'WC_EXIST', WC_INVALID_BRANCH => 'WC_INVALID_BRANCH', WC_URL_NOT_EXIST => 'WC_URL_NOT_EXIST', }; sub get_targets { return @{$_[0]->{targets}}; } 1; __END__ =pod =head1 NAME Fcm::Cm =head1 SYNOPSIS use Fcm::Cm qw{cli}; # Use as a wrapper to Subversion, and other FCM code management commands cli('info', '--revision', 'HEAD', $url); use Fcm::Cm qw{cm_check_missing cm_check_unknown cm_switch cm_update}; # Checks status for "missing" items and "svn delete" them $missing_st_handler = sub { my ($name, $target_list_ref, $status_list_ref) = @_; # ... return @paths_of_interest; }; cm_check_missing({st_check_handler => $missing_st_handler}, @targets); # Checks status for "unknown" items and "svn add" them $unknown_st_handler = sub { my ($name, $target_list_ref, $status_list_ref) = @_; # ... return @paths_of_interest; }; cm_check_unknown({st_check_handler => $unknown_st_handler}, @targets); # Sets up a status checker $st_check_handler = sub { my ($name, $target_list_ref, $status_list_ref) = @_; # ... }; # Switches a "working copy" at the "root" level to a new URL target cm_switch( { 'non-interactive' => $non_interactive_flag, 'quiet' => $quiet_flag, 'revision' => $revision, 'st_check_handler' => $st_check_handler, }, $target, $path_of_wc, ); # Runs "svn update" on each working copy from their "root" level cm_update( { 'non-interactive' => $non_interactive_flag, 'quiet' => $quiet_flag, 'revision' => $revision, 'st_check_handler' => $st_check_handler, }, @targets, ); =head1 DESCRIPTION Wraps the Subversion client and implements other FCM code management functionalities. =head1 FUNCTIONS =over 4 =item cli($function,@args) Implements the FCM code management CLI. If --help or -h is specified in @args, it displays help and returns. Otherwise, it attempts to expand any FCM location and revision keywords in @args. Calls the relevant FCM code management function according to $function, or a SVN command if $function is not modified by FCM. =item cm_check_missing(\%option,@targets) Use "svn status" to check for missing items in @targets. If @targets is an empty list, the function adds the current working directory to it. Expects $option{st_check_handler} to be a CODE reference. Calls $option{st_check_handler} with ($name, $target_list_ref, $status_list_ref) where $name is "delete", $target_list_ref is \@targets, and $status_list_ref is an ARRAY reference to a list of "svn status" output with the "missing" status. $option{st_check_handler} should return a list of interesting paths, which will be scheduled for removal using "svn delete". =item cm_check_unknown(\%option,@targets) Similar to cm_check_missing(\%option,@targets) but checks for "unknown" items, which will be scheduled for addition using "svn add". =item cm_switch(\%option,$target,$path_of_wc) Invokes "svn switch" at the root of a working copy specified by $path_of_wc (or the current working directory if $path_of_wc is not specified). $option{'non-interactive'}, $option{quiet}, $option{revision} determines the options (of the same name) that are passed to "svn switch". If $option{st_check_handler} is set, it should be a CODE reference, and will be called with ('switch', [$path_of_wc], $status_list_ref), where $status_list_ref is an ARRAY reference to the output returned by "svn status" on $path_of_wc. This can be used for the application to display the working copy status to the user before prompting him/her to continue. The return value of $option{st_check_handler} is ignored. =item cm_update(\%option,@targets) Invokes "svn update" at the root of each working copy specified by @targets. If @targets is an empty list, the function adds the current working directory to it. $option{'non-interactive'}, $option{quiet}, $option{revision} determines the options (of the same name) that are passed to "svn update". If $option{st_check_handler} is set, it should be a CODE reference, and will be called with ($name, $target_list_ref, $status_list_ref), where $name is 'update', $target_list_ref is \@targets and $status_list_ref is an ARRAY reference to the output returned by "svn status -u" on the @targets. This can be used for the application to display the working copy update status to the user before prompting him/her to continue. The return value of $option{st_check_handler} is ignored. =back =head1 DIAGNOSTICS The following exceptions can be raised: =over 4 =item Fcm::Cm::Abort This exception @ISA L. It is raised if a command is aborted for some reason. The $e->get_code() method can be used to retrieve an error code, which can be one of the following: =over 4 =item $e->FAIL The command aborts because of a failure. =item $e->NULL The command aborts because it will result in no change. =item $e->USER The command aborts because of an action by the user. =back =item Fcm::Cm::Exception This exception @ISA L. It is raised if a command fails with a known reason. The $e->get_targets() method can be used to retrieve a list of targets/resources associated with this exception. The $e->get_code() method can be used to retrieve an error code, which can be one of the following: =over 4 =item $e->CHDIR Fails to change directory to a target. =item $e->INVALID_BRANCH A target is not a valid branch URL in the standard FCM project layout. =item $e->INVALID_PROJECT A target is not a valid project URL in the standard FCM project layout. =item $e->INVALID_TARGET A target is not a valid Subversion URL or working copy. =item $e->INVALID_URL A target is not a valid Subversion URL. =item $e->INVALID_WC A target is not a valid Subversion working copy. =item $e->MERGE_REV_INVALID An invalid revision (target element 0) is specified for a merge. =item $e->MERGE_SELF Attempt to merge a URL (target element 0) to its own working copy (target element 1). =item $e->MERGE_UNRELATED The merge target (target element 0) is not directly related to the merge source (target element 1). =item $e->MERGE_UNSAFE A merge source (target element 0) contains changes outside the target sub-directory. =item $e->MKPATH Fail to create a directory (target element 0) recursively. =item $e->NOT_EXIST A target does not exist. =item $e->PARENT_NOT_EXIST The parent of the target no longer exists. =item $e->RMTREE Fail to remove a directory (target element 0) recursively. =item $e->SWITCH_UNSAFE A merge template exists in the commit message file (target element 0) in a working copy target. =item $e->WC_EXIST The target working copy already exists. =item $e->WC_INVALID_BRANCH The URL of the target working copy is not a valid branch URL in the standard FCM project layout. =item $e->WC_URL_NOT_EXIST The URL of the target working copy no longer exists at the HEAD revision. =back =back =head1 TO DO Reintegrate with L and L, but separate this module into the CLI part and the CM part. Expose the remaining CM functions when this is done. Use L to interface with Subversion. Move C out of this module. =head1 COPYRIGHT E<169> Crown copyright Met Office. All rights reserved. =cut