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 | # ------------------------------------------------------------------------------ |
---|
14 | use strict; |
---|
15 | use warnings; |
---|
16 | |
---|
17 | package Fcm::Cm; |
---|
18 | use base qw{Exporter}; |
---|
19 | |
---|
20 | our @EXPORT_OK = qw(cli cm_check_missing cm_check_unknown cm_switch cm_update); |
---|
21 | |
---|
22 | use Cwd qw{cwd}; |
---|
23 | use Getopt::Long qw{GetOptions :config bundling}; |
---|
24 | use Fcm::CLI::Exception; |
---|
25 | use Fcm::Config; |
---|
26 | use Fcm::CmBranch; |
---|
27 | use Fcm::CmUrl; |
---|
28 | use Fcm::Keyword; |
---|
29 | use 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 | }; |
---|
38 | use File::Basename qw{basename dirname}; |
---|
39 | use File::Path qw{mkpath rmtree}; |
---|
40 | use File::Spec; |
---|
41 | use File::Temp qw{tempfile}; |
---|
42 | use Pod::Usage qw{pod2usage}; |
---|
43 | |
---|
44 | # ------------------------------------------------------------------------------ |
---|
45 | |
---|
46 | # CLI message handler |
---|
47 | our $CLI_MESSAGE = \&_cli_message; |
---|
48 | |
---|
49 | # List of CLI messages |
---|
50 | our %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 |
---|
68 | our %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 |
---|
75 | our %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 |
---|
111 | our %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 |
---|
139 | our %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 |
---|
147 | our $CLI_PROMPT = \&_cli_prompt; |
---|
148 | our $CLI_PROMPT_PREFIX = q{fcm }; |
---|
149 | |
---|
150 | # List of exception handlers [$class, CODE->($function, $e)] |
---|
151 | our @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 |
---|
158 | our %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 |
---|
164 | our %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" |
---|
179 | our %CLI_MORE_HELP_FOR = map {($_, 1)} qw{add diff delete switch update}; |
---|
180 | |
---|
181 | # The preferred name of subcommand aliases |
---|
182 | our %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 |
---|
214 | our %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 |
---|
242 | our %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 |
---|
265 | our %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 |
---|
324 | our %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. |
---|
334 | sub 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 | |
---|
378 | sub 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 | |
---|
627 | sub 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 | |
---|
819 | sub 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 | |
---|
911 | sub 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 | |
---|
1089 | sub 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 | |
---|
1391 | sub 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 | |
---|
1781 | this=`basename \$0` |
---|
1782 | echo "\$this: Applying patch for changeset $rev." |
---|
1783 | |
---|
1784 | # Location of the patch, base on the location of this script |
---|
1785 | cd `dirname \$0` || exit 1 |
---|
1786 | fcm_patch_dir=\$PWD |
---|
1787 | |
---|
1788 | # Change directory back to the working copy |
---|
1789 | cd \$OLDPWD || exit 1 |
---|
1790 | |
---|
1791 | # Check working copy does not have local changes |
---|
1792 | status=`svn status` |
---|
1793 | if [[ -n \$status ]]; then |
---|
1794 | echo "\$this: working copy contains changes, abort." >&2 |
---|
1795 | exit 1 |
---|
1796 | fi |
---|
1797 | if [[ -a "#commit_message#" ]]; then |
---|
1798 | echo "\$this: existing commit message in "#commit_message#", abort." >&2 |
---|
1799 | exit 1 |
---|
1800 | fi |
---|
1801 | |
---|
1802 | # Apply the changes |
---|
1803 | EOF |
---|
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 |
---|
1815 | cp \${fcm_patch_dir}/log-message "#commit_message#" |
---|
1816 | |
---|
1817 | echo "\$this: finished normally." |
---|
1818 | #EOF |
---|
1819 | EOF |
---|
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 | |
---|
1866 | this=`basename \$0` |
---|
1867 | |
---|
1868 | # Check argument |
---|
1869 | target=\$1 |
---|
1870 | |
---|
1871 | # First argument must be a URL or working copy |
---|
1872 | if [[ -z \$target ]]; then |
---|
1873 | echo "\$this: the first argument must be a URL or a working copy, abort." >&2 |
---|
1874 | exit 1 |
---|
1875 | fi |
---|
1876 | |
---|
1877 | if [[ \$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 |
---|
1884 | else |
---|
1885 | fcm_working_copy=\$target |
---|
1886 | fi |
---|
1887 | |
---|
1888 | # Location of the patches, base on the location of this script |
---|
1889 | cd `dirname \$0` || exit 1 |
---|
1890 | fcm_patches_dir=\$PWD |
---|
1891 | |
---|
1892 | # Change directory to the working copy |
---|
1893 | cd \$fcm_working_copy || exit 1 |
---|
1894 | |
---|
1895 | # Set the language to avoid encoding problems |
---|
1896 | export LANG=en_GB |
---|
1897 | |
---|
1898 | # Commands to apply patches |
---|
1899 | EOF |
---|
1900 | |
---|
1901 | # Script content |
---|
1902 | print FILE @script; |
---|
1903 | |
---|
1904 | # Script footer |
---|
1905 | print FILE <<EOF; |
---|
1906 | # Remove temporary working copy, if necessary |
---|
1907 | if [[ -d \$fcm_tmp_dir && -w \$fcm_tmp_dir ]]; then |
---|
1908 | rm -rf \$fcm_tmp_dir |
---|
1909 | fi |
---|
1910 | |
---|
1911 | echo "\$this: finished normally." |
---|
1912 | #EOF |
---|
1913 | EOF |
---|
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. |
---|
1936 | sub _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. |
---|
1946 | sub _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. |
---|
1958 | sub _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. |
---|
1968 | sub _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. |
---|
1988 | sub _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. |
---|
2002 | sub _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. |
---|
2011 | sub _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. |
---|
2023 | sub _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. |
---|
2030 | sub _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. |
---|
2038 | sub _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. |
---|
2051 | sub _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. |
---|
2072 | sub _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. |
---|
2092 | sub _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. |
---|
2117 | sub _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. |
---|
2161 | sub _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. |
---|
2178 | sub _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. |
---|
2191 | sub 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. |
---|
2203 | sub 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. |
---|
2215 | sub 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. |
---|
2261 | sub 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. |
---|
2303 | sub _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. |
---|
2311 | sub _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. |
---|
2321 | sub _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". |
---|
2366 | sub _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". |
---|
2381 | sub _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. |
---|
2395 | sub _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". |
---|
2416 | sub _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. |
---|
2431 | package Fcm::Cm::Abort; |
---|
2432 | use base qw{Fcm::Exception}; |
---|
2433 | use constant {FAIL => 'FAIL', NULL => 'NULL', USER => 'USER'}; |
---|
2434 | |
---|
2435 | sub get_code { |
---|
2436 | return $_[0]->{code}; |
---|
2437 | } |
---|
2438 | |
---|
2439 | # ------------------------------------------------------------------------------ |
---|
2440 | # Resource exception. |
---|
2441 | package Fcm::Cm::Exception; |
---|
2442 | our @ISA = qw{Fcm::Cm::Abort}; |
---|
2443 | use 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 | |
---|
2464 | sub get_targets { |
---|
2465 | return @{$_[0]->{targets}}; |
---|
2466 | } |
---|
2467 | |
---|
2468 | 1; |
---|
2469 | __END__ |
---|
2470 | |
---|
2471 | =pod |
---|
2472 | |
---|
2473 | =head1 NAME |
---|
2474 | |
---|
2475 | Fcm::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 | |
---|
2530 | Wraps the Subversion client and implements other FCM code management |
---|
2531 | functionalities. |
---|
2532 | |
---|
2533 | =head1 FUNCTIONS |
---|
2534 | |
---|
2535 | =over 4 |
---|
2536 | |
---|
2537 | =item cli($function,@args) |
---|
2538 | |
---|
2539 | Implements the FCM code management CLI. If --help or -h is specified in @args, |
---|
2540 | it displays help and returns. Otherwise, it attempts to expand any FCM location |
---|
2541 | and revision keywords in @args. Calls the relevant FCM code management function |
---|
2542 | according to $function, or a SVN command if $function is not modified by FCM. |
---|
2543 | |
---|
2544 | =item cm_check_missing(\%option,@targets) |
---|
2545 | |
---|
2546 | Use "svn status" to check for missing items in @targets. If @targets is an empty |
---|
2547 | list, 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 |
---|
2551 | ARRAY 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 |
---|
2553 | be scheduled for removal using "svn delete". |
---|
2554 | |
---|
2555 | =item cm_check_unknown(\%option,@targets) |
---|
2556 | |
---|
2557 | Similar to cm_check_missing(\%option,@targets) but checks for "unknown" items, |
---|
2558 | which will be scheduled for addition using "svn add". |
---|
2559 | |
---|
2560 | =item cm_switch(\%option,$target,$path_of_wc) |
---|
2561 | |
---|
2562 | Invokes "svn switch" at the root of a working copy specified by $path_of_wc (or |
---|
2563 | the current working directory if $path_of_wc is not specified). |
---|
2564 | $option{'non-interactive'}, $option{quiet}, $option{revision} determines the |
---|
2565 | options (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 |
---|
2567 | called with ('switch', [$path_of_wc], $status_list_ref), where $status_list_ref |
---|
2568 | is an ARRAY reference to the output returned by "svn status" on $path_of_wc. |
---|
2569 | This can be used for the application to display the working copy status to the |
---|
2570 | user 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 | |
---|
2575 | Invokes "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 |
---|
2577 | it. $option{'non-interactive'}, $option{quiet}, $option{revision} determines the |
---|
2578 | options (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 |
---|
2580 | called 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 |
---|
2582 | reference to the output returned by "svn status -u" on the @targets. This can be |
---|
2583 | used for the application to display the working copy update status to the user |
---|
2584 | before prompting him/her to continue. The return value of |
---|
2585 | $option{st_check_handler} is ignored. |
---|
2586 | |
---|
2587 | =back |
---|
2588 | |
---|
2589 | =head1 DIAGNOSTICS |
---|
2590 | |
---|
2591 | The following exceptions can be raised: |
---|
2592 | |
---|
2593 | =over 4 |
---|
2594 | |
---|
2595 | =item Fcm::Cm::Abort |
---|
2596 | |
---|
2597 | This exception @ISA L<Fcm::Exception|Fcm::Exception>. It is raised if a command |
---|
2598 | is aborted for some reason. The $e->get_code() method can be used to retrieve an |
---|
2599 | error code, which can be one of the following: |
---|
2600 | |
---|
2601 | =over 4 |
---|
2602 | |
---|
2603 | =item $e->FAIL |
---|
2604 | |
---|
2605 | The command aborts because of a failure. |
---|
2606 | |
---|
2607 | =item $e->NULL |
---|
2608 | |
---|
2609 | The command aborts because it will result in no change. |
---|
2610 | |
---|
2611 | =item $e->USER |
---|
2612 | |
---|
2613 | The command aborts because of an action by the user. |
---|
2614 | |
---|
2615 | =back |
---|
2616 | |
---|
2617 | =item Fcm::Cm::Exception |
---|
2618 | |
---|
2619 | This exception @ISA L<Fcm::Abort|Fcm::Abort>. It is raised if a command fails |
---|
2620 | with a known reason. The $e->get_targets() method can be used to retrieve a list |
---|
2621 | of targets/resources associated with this exception. The $e->get_code() method |
---|
2622 | can be used to retrieve an error code, which can be one of the following: |
---|
2623 | |
---|
2624 | =over 4 |
---|
2625 | |
---|
2626 | =item $e->CHDIR |
---|
2627 | |
---|
2628 | Fails to change directory to a target. |
---|
2629 | |
---|
2630 | =item $e->INVALID_BRANCH |
---|
2631 | |
---|
2632 | A target is not a valid branch URL in the standard FCM project layout. |
---|
2633 | |
---|
2634 | =item $e->INVALID_PROJECT |
---|
2635 | |
---|
2636 | A target is not a valid project URL in the standard FCM project layout. |
---|
2637 | |
---|
2638 | =item $e->INVALID_TARGET |
---|
2639 | |
---|
2640 | A target is not a valid Subversion URL or working copy. |
---|
2641 | |
---|
2642 | =item $e->INVALID_URL |
---|
2643 | |
---|
2644 | A target is not a valid Subversion URL. |
---|
2645 | |
---|
2646 | =item $e->INVALID_WC |
---|
2647 | |
---|
2648 | A target is not a valid Subversion working copy. |
---|
2649 | |
---|
2650 | =item $e->MERGE_REV_INVALID |
---|
2651 | |
---|
2652 | An invalid revision (target element 0) is specified for a merge. |
---|
2653 | |
---|
2654 | =item $e->MERGE_SELF |
---|
2655 | |
---|
2656 | Attempt to merge a URL (target element 0) to its own working copy (target |
---|
2657 | element 1). |
---|
2658 | |
---|
2659 | =item $e->MERGE_UNRELATED |
---|
2660 | |
---|
2661 | The merge target (target element 0) is not directly related to the merge source |
---|
2662 | (target element 1). |
---|
2663 | |
---|
2664 | =item $e->MERGE_UNSAFE |
---|
2665 | |
---|
2666 | A merge source (target element 0) contains changes outside the target |
---|
2667 | sub-directory. |
---|
2668 | |
---|
2669 | =item $e->MKPATH |
---|
2670 | |
---|
2671 | Fail to create a directory (target element 0) recursively. |
---|
2672 | |
---|
2673 | =item $e->NOT_EXIST |
---|
2674 | |
---|
2675 | A target does not exist. |
---|
2676 | |
---|
2677 | =item $e->PARENT_NOT_EXIST |
---|
2678 | |
---|
2679 | The parent of the target no longer exists. |
---|
2680 | |
---|
2681 | =item $e->RMTREE |
---|
2682 | |
---|
2683 | Fail to remove a directory (target element 0) recursively. |
---|
2684 | |
---|
2685 | =item $e->SWITCH_UNSAFE |
---|
2686 | |
---|
2687 | A merge template exists in the commit message file (target element 0) in a |
---|
2688 | working copy target. |
---|
2689 | |
---|
2690 | =item $e->WC_EXIST |
---|
2691 | |
---|
2692 | The target working copy already exists. |
---|
2693 | |
---|
2694 | =item $e->WC_INVALID_BRANCH |
---|
2695 | |
---|
2696 | The URL of the target working copy is not a valid branch URL in the standard FCM |
---|
2697 | project layout. |
---|
2698 | |
---|
2699 | =item $e->WC_URL_NOT_EXIST |
---|
2700 | |
---|
2701 | The 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 | |
---|
2709 | Reintegrate with L<Fcm::CmUrl|Fcm::CmUrl> and L<Fcm::CmBranch|Fcm::CmBranch>, |
---|
2710 | but separate this module into the CLI part and the CM part. Expose the remaining |
---|
2711 | CM functions when this is done. |
---|
2712 | |
---|
2713 | Use L<SVN::Client|SVN::Client> to interface with Subversion. |
---|
2714 | |
---|
2715 | Move C<mkpatch> out of this module. |
---|
2716 | |
---|
2717 | =head1 COPYRIGHT |
---|
2718 | |
---|
2719 | E<169> Crown copyright Met Office. All rights reserved. |
---|
2720 | |
---|
2721 | =cut |
---|