Context Navigation

Cm.pm

Last change on this file was 1578, checked in by jghattas, 13 years ago

Add fcm in LMDZ5/tools directory

It is no longer needed to have fcm in your environement PATH variable.
Now makelmdz_fcm takes by default this fcm. It is still possible to use
another fcm, using -fcm_path argument in makelmdz_fcm.

File size: 71.9 KB

Line
1	#!/usr/bin/perl
2	# ------------------------------------------------------------------------------
3	# NAME
4	# Fcm::Cm
5	#
6	# DESCRIPTION
7	# This module contains the FCM code management functionalities and wrappers
8	# to Subversion commands.
9	#
10	# COPYRIGHT
11	# (C) Crown copyright Met Office. All rights reserved.
12	# For further details please refer to the file COPYRIGHT.txt
13	# which you should have received as part of this distribution.
14	# ------------------------------------------------------------------------------
15
16	package Fcm::Cm;
17
18	# Standard pragma
19	use warnings;
20	use strict;
21
22	# Standard modules
23	our (@ISA, @EXPORT, @EXPORT_OK);
24	use Getopt::Long;
25	use File::Basename;
26	use File::Path;
27	use File::Spec;
28	use File::Temp qw/tempfile/;
29	use Cwd;
30
31	# FCM component modules
32	use Fcm::CmBranch;
33	use Fcm::CmUrl;
34	use Fcm::Util;
35
36	sub cm_command;
37
38	require Exporter;
39	@ISA = qw(Exporter);
40	@EXPORT = qw(
41	cm_command
42	);
43
44	# Function declaration:
45	sub cm_add;
46	sub cm_branch;
47	sub cm_commit;
48	sub cm_conflicts;
49	sub cm_delete;
50	sub cm_diff;
51	sub cm_merge;
52	sub cm_mkpatch;
53	sub cm_svn;
54	sub cm_switch;
55	sub _construct_branch_url;
56
57	# ------------------------------------------------------------------------------
58
59	my @subcommand_url = qw/
60	blame praise annotate ann
61	branch br
62	cat
63	checkout co
64	copy cp
65	delete del remove rm
66	diff di
67	export
68	import
69	info
70	list ls
71	lock
72	log
73	merge
74	mkdir
75	mkpatch
76	move mv rename ren
77	propdel pdel pd
78	propedit pedit pe
79	propget pget pg
80	proplist plist pl
81	propset pset ps
82	switch sw
83	unlock
84	/; # List of subcommands that accept URL inputs
85
86	my @subcommand_rev = qw/
87	blame praise annotate ann
88	branch br
89	cat
90	checkout co
91	copy cp
92	diff di
93	export
94	info
95	list ls
96	log
97	merge
98	mkpatch
99	move mv rename ren
100	propdel pdel pd
101	propedit pedit pe
102	propget pget pg
103	proplist plist pl
104	propset pset ps
105	switch sw
106	update up
107	/; # List of subcommands that accept revision inputs
108
109	# ------------------------------------------------------------------------------
110	# SYNOPSIS
111	# &cm_command ($function);
112	#
113	# DESCRIPTION
114	# This is the generic FCM code management wrapper. It calls the correct FCM
115	# code management function or a wrapper to a Subversion command based on the
116	# value of the argument $function.
117	# ------------------------------------------------------------------------------
118
119	sub cm_command {
120
121	my ($function) = shift @_;
122
123	# Expand URL keywords if necessary
124	if (grep {$_ eq $function} @subcommand_url) {
125	for my $arg (@ARGV) {
126	my $var = expand_url_keyword (URL => $arg);
127	$arg = $var if $arg ne $var;
128	}
129	}
130
131	# Expand revision keywords (for -r or --revision options) if necessary
132	if (grep {$_ eq $function} @subcommand_rev) {
133	my @new_argv = ();
134
135	while (defined (my $arg = shift @ARGV)) {
136	if ($arg eq '--revision') {
137	# Long --revision option, must be followed by a space before the
138	# revision argument
139	push @new_argv, $arg;
140
141	} elsif ($arg =~ s/^-r//) {
142	# Short -r option, may be followed by the revision argument with or
143	# without a space in between
144	push @new_argv, '--revision';
145	unshift @ARGV, $arg if $arg;
146
147	} else {
148	# Other option or argument
149	push @new_argv, $arg;
150	next;
151	}
152
153	# First revision number/keyword
154	my $rev1 = '';
155
156	# Get the next argument from the list
157	$arg = shift @ARGV;
158
159	if (index ($arg, '{') == 0) {
160	# A revision date argument may contain a space. Therefore, it may need
161	# the next argument(s) from the list
162	while (index ($arg, '}') == -1) {
163	my $shift = shift @ARGV;
164	last unless $shift;
165	$arg .= ' ' . $shift;
166	}
167
168	$arg =~ s/^(\{.+?\})//;
169	$rev1 = $1;
170
171	} else {
172	# Other revision argument
173	$arg =~ s/^(\S+?)(?::\|$)//;
174	$rev1 = $1;
175	}
176
177	# The rest of $arg is the second revision number/keyword
178	my $rev2 = $arg;
179	$rev2 =~ s/^:*//;
180
181	# A revision date argument may contain a space. Therefore, it may need
182	# the next argument(s) from the list
183	if (index ($rev2, '{') == 0) {
184	while (index ($rev2, '}') == -1) {
185	my $shift = shift @ARGV;
186	last unless $shift;
187	$rev2 .= ' ' . $shift;
188	}
189	}
190
191	# Expand revision keyword if necessary
192	if ($rev1 !~ /^(?:\d+\|HEAD\|BASE\|COMMITTED\|PREV\|\{.+\})$/i or
193	$rev2 !~ /^(?:\d+\|HEAD\|BASE\|COMMITTED\|PREV\|\{.+\})$/i) {
194	# Find out the associated URLs by inspecting the argument list
195	my $url1 = '';
196	my $url2 = '';
197
198	for (@new_argv, @ARGV) {
199	my $arg = Fcm::CmUrl->new (URL => $_);
200	next unless $arg->is_url;
201
202	if ($url1) {
203	$url2 = $arg->url_peg;
204	last;
205
206	} else {
207	$url1 = $arg->url_peg;
208	}
209	}
210
211	# Argument list does not contain a URL, try "svn info" on WC
212	$url1 = &get_url_of_wc () if not $url1;
213	$url2 = $url1 if not $url2;
214
215	# Expand 1st revision keyword if necessary
216	$rev1 = expand_rev_keyword (REV => $rev1, URL => $url1)
217	if $rev1 !~ /^(?:\d+\|HEAD\|BASE\|COMMITTED\|PREV\|\{.+\})$/i;
218
219	# Expand 2nd revision keyword if necessary
220	$rev2 = expand_rev_keyword (REV => $rev2, URL => $url2)
221	if $rev2 and $rev2 !~ /^(?:\d+\|HEAD\|BASE\|COMMITTED\|PREV\|\{.+\})$/i;
222	}
223
224	# Append revision argument to argument list
225	push @new_argv, ($rev2 ? $rev1 . ':' . $rev2 : $rev1);
226	}
227
228	@ARGV = @new_argv;
229	}
230
231	# Expand revision keywords (for peg revision TARGET@REVSION) if necessary
232	for (@ARGV) {
233	if (m#^(\w+://\S+)@(\S+)$#) {
234	my $url = $1;
235	my $rev = $2;
236
237	my $new_rev = expand_rev_keyword (URL => $url, REV => $rev, HEAD => 1);
238
239	$_ = $url . '@' . $new_rev if $new_rev ne $rev;
240	}
241	}
242
243	# List of special sub-commands recognised by FCM
244	my %subcommand = (
245	ADD => [qw/add/],
246	BRANCH => [qw/branch br/],
247	COMMIT => [qw/commit ci/],
248	CONFLICTS => [qw/conflicts cf/],
249	CHECKOUT => [qw/checkout co/],
250	DELETE => [qw/delete del remove rm/],
251	DIFF => [qw/diff di/],
252	MERGE => [qw/merge/],
253	MKPATCH => [qw/mkpatch/],
254	SWITCH => [qw/switch sw/],
255	);
256
257	if (grep {$_ eq $function} @{ $subcommand{ADD} }) {
258	cm_add;
259
260	} elsif (grep {$_ eq $function} @{ $subcommand{BRANCH} }) {
261	cm_branch;
262
263	} elsif (grep {$_ eq $function} @{ $subcommand{CHECKOUT} }) {
264	# Check whether the last argument is a PATH.
265	# If so, check whether it is a working copy.
266	# Otherwise, check whether the current directory is a working copy.
267	# If current working direcory (or PATH) is a working copy, fail the command.
268	if (@ARGV) {
269	my $arg = Fcm::CmUrl->new (URL => $ARGV [-1]);
270	my $path = $arg->is_url ? cwd () : $ARGV [-1];
271
272	e_report $path, ': already a working copy, abort checkout.'
273	if &is_wc ($path);
274	}
275
276	# Invoke checkout
277	cm_svn ('checkout');
278
279	} elsif (grep {$_ eq $function} @{ $subcommand{COMMIT} }) {
280	cm_commit;
281
282	} elsif (grep {$_ eq $function} @{ $subcommand{CONFLICTS} }) {
283	cm_conflicts;
284
285	} elsif (grep {$_ eq $function} @{ $subcommand{DELETE} }) {
286	cm_delete;
287
288	} elsif (grep {$_ eq $function} @{ $subcommand{DIFF} }) {
289	cm_diff;
290
291	} elsif (grep {$_ eq $function} @{ $subcommand{MERGE} }) {
292	cm_merge;
293
294	} elsif (grep {$_ eq $function} @{ $subcommand{MKPATCH} }) {
295	cm_mkpatch;
296
297	} elsif (grep {$_ eq $function} @{ $subcommand{SWITCH} }) {
298	cm_switch;
299
300	} else {
301	cm_svn ($function);
302	}
303
304	}
305
306	# ------------------------------------------------------------------------------
307	# SYNOPSIS
308	# &Fcm::Cm::cm_add ();
309	#
310	# DESCRIPTION
311	# This is a wrapper to "svn add". It adds an extra functionality to check
312	# for any files or directories reported by "svn status" as not under version
313	# control, and to prompt the user whether these files or directories should
314	# be added.
315	# ------------------------------------------------------------------------------
316
317	sub cm_add {
318
319	# Print usage message if requested
320	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
321	print <<EOF;
322	usage: fcm add [options] [args]
323
324	Valid options:
325	-c [--check] : Check for any files or directories reported by svn status as
326	not under version control and add them.
327	<SVN options> : Standard options to svn add as described below ...
328
329	EOF
330
331	&run_command ([qw/svn add --help/], PRINT => 1, METHOD => 'exec');
332	}
333
334	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--check -c)) {
335	# The --check option is specified, add any new files
336	# Execute "svn status", print lines starting with a "?"
337	my $pat = '^\?.{4}\s*';
338	my @status = grep /$pat.*/, &run_command ([qw/svn status/], METHOD => 'qx');
339	print @status if @status;
340
341	# Get list of "?" files
342	my @files = map {chomp; s/$pat//; $_} @status;
343	my $reply = '';
344
345	# Execute "add" command depending on user reply
346	for my $file (@files) {
347	# Get a user reply, unless previous reply is "a" for "all"
348	$reply = &main::get_input (
349	TITLE => 'fcm add',
350	MESSAGE => "Add file '$file'?",
351	TYPE => 'yna',
352	DEFAULT => 'n',
353	) unless $reply eq "a";
354
355	# Add current $file if reply is "y" for "yes" or "a" for "all"
356	&run_command ([qw/svn add/, $file]) if $reply =~ /^[ya]$/;
357	}
358
359	} else {
360	# The --check option is not specified, just call "svn add"
361	cm_svn ("add");
362	}
363	}
364
365	# ------------------------------------------------------------------------------
366	# SYNOPSIS
367	# &Fcm::Cm::cm_branch ();
368	#
369	# DESCRIPTION
370	# This is a FCM command to check information, create or delete a branch in
371	# a Subversion repository.
372	# ------------------------------------------------------------------------------
373
374	sub cm_branch {
375	my $usage = <<EOF;
376	branch: Create, delete or display information of a branch
377	usage: 1. fcm branch [--info] [OPTIONS] [TARGET]
378	2. fcm branch --delete [OPTIONS] [TARGET]
379	3. fcm branch --create [OPTIONS] [SOURCE]
380	4. fcm branch --list [OPTIONS] [SOURCE]
381
382	1. --info or -i: Display information about a branch. This is the default
383	option if --create, --delete and --list are not specified.
384
385	2. --delete or -d: Delete a branch.
386
387	3. --create or -c: Create a new branch from SOURCE. The --name option must be
388	used to specify a short name for the new branch.
389
390	4. --list or -l: List all the branches owned by the current user in SOURCE. If
391	the --user option is specified with a list of users, list all the branches
392	owned by these users instead of the current user.
393
394	TARGET (and SOURCE) can be an URL or a Subversion working copy. Otherwise,
395	the current working directory must be a working copy. For --info and
396	--delete, the specified URL (or the URL of the working copy) must be a URL
397	under a valid branch in a standard FCM project. For --create and --list, it
398	must be a URL under a standard FCM project.
399
400	Valid options with --info and --delete:
401	-v [--verbose] : Print extra information.
402	-a [--show-all] : Set --show-children, --show-other and --show-siblings.
403	--show-children : Report children of the current branch.
404	--show-other : Report custom/ reverse merges into the current branch.
405	--show-siblings : Report merges with siblings of the current branch.
406
407	Valid options with --delete and --create:
408	--non-interactive : Do no interactive prompting. This option implies
409	--svn-non-interactive.
410	--password arg : Specify a password for write access to the repository.
411	--svn-non-interactive : Do no interactive prompting at commit time. This
412	option is implied by --non-interactive.
413
414	Valid options with --create and --list:
415	-r [--revision] arg : Specify the operative revision of the SOURCE for
416	creating the branch.
417
418	Valid options with --create:
419	--branch-of-branch : If this option is specified and the SOURCE is a
420	branch, it will create a new branch from the SOURCE
421	branch. Otherwise, the branch is created from the
422	trunk.
423	-k [--ticket] arg : Specify one (or more) Trac ticket. If specified, the
424	command will add to the commit log the line "Relates
425	to ticket #<ticket>". Multiple tickets can be set by
426	specifying this option multiple times, or by
427	specifying the tickets in a comma-separated list.
428	-n [--name] arg : Specify a short name for the branch, which should
429	contain only word characters, i.e. [A-Za-z0-9_].
430	--rev-flag arg : Specify a flag for determining the prefix of the
431	branch name. The flag can be the the string "NORMAL",
432	"NUMBER" or "NONE". "NORMAL" is the default
433	behaviour, in which the branch name will be prefixed
434	with a Subversion revision number if the revision is
435	not associated with a registered FCM revision
436	keyword. If the revision is registered with a FCM
437	revision keyword, the keyword will be used in place
438	of the number. If "NUMBER" is specified, the branch
439	name will always be prefixed with a Subversion
440	revision number. If "NONE" is specified, the branch
441	name will not be prefixed by a revision number or
442	keyword.
443	-t [--type] arg : Specify the type of the branch to be created. It must
444	be one of the following:
445	DEV::USER - a development branch for the user
446	DEV::SHARE - a shared development branch
447	DEV - same as DEV::USER
448	TEST::USER - a test branch for the user
449	TEST::SHARE - a shared test branch
450	TEST - same as TEST::USER
451	PKG::USER - a package branch for the user
452	PKG::SHARE - a shared package branch
453	PKG::CONFIG - a configuration branch
454	PKG::REL - a release branch
455	PKG - same as PKG::USER
456	CONFIG - same as PKG::CONFIG
457	REL - same as PKG::REL
458	SHARE - same as DEV::SHARE
459	USER - same as DEV::USER
460	If not specified, the default is to create a
461	development branch for the current user, i.e.
462	DEV::USER.
463
464	Valid options with --list:
465	-u [--user] arg : Specify a colon-separated list of users. List branches
466	owned by these users instead of the current user.
467	-v [--verbose] : Print Subversion URL instead of FCM URL keywords.
468	EOF
469
470	# Print usage message if requested
471	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
472	print $usage;
473	return 1;
474	}
475
476	# Process command line options
477	# ----------------------------------------------------------------------------
478	my (
479	$info,
480	$delete,
481	$create,
482	$list,
483	$branch_of_branch,
484	$name,
485	$non_interactive,
486	$password,
487	$rev,
488	$rev_flag,
489	$show_all,
490	$show_children,
491	$show_other,
492	$show_siblings,
493	$svn_non_interactive,
494	@tickets,
495	$type,
496	@userlist,
497	$verbose,
498	);
499	GetOptions (
500	'info\|i' => \$info,
501	'delete\|d' => \$delete,
502	'create\|c' => \$create,
503	'list\|l' => \$list,
504	'branch-of-branch' => \$branch_of_branch,
505	'name\|n=s' => \$name,
506	'non-interactive' => \$non_interactive,
507	'password=s' => \$password,
508	'revision\|r=s' => \$rev,
509	'rev-flag=s' => \$rev_flag,
510	'show-all\|a' => \$show_all,
511	'show-children' => \$show_children,
512	'show-other' => \$show_other,
513	'show-siblings' => \$show_siblings,
514	'svn-non-interactive' => \$svn_non_interactive,
515	'ticket\|k=s' => \@tickets,
516	'type\|t=s' => \$type,
517	'user\|u=s' => \@userlist,
518	'verbose\|v' => \$verbose,
519	);
520
521	my $num_options = 0;
522	$num_options++ if defined $info;
523	$num_options++ if defined $delete;
524	$num_options++ if defined $create;
525	$num_options++ if defined $list;
526
527	# Report invalid usage
528	# ----------------------------------------------------------------------------
529	e_report $usage if $num_options > 1;
530
531	# Get URL of repository or branch
532	# ----------------------------------------------------------------------------
533	my $url;
534	if ($ARGV[0]) {
535	$url = Fcm::CmUrl->new (URL => $ARGV[0]);
536
537	if (not $url->is_url) {
538	# An argument is specified and is not a URL
539	# Assume that it is a path with a working copy
540	if (&is_wc ($ARGV[0])) {
541	$url = Fcm::CmUrl->new (URL => &get_url_of_wc ($ARGV[0]));
542
543	} else {
544	e_report $ARGV[0], ': is not a working copy, abort.';
545	}
546	}
547
548	} else {
549	# An argument is not specified
550	# Assume that the current directory is a working copy
551	if (&is_wc ()) {
552	$url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
553
554	} else {
555	e_report 'The current directory is not a working copy, please specify a ',
556	'URL or a path to a working copy, abort.';
557	}
558	}
559
560	# Ensure $url->url_peg is a URL of a standard FCM project
561	e_report $url->url_peg, ': not a URL of a standard FCM project, abort.'
562	if not $url->project_url;
563
564	if ($create) {
565	# The --create option is specified, create a branch
566	# --------------------------------------------------------------------------
567
568	# Check branch type flags
569	if ($type) {
570	$type = uc ($type);
571
572	if ($type =~ /^(USER\|SHARE)$/) {
573	$type = 'DEV::' . $1;
574
575	} elsif ($type =~ /^(CONFIG\|REL)$/) {
576	$type = 'PKG::' . $1;
577
578	} elsif ($type =~ /^(DEV\|TEST\|PKG)$/) {
579	$type = $1 . '::USER';
580
581	} elsif ($type !~ /^(?:DEV\|TEST\|PKG)::(?:USER\|SHARE)$/ and
582	$type !~ /^PKG::(?:CONFIG\|REL)/) {
583	e_report $type, ': is not a valid type flag, abort.';
584	}
585
586	} else {
587	$type = 'DEV::USER';
588	}
589
590	# Check branch name
591	e_report 'The option --name must be used to specify a branch name, abort.'
592	if not $name;
593
594	e_report $name, ': invalid characters in name, abort.' if $name !~ /^\w+$/;
595
596	# Check revision flag is valid
597	if ($rev_flag) {
598	$rev_flag = uc ($rev_flag);
599
600	e_report $rev_flag, ': invalid argument to the --rev-flag option, abort.'
601	if $rev_flag !~ /^(?:NORMAL\|NUMBER\|NONE)$/;
602
603	} else {
604	$rev_flag = 'NORMAL';
605	}
606
607	# Handle multiple tickets
608	@tickets = split (/,/, join (',', @tickets));
609	s/^#// for (@tickets);
610	@tickets = sort {$a <=> $b} @tickets;
611
612	# Determine whether to create a branch of a branch
613	$url->branch ('trunk') unless $branch_of_branch;
614
615	# Create the branch
616	my $branch = Fcm::CmBranch->new;
617	$branch->create (
618	SRC => $url,
619	TYPE => $type,
620	NAME => $name,
621	PASSWORD => $password,
622	REV_FLAG => $rev_flag,
623	TICKET => \@tickets,
624	REV => $rev,
625	NON_INTERACTIVE => $non_interactive,
626	SVN_NON_INTERACTIVE => $svn_non_interactive,
627	);
628
629	} elsif ($list) {
630	# The option --list is specified
631	# List branches owned by current or specified users
632	# --------------------------------------------------------------------------
633	# Get URL of the project "branches/" sub-directory
634	$url->subdir ('');
635	$url->branch ('');
636	my @list = map {$_, 1} $url->branch_list ($rev);
637
638	if (@userlist) {
639	# Sort list of users
640	@userlist = sort (split /:/, join (':', @userlist));
641
642	} else {
643	# No user specified, add currrent user to list
644	push @userlist, $ENV{LOGNAME} unless @userlist;
645	}
646
647	# Filter branches matching user list
648	my @branches;
649	for my $branch (@list) {
650	next unless $branch =~ m#/([^/]+)/[^/]+/*$#;
651
652	my $user = $1;
653
654	push @branches, $branch if grep {$user eq $_} @userlist;
655	}
656
657	# Output, number of branches found
658	print scalar (@branches), ' ',
659	(scalar (@branches) > 1 ? 'branches' : 'branch'), ' found for ',
660	join (', ', @userlist), ' in ', $url->project_url_peg,
661	($rev ? (' at r', $rev) : ()), "\n";
662
663	if (@branches) {
664	# Output the URL of each branch
665	if (not $verbose) {
666	my $project = $url->project_url;
667	my $keyword = &get_url_keyword (URL => $project);
668	@branches = map {s#^$project/+branches#$keyword-br#; $_} @branches
669	if defined $keyword;
670	}
671	@branches = map {$_ . "\n"} sort @branches;
672	print @branches;
673
674	} else {
675	# No branch found, exit with an error code
676	exit 1;
677	}
678
679	} else {
680	# The option --info or --delete is specified
681	# Report branch information (and/or delete a branch)
682	# --------------------------------------------------------------------------
683	# Set verbose level
684	&main::cfg->verbose ($verbose ? 1 : 0);
685
686	# Set up the branch, report any error
687	my $branch = Fcm::CmBranch->new (URL => $url->url_peg);
688	e_report $branch->url_peg, ': not a branch, abort.' unless $branch->branch;
689
690	e_report $branch->url_peg, ': does not exist, abort.'
691	unless $branch->url_exists;
692
693	# Remove the sub-directory part of the URL
694	$branch->subdir ('');
695
696	# Report branch info
697	$branch->display_info (
698	SHOW_CHILDREN => ($show_all \|\| $show_children),
699	SHOW_OTHER => ($show_all \|\| $show_other ),
700	SHOW_SIBLINGS => ($show_all \|\| $show_siblings),
701	);
702
703	# Delete branch if --delete is specified
704	$branch->del (
705	PASSWORD => $password,
706	NON_INTERACTIVE => $non_interactive,
707	SVN_NON_INTERACTIVE => $svn_non_interactive,
708	) if $delete;
709	}
710
711	}
712
713	# ------------------------------------------------------------------------------
714	# SYNOPSIS
715	# &Fcm::Cm::cm_commit ();
716	#
717	# DESCRIPTION
718	# This is a FCM wrapper to the "svn commit" command.
719	# ------------------------------------------------------------------------------
720
721	sub cm_commit {
722
723	# Print usage message if requested
724	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
725	print <<EOF;
726	commit (ci): Send changes from your working copy to the repository.
727	usage: fcm commit [PATH]
728
729	Invoke your favourite editor to prompt you for a commit log message. Send
730	changes from your working copy to the repository. Update your working copy
731	following the commit.
732
733	Valid options:
734	--dry-run : Allows you to add to the commit message without
735	committing.
736	--svn-non-interactive : Do no interactive prompting at commit time.
737	--password arg : Specify a password ARG.
738	EOF
739	return 1;
740	}
741
742	my ($dry_run, $svn_non_interactive, $password);
743	GetOptions (
744	'dry-run' => \$dry_run,
745	'svn-non-interactive' => \$svn_non_interactive,
746	'password' => \$password,
747	);
748
749	# The remaining argument is the path to a working copy
750	my ($path) = @ARGV;
751
752	if ($path) {
753	# Check that specified path exists
754	e_report $path, ': does not exist, abort.' if not -e $path;
755
756	} else {
757	# No argument specified, use current working directory
758	$path = cwd ();
759	}
760
761	# Make sure we are in a working copy
762	e_report $path, ': not a working copy, abort.' if not &is_wc ($path);
763
764	# Make sure we are at the top level of the working copy
765	# (otherwise we might miss any template commit message)
766	my $dir = &get_wct ($path);
767
768	if ($dir ne cwd ()) {
769	chdir $dir or die 'Cannot change directory to: ', $dir;
770	print 'Committing changes from ', $dir, ' ...', "\n";
771	}
772
773	# Get update status of working copy
774	# Check working copy files are not in conflict, missing, or out of date
775	my @status = &run_command ([qw/svn status --show-updates/], METHOD => 'qx');
776	unless (defined $dry_run) {
777	my (@conflict, @missing, @outdate);
778
779	for (@status) {
780	if (/^C/) {
781	push @conflict, $_;
782	next;
783	}
784
785	if (/^!/) {
786	push @missing, $_;
787	next;
788	}
789
790	if (/^.{7}\*/) {
791	push @outdate, $_;
792	next;
793	}
794
795	# Check that all files which have been added have the svn:executable
796	# property set correctly (in case the developer adds a script before they
797	# remember to set the execute bit)
798	next unless /^A.{7} \d+ +(.)/;
799	my $file = $1;
800
801	next unless -f $file;
802	my @command = (-x $file)
803	? (qw/svn propset -q svn:executable */, $file)
804	: (qw/svn propdel -q svn:executable/ , $file);
805	&run_command (\@command);
806	}
807
808	# Abort commit if files are in conflict, missing, or out of date
809	if (@conflict or @missing or @outdate) {
810	w_report 'File(s) in conflict:', "\n", @conflict if @conflict;
811	w_report 'File(s) missing:' , "\n", @missing if @missing;
812	w_report 'File(s) out of date:', "\n", @outdate if @outdate;
813	e_report 'Abort commit.';
814	}
815	}
816
817	# Read in any existing message
818	my $ci_mesg = Fcm::CmCommitMessage->new ();
819	$ci_mesg->read_file;
820
821	# Execute "svn status" for a list of changed items
822	@status = grep !/^\?/, &run_command ([qw/svn status/], METHOD => 'qx');
823
824	# Abort if there is no change in the working copy
825	if (not @status) {
826	print 'No change in working copy, abort.', "\n";
827	return;
828	}
829
830	# Get associated URL of current working copy
831	my $url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
832
833	# Include URL, or project, branch and sub-directory info in @status
834	unshift @status, "\n";
835
836	if ($url->project and $url->branch) {
837	unshift @status, (
838	'[Project: ' . $url->project . ']' . "\n",
839	'[Branch : ' . $url->branch . ']' . "\n",
840	'[Sub-dir: ' . ($url->subdir ? $url->subdir : '<top>') . ']' . "\n",
841	);
842
843	} else {
844	unshift @status, '[URL: ' . $url->url . ']' . "\n";
845	}
846
847	# Use a temporary file to store the final commit log message
848	$ci_mesg->ignore_mesg (@status);
849	my $logfile = $ci_mesg->edit_file (TEMP => 1);
850
851	# Check with the user to see if he/she wants to go ahead
852	my $reply = 'n';
853	if (not defined $dry_run) {
854	# Add extra warning for trunk commit
855	my $mesg = $url->is_trunk
856	? "\n" .
857	'*** WARNING: YOU ARE COMMITTING TO THE TRUNK.' . "\n" .
858	'*** Please ensure that your change conforms to your project\'s ' .
859	'working practices.' . "\n\n"
860	: '';
861	$mesg .= 'Would you like to commit this change?';
862
863	# Prompt the user
864	$reply = &main::get_input (
865	TITLE => 'fcm commit',
866	MESSAGE => $mesg,
867	TYPE => 'yn',
868	DEFAULT => 'n',
869	);
870	}
871
872	if ($reply eq 'y') {
873	# Commit the change if user replies "y" for "yes"
874	my @command = (
875	qw/svn commit -F/, $logfile,
876	($svn_non_interactive ? '--non-interactive' : ()),
877	(defined $password ? ('--password', $password) : ()),
878	);
879	my $rc;
880	&run_command (\@command, RC => \$rc, ERROR => 'warn');
881
882	if ($rc) {
883	# Commit failed
884	# Write temporary commit log content to commit log message file
885	$ci_mesg->write_file;
886
887	# Fail the command
888	e_report;
889	}
890
891	# Remove commit message file
892	unlink $ci_mesg->file;
893
894	# Update the working copy
895	print 'Performing update to make sure your working copy is at this new ',
896	'revision ...', "\n";
897	&run_command ([qw/svn update/]);
898
899	} else {
900	# Abort commit if dry run or user replies "n" for "no"
901	w_report 'Commit aborted by user.' unless $dry_run;
902
903	# Write temporary commit log content to commit log message file
904	$ci_mesg->write_file;
905	}
906
907	return;
908	}
909
910	# ------------------------------------------------------------------------------
911	# SYNOPSIS
912	# &Fcm::Cm::cm_conflicts ();
913	#
914	# DESCRIPTION
915	# This is a FCM command for resolving conflicts within working copy using a
916	# graphical merge tool.
917	# ------------------------------------------------------------------------------
918
919	sub cm_conflicts {
920
921	# Print usage message if requested
922	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
923	print <<EOF;
924	conflicts: Use graphical tool to resolve any conflicts within your working copy.
925	usage: fcm conflicts [PATH]
926
927	Invoke the xxdiff graphical merge tool to help you resolve conflicts in your
928	working copy. It prompts you to run "svn resolved" each time you have
929	resolved the conflicts in a file.
930	EOF
931	return 1;
932	}
933
934	# Path to the working copy
935	my $path = $ARGV[0];
936	$path = cwd () if not $path;
937
938	# Check for any files with conflicts
939	my @status = grep /^C.{4} (.)/, &run_command (
940	[qw/svn st/, ($path eq cwd () ? () : $path)], METHOD => 'qx',
941	);
942	my @files = map {m/^C.{4} (.)/; $1} @status;
943
944	# Save current working directory
945	my $topdir = cwd ();
946
947	for my $file (@files) {
948	# Print name of file in conflicts
949	print "Conflicts in file: $file\n";
950
951	# Determine directory and base name of file in conflicts
952	my $base = basename $file;
953	my $dir = dirname $file;
954
955	# Change to container directory of file in conflicts
956	chdir File::Spec->catfile ($topdir, $dir) or die "Directory change to $dir failed";
957
958	# Use "svn info" to determine conflict marker files
959	my @info = &run_command ([qw/svn info/, $base], METHOD => 'qx');
960
961	# Ignore if $base is a binary file
962	if (-B $base) {
963	w_report $base,
964	': ignoring binary file, please resolve conflicts manually.';
965	next;
966	}
967
968	# Get conflicts markers files
969	my ($older, $mine, $yours);
970
971	for (@info) {
972	$older = $1 if (/^Conflict Previous Base File: (.*)/);
973	$mine = $1 if (/^Conflict Previous Working File: (.*)/);
974	$yours = $1 if (/^Conflict Current Base File: (.*)/);
975	}
976
977	if ((stat $base)[9] > (stat $mine)[9]) {
978	# If $base is newer, it may contain saved changes
979	my $reply = &main::get_input (
980	TITLE => 'fcm conflicts',
981	MESSAGE => 'Existing changes in ' . $base . ' will be overwritten.' .
982	"\n" . 'Do you wish to continue?',
983	TYPE => 'yn',
984	DEFAULT => 'n',
985	);
986
987	next if $reply ne 'y';
988	}
989
990	# Launch "xxdiff" to allow user to perform graphical merging
991	my $xxdiffrc;
992	my @command = (qw/xxdiff -m -M/, $base, qw/-O -X/, $mine, $older, $yours);
993	my ($decision) = &run_command (
994	\@command, METHOD => 'qx', RC => \$xxdiffrc, ERROR => 'ignore',
995	);
996	die &get_command_string (\@command), ' failed' if $xxdiffrc and ! $decision;
997	chomp $decision;
998
999	# Perform different actions depending on the user's decision
1000	if ($decision eq "NODECISION") {
1001	print "No decision taken\n";
1002
1003	} elsif ($decision eq "MERGED" and $xxdiffrc != 0) {
1004	print "Merge conflicts were not all resolved\n";
1005
1006	} else {
1007	# User has MERGED, ACCEPTED or REJECTED all changes
1008	if ($decision eq "MERGED") {
1009	print "All merge conflicts resolved\n";
1010
1011	} else {
1012	print "You have chosen to $decision all the changes\n";
1013	}
1014
1015	# Prompt user to run "svn resolved" on the file
1016	my $reply = &main::get_input (
1017	TITLE => 'fcm conflicts',
1018	MESSAGE => 'Would you like to run "svn resolved"?',
1019	TYPE => 'yn',
1020	DEFAULT => 'n',
1021	);
1022
1023	# If reply is "yes"...
1024	&run_command ([qw/svn resolved/, $base]) if $reply eq 'y';
1025	}
1026	}
1027	}
1028
1029	# ------------------------------------------------------------------------------
1030	# SYNOPSIS
1031	# &Fcm::Cm::cm_delete ();
1032	#
1033	# DESCRIPTION
1034	# This is a wrapper to "svn delete". It adds an extra functionality to check
1035	# for any files or directories reported by "svn status" as missing, and to
1036	# prompt the user whether these files or directories should be deleted.
1037	# ------------------------------------------------------------------------------
1038
1039	sub cm_delete {
1040
1041	# Print usage message if requested
1042	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1043	print <<EOF;
1044	usage: fcm delete [options] [args]
1045
1046	Valid options:
1047	-c [--check] : Check for any files or directories reported by svn status as
1048	missing and delete them.
1049	<SVN options> : Standard options to svn delete as described below ...
1050
1051	EOF
1052
1053	&run_command ([qw/svn delete --help/], PRINT => 1, METHOD => 'exec');
1054	}
1055
1056	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--check -c)) {
1057	# The --check option is specified, delete any missing files
1058	# Execute "svn status", print lines starting with a "!"
1059	my $pat = '^!.{4}\s*';
1060	my @status = grep /$pat.*/, &run_command ([qw/svn status/], METHOD => 'qx');
1061	print @status if @status;
1062
1063	# Get list of "!" files
1064	my @files = map {chomp; s/$pat//; $_} @status;
1065	my $reply = '';
1066
1067	# Execute "delete" command depending on user reply
1068	for my $file (@files) {
1069	# Get a user reply, unless previous reply is "a" for "all"
1070	$reply = &main::get_input (
1071	TITLE => 'fcm delete',
1072	MESSAGE => "Delete file '$file'?",
1073	TYPE => 'yna',
1074	DEFAULT => 'n',
1075	) unless $reply eq "a";
1076
1077	# Delete current $file if reply is "y" for "yes" or "a" for "all"
1078	&run_command ([qw/svn delete/, $file]) if $reply =~ /^[ya]$/;
1079	}
1080
1081	} else {
1082	# The --check option is not specified, just call "svn delete"
1083	cm_svn ("delete");
1084	}
1085	}
1086
1087	# ------------------------------------------------------------------------------
1088	# SYNOPSIS
1089	# &Fcm::Cm::cm_diff ();
1090	#
1091	# DESCRIPTION
1092	# This is a wrapper to "svn diff". It adds two extra functionalities. The
1093	# first one allows the command to show differences relative to the base of
1094	# the branch. The second one allows differences to be displayed via a
1095	# graphical tool.
1096	# ------------------------------------------------------------------------------
1097
1098	sub cm_diff {
1099
1100	# Print usage message if requested
1101	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1102	print <<EOF;
1103	usage: 1. fcm diff --branch [OPTIONS] [TARGET]
1104	2. fcm diff [OPTIONS] [ARGS]
1105
1106	1. --branch or -b: Show differences relative to the base of the target branch,
1107	i.e. the changes available for merging from the target branch into its
1108	parent. If TARGET is specified, it must either be a URL or a working copy.
1109	Otherwise, the target is the the current directory which must be a working
1110	copy. The target URL must be a branch in a standard FCM project.
1111
1112	2. See description of "svn diff" below.
1113
1114	Valid options:
1115	-g [--graphical] : Use a graphical diff tool to display the differences. This
1116	option should not be used in combination with --diff-cmd.
1117	<SVN options> : Standard options to "svn diff" as described below.
1118
1119	Valid options with --branch:
1120	--diff-cmd arg : As described below in the help for "svn diff".
1121	-g [--graphical] : As described above.
1122	-t [--trac] : If TARGET is a URL, use Trac to display the diff.
1123	--wiki : If TARGET is a URL, print Trac link for the diff.
1124	-x [--extensions] arg : As described below in the help for "svn diff".
1125
1126	EOF
1127
1128	&run_command ([qw/svn diff --help/], PRINT => 1, METHOD => 'exec');
1129	}
1130
1131	# Set up environment for graphical diff
1132	# Use environment variable if set, otherwise use default setting
1133	my $env = 'FCM_GRAPHIC_DIFF';
1134	$ENV{$env} = &main::cfg->setting (qw/TOOL GRAPHIC_DIFF/)
1135	unless exists $ENV{$env} or not &main::cfg->setting (qw/TOOL GRAPHIC_DIFF/);
1136
1137	# Check for the --branch options
1138	# ----------------------------------------------------------------------------
1139	my $branch = grep {$_ eq '-b' or $_ eq '--branch'} @ARGV;
1140
1141	if (not $branch) {
1142	# The --branch option not specified, just call "svn diff"
1143	# Convert the --graphical to qw/--diff-cmd fcm_graphical_diff/
1144	@ARGV = map {
1145	($_ eq '-g' or $_ eq '--graphical')
1146	? (qw/--diff-cmd fcm_graphic_diff/)
1147	: $_
1148	} @ARGV;
1149
1150	# Execute the command
1151	cm_svn ('diff');
1152	}
1153
1154	# The --branch option is specified
1155	# ----------------------------------------------------------------------------
1156
1157	# Determine whether the --graphical option is specified,
1158	# if so set the appropriate command
1159	# ----------------------------------------------------------------------------
1160	my ($diff_cmd, $extensions, $graphical, $trac, $wiki);
1161	GetOptions (
1162	'b\|branch' => \$branch,
1163	'diff-cmd=s' => \$diff_cmd,
1164	'x\|extensions=s' => \$extensions,
1165	'g\|graphical' => \$graphical,
1166	't\|trac' => \$trac,
1167	'wiki' => \$wiki,
1168	);
1169
1170	my @diff_cmd = ();
1171
1172	if ($graphical) {
1173	@diff_cmd = (qw/--diff-cmd fcm_graphic_diff/);
1174
1175	} elsif ($diff_cmd) {
1176	@diff_cmd = ('--diff-cmd', $diff_cmd);
1177
1178	push @diff_cmd, '--extensions', split (/\s+/, $extensions) if $extensions;
1179	}
1180
1181	# The remaining argument should either be a URL or a PATH
1182	my ($url_arg, $path_arg);
1183
1184	if (@ARGV) {
1185	my $arg = Fcm::CmUrl->new (URL => $ARGV[0]);
1186
1187	if ($arg->is_url) {
1188	$url_arg = $ARGV[0];
1189
1190	} else {
1191	$path_arg = $ARGV[0];
1192	}
1193	}
1194
1195	# Get repository and branch information
1196	# ----------------------------------------------------------------------------
1197	my ($url, $path);
1198	if (defined $url_arg) {
1199	# If a URL is specified, get repository and branch information from it
1200	$url = Fcm::CmBranch->new (URL => $url_arg);
1201
1202	} else {
1203	# Get repository and branch information from the specified path or the
1204	# current directory if it is a working copy
1205	$path = $path_arg ? $path_arg : cwd ();
1206	e_report $path, ': not a working copy, abort.' unless &is_wc ($path);
1207
1208	$url = Fcm::CmBranch->new (URL => &get_url_of_wc ($path));
1209	}
1210
1211	# Check that URL is a standard FCM branch
1212	e_report $url->url_peg, ': not a standard FCM branch, abort.'
1213	unless $url->is_branch;
1214
1215	# Save and remove sub-directory part of the URL
1216	my $subdir = $url->subdir ();
1217	$url->subdir ('');
1218
1219	# Check that $url exists
1220	e_report $url->url_peg, ': not a valid URL, abort.' unless $url->url_exists;
1221
1222	# Compare current branch with its parent
1223	# ----------------------------------------------------------------------------
1224	my $parent = Fcm::CmBranch->new (URL => $url->parent->url);
1225	$parent->pegrev ($url->pegrev) if $url->pegrev;
1226
1227	e_report $parent->url, ': branch parent no longer exists',
1228	($parent->pegrev ? ' at ' . $parent->pegrev : ''), ', abort.'
1229	unless $parent->url_exists;
1230
1231	my $base = $parent->base_of_merge_from ($url);
1232
1233	# Ensure the correct diff (syntax) is displayed
1234	# ----------------------------------------------------------------------------
1235	# Reinstate the sub-tree part into the URL
1236	$url->subdir ($subdir);
1237	$base->subdir ($subdir);
1238
1239	# Ensure the branch URL has a peg revision
1240	$url->pegrev ($url->svninfo (FLAG => 'Last Changed Rev')) if not $url->pegrev;
1241
1242	if ($trac or $wiki) {
1243	# Trac/wiki
1244	# --------------------------------------------------------------------------
1245	if (not $url_arg) {
1246	if (&run_command ([qw/svn status/], METHOD => 'qx')) {
1247	w_report 'WARNING: the working copy at "', ($path_arg ? $path_arg : '.'),
1248	'" contains local changes, which cannot be displayed in Trac.';
1249	}
1250	}
1251
1252	# Trac wiki syntax
1253	my $wiki_syntax = 'diff:' . $base->path_peg . '//' . $url->path_peg;
1254
1255	if ($wiki) {
1256	# Print Trac wiki syntax only
1257	print $wiki_syntax, "\n";
1258
1259	} else { # if $trac
1260	# Use Trac to view "diff"
1261	my $browser = &main::cfg->setting (qw/MISC WEB_BROWSER/);
1262	die 'ERROR: web browser not set, abort' if not $browser;
1263
1264	my $trac_url = &get_browser_url (URL => $url->project_url);
1265	e_report 'ERROR: ', $url->project_url,
1266	': not associated with a Trac URL, abort.'
1267	if not $trac_url;
1268
1269	$trac_url =~ s#/browser/.*$#/intertrac/$wiki_syntax#;
1270
1271	&run_command ([$browser, $trac_url], METHOD => 'exec', PRINT => 1);
1272	}
1273
1274	} else {
1275	# Execute the "diff" command
1276	# --------------------------------------------------------------------------
1277	my @command = (
1278	qw/svn diff/, @diff_cmd,
1279	'--old', $base->url_peg,
1280	'--new', ($url_arg ? $url->url_peg : ($path_arg ? $path_arg : '.')),
1281	);
1282	&run_command (\@command, PRINT => 1);
1283	}
1284	}
1285
1286	# ------------------------------------------------------------------------------
1287	# SYNOPSIS
1288	# &Fcm::Cm::cm_merge ();
1289	#
1290	# DESCRIPTION
1291	# This is a wrapper to "svn merge".
1292	# ------------------------------------------------------------------------------
1293
1294	sub cm_merge {
1295
1296	# Print usage message if requested
1297	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1298	print <<EOF;
1299	merge: Merge changes from a source into your working copy.
1300	usage: 1. fcm merge SOURCE
1301	2. fcm merge --custom --revision N[:M] SOURCE
1302	fcm merge --custom URL[\@REV1] URL[\@REV2]
1303	3. fcm merge --reverse --revision [M:]N
1304
1305	1. If neither --custom nor --reverse is specified, the command merges changes
1306	automatically from SOURCE into your working copy. SOURCE must be a valid
1307	URL[\@REV] of a branch in a standard FCM project. The base of the merge
1308	will be calculated automatically based on the common ancestor and latest
1309	merge information between the SOURCE and the branch of the working copy.
1310
1311	2. If --custom is specified, the command can be used in two forms.
1312
1313	In the first form, it performs a custom merge from the specified
1314	changeset(s) of SOURCE into your working copy. SOURCE must be a valid
1315	URL[\@REV] of a branch in a standard FCM project. If a single revision is
1316	specified, the merge delta is (N - 1):N of SOURCE. Otherwise, the merge
1317	delta, is N:M of SOURCE, where N < M.
1318
1319	In the second form, it performs a custom merge using the delta between the
1320	two specified branch URLs. For each URL, if a peg revision is not
1321	specified, the command will peg the URL with its last changed revision.
1322
1323	3. If --reverse is specified, the command performs a reverse merge of the
1324	changeset(s) specified by the --revision option. If a single revision is
1325	specified, the merge delta is N:(N - 1). Otherwise, the merge delta is
1326	M:N, where M > N. Note that you do not have to specify a SOURCE for a
1327	reverse merge, because the SOURCE should always be the branch your working
1328	copy is pointing to.
1329
1330	The command provide a commit log message template following the merge.
1331
1332	Valid options:
1333	--dry-run : Try operation but make no changes.
1334	--non-interactive : Do no interactive prompting.
1335	-r [--revision] arg: Specify a (range of) revision number(s).
1336	--verbose : Print extra information.
1337	EOF
1338	return 1;
1339	}
1340
1341	# Options
1342	# ----------------------------------------------------------------------------
1343	my ($custom, $dry_run, $non_interactive, $reverse, $rev, $verbose);
1344	GetOptions (
1345	'custom' => \$custom,
1346	'dry-run' => \$dry_run,
1347	'non-interactive' => \$non_interactive,
1348	'reverse' => \$reverse,
1349	'revision\|r=s' => \$rev,
1350	'verbose\|v' => \$verbose,
1351	);
1352
1353	# Find out the URL of the working copy
1354	# ----------------------------------------------------------------------------
1355	my ($target, $wct);
1356	if (&is_wc ()) {
1357	$wct = &get_wct ();
1358
1359	if ($wct ne cwd ()) {
1360	print 'Change directory to top of working copy: ', $wct, "\n";
1361	chdir $wct or die 'Cannot change directory to: ', $wct;
1362	}
1363
1364	$target = Fcm::CmBranch->new (URL => &get_url_of_wc ($wct));
1365
1366	} else {
1367	e_report 'The current directory is not a working copy, abort.';
1368	}
1369
1370	e_report 'Your working copy URL does not exist at the HEAD revision, abort.'
1371	unless $target->url_exists;
1372
1373	# The target must be at the top of a branch
1374	# $subdir will be used later to determine whether the merge is allowed or not
1375	my $subdir = $target->subdir;
1376	$target->subdir ('') if $subdir;
1377
1378	# Check for any local modifications
1379	# ----------------------------------------------------------------------------
1380	return
1381	if ! ($dry_run or $non_interactive) and &_abort_modified_wc ('fcm merge');
1382
1383	# Determine the SOURCE URL
1384	# ----------------------------------------------------------------------------
1385	my $source;
1386
1387	if ($reverse) {
1388	# Reverse merge, the SOURCE is the the working copy URL
1389	$source = Fcm::CmBranch->new (URL => $target->url);
1390
1391	} else {
1392	# Automatic/custom merge, argument 1 is the SOURCE of the merge
1393	my $source_url = shift (@ARGV);
1394	e_report 'Error: argument 1 must be the URL/name of a source branch in ',
1395	'automatic/custom mode, abort.'
1396	if not $source_url;
1397
1398	$source = &_construct_branch_url ($source_url, $target);
1399	}
1400
1401	# Parse the revision option
1402	# ----------------------------------------------------------------------------
1403	my @revs;
1404	if ($reverse or $custom) {
1405	if ($reverse and not $rev) {
1406	e_report 'Error: a revision (range) must be specified with ',
1407	'--revision in reverse mode, abort.'
1408	}
1409
1410	@revs = split (/:/, $rev) if $rev;
1411	}
1412
1413	# Determine the merge delta and the commit log message
1414	# ----------------------------------------------------------------------------
1415	my (@delta, $mesg);
1416	my $separator = '-' x 80 . "\n";
1417
1418	if ($reverse) {
1419	# Reverse merge
1420	# --------------------------------------------------------------------------
1421	if (@revs == 1) {
1422	$revs[1] = ($revs[0] - 1);
1423
1424	} else {
1425	@revs = sort {$b <=> $a} @revs;
1426	}
1427
1428	$source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
1429	unless $source->pegrev;
1430	$source->subdir ($subdir);
1431
1432	# "Delta" of the "svn merge" command
1433	@delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
1434
1435	# Template message
1436	$mesg = 'Reversed r' . $revs[0] .
1437	(($revs[1] < $revs[0] - 1) ? ':' . $revs[1] : '') . ' of ' .
1438	$source->path . "\n";
1439
1440	} elsif ($custom) {
1441	# Custom merge
1442	# --------------------------------------------------------------------------
1443	if (@revs) {
1444	# Revision specified
1445	# ------------------------------------------------------------------------
1446	# Only one revision N specified, use (N - 1):N as the delta
1447	unshift @revs, ($revs[0] - 1) if @revs == 1;
1448
1449	$source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
1450	unless $source->pegrev;
1451	$source->subdir ($subdir);
1452	$target->subdir ($subdir);
1453
1454	# "Delta" of the "svn merge" command
1455	@delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
1456
1457	# Template message
1458	$mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] .
1459	' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n";
1460
1461	} else {
1462	# Revision not specified
1463	# ------------------------------------------------------------------------
1464	# Get second source URL
1465	my $source2_url = shift (@ARGV);
1466	e_report 'Error: argument 2 must be the URL/name of a source branch in ',
1467	'custom mode when --revision is not specified, abort.'
1468	if not $source2_url;
1469
1470	my $source2 = &_construct_branch_url ($source2_url, $target);
1471
1472	$source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
1473	unless $source->pegrev;
1474	$source2->pegrev ($source2->svninfo (FLAG => 'Last Changed Rev'))
1475	unless $source2->pegrev;
1476	$source->subdir ($subdir);
1477	$source2->subdir ($subdir);
1478	$target->subdir ($subdir);
1479
1480	# "Delta" of the "svn merge" command
1481	@delta = ($source->url_peg, $source2->url_peg);
1482
1483	# Template message
1484	$mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg .
1485	' cf. ' . $source2->path_peg . "\n";
1486	}
1487
1488	} else {
1489	# Automatic merge
1490	# --------------------------------------------------------------------------
1491	# Check to ensure source branch is not the same as the target branch
1492	e_report 'Error: cannot merge ', $source->branch,
1493	' to its own working copy, abort.'
1494	if $source->branch eq $target->branch;
1495
1496	# Only allow the merge if the source and target are "directly related"
1497	# --------------------------------------------------------------------------
1498	my $anc = $target->ancestor ($source);
1499	e_report 'Error: source and target are not directly related' unless
1500	($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg)
1501	or
1502	($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg)
1503	or
1504	($anc->url eq $source->parent->url and $anc->url eq $target->parent->url);
1505
1506	# Check for available merges from the source
1507	# --------------------------------------------------------------------------
1508	my @revs = $target->avail_merge_from ($source, 1);
1509
1510	if (@revs) {
1511	print 'Available Merge', (@revs > 1 ? 's' : ''), ' From ',
1512	$source->path_peg, ':';
1513
1514	if ($verbose) {
1515	# Verbose mode, print log messages of available merges
1516	print "\n";
1517
1518	for (@revs) {
1519	print $separator, $source->display_svnlog ($_);
1520	}
1521
1522	print $separator;
1523
1524	} else {
1525	# Normal mode, list revisions of available merges
1526	print ' ', join (' ', @revs), "\n";
1527	}
1528
1529	} else {
1530	w_report 'No merge available from ', $source->path_peg, ', abort.';
1531	return;
1532	}
1533
1534	# If more than one merge available, prompt user to enter a revision number
1535	# to merge from, default to $revs [0]
1536	# --------------------------------------------------------------------------
1537	my $reply = ($non_interactive or @revs == 1) ? $revs[0] : &main::get_input (
1538	TITLE => 'fcm merge',
1539	MESSAGE => 'Please enter the revision you wish to merge from',
1540	DEFAULT => $revs [0],
1541	);
1542
1543	if (not defined ($reply)) {
1544	w_report 'Merge aborted by user.';
1545	return;
1546	}
1547
1548	# Expand revision keyword if necessary
1549	if ($reply) {
1550	$reply = expand_rev_keyword (REV => $reply, URL => $target->project_url);
1551	}
1552
1553	# Check that the reply is a number in the available merges list
1554	e_report $reply, ': not a revision in the list of available merges.'
1555	unless (grep {$_ == $reply} @revs);
1556
1557	$source->pegrev ($1) if ($reply =~ /^(\d+)/);
1558
1559	# If the working copy top is pointing to a sub-directory of a branch,
1560	# we need to check whether the merge will result in losing changes made in
1561	# other sub-directories of the source.
1562	if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) {
1563	e_report 'SOURCE contains changes outside the current sub-directory.', "\n",
1564	'Please use a full tree for the merge, abort.';
1565	}
1566
1567	# Calculate the base of the merge
1568	my $base = $target->base_of_merge_from ($source);
1569
1570	# $source and $base must take into account the sub-directory
1571	my $s = Fcm::CmBranch->new (URL => $source->url_peg);
1572	my $b = Fcm::CmBranch->new (URL => $base->url_peg);
1573
1574	$s->subdir ($subdir) if $subdir;
1575	$b->subdir ($subdir) if $subdir;
1576
1577	# Diagnostic
1578	print 'About to merge in changes from ', $s->path_peg, ' compared with ',
1579	$b->path_peg, "\n";
1580
1581	# Delta of the "svn merge" command
1582	@delta = ($b->url_peg, $s->url_peg);
1583
1584	# Template message
1585	$mesg = 'Merged into ' . $target->path . ': ' . $source->path_peg .
1586	' cf. ' . $base->path_peg . "\n";
1587	}
1588
1589	# Run "svn merge" in "--dry-run" mode to see the result
1590	# ----------------------------------------------------------------------------
1591	my @out = &run_command (
1592	[qw/svn merge --dry-run/, @delta],
1593	METHOD => 'qx', PRINT => ($dry_run and $verbose),
1594	);
1595
1596	# Abort merge if it will result in no change
1597	if (not @out) {
1598	print 'This merge will not result in any change, abort.', "\n";
1599	return;
1600	}
1601
1602	# Report result of "svn merge --dry-run"
1603	if (not $non_interactive) {
1604	print 'This merge will result in the following change',
1605	(@out > 1 ? 's' : ''), ':', "\n";
1606	print $separator, @out, $separator;
1607	}
1608
1609	return if $dry_run;
1610
1611	# Prompt the user to see if (s)he would like to go ahead
1612	# ----------------------------------------------------------------------------
1613	my $reply = $non_interactive ? 'y' : &main::get_input (
1614	TITLE => 'fcm merge',
1615	MESSAGE => 'Would you like to go ahead with the merge?',
1616	TYPE => 'yn',
1617	DEFAULT => 'n',
1618	);
1619
1620	# Go ahead with merge only if user replies "y"
1621	if ($reply eq "y") {
1622	print "Performing merge ...\n";
1623	&run_command ([qw/svn merge/, @delta], PRINT => $verbose);
1624
1625	} else {
1626	w_report 'Merge aborted by user.';
1627	return;
1628	}
1629
1630	# Prepare the commit log
1631	# ----------------------------------------------------------------------------
1632	# Read in any existing message
1633	my $ci_mesg = Fcm::CmCommitMessage->new;
1634	$ci_mesg->read_file;
1635	$ci_mesg->auto_mesg ($mesg, ($ci_mesg->auto_mesg));
1636	$ci_mesg->write_file;
1637
1638	if ($verbose) {
1639	print <<EOF;
1640	${separator}The following line has been added to your commit message file:
1641	$mesg
1642	EOF
1643	}
1644
1645	return;
1646	}
1647
1648	# ------------------------------------------------------------------------------
1649	# SYNOPSIS
1650	# &Fcm::Cm::cm_mkpatch ();
1651	#
1652	# DESCRIPTION
1653	# This is a FCM command to create a patching script from particular revisions
1654	# of a URL.
1655	# ------------------------------------------------------------------------------
1656
1657	sub cm_mkpatch {
1658	my $usage = <<EOF;
1659	mkpatch: Create patches from specified revisions of a URL
1660	usage: fcm mkpatch [OPTIONS] URL [OUTDIR]
1661
1662	URL must be the URL of a branch in a FCM project. If the URL is a
1663	sub-directory of a branch, it will use the root of the branch.
1664
1665	Create patches from specified revisions of the specified URL. If OUTDIR is
1666	specified, the output is sent to OUTDIR. Otherwise, the output will be sent
1667	to a default location in the current directory (\$PWD/fcm-mkpatch-out). The
1668	output directory will contain the patch for each revision as well as a script
1669	for importing the patch.
1670
1671	If a revision is specified with the --revision option, it will attempt to
1672	create a patch based on the changes at that revision. If a revision is not
1673	specified, it will attempt to create a patch based on the changes at the HEAD
1674	revision. If a revision range is specified, it will attempt to create a patch
1675	for each revision in that range (including the change in the lower range)
1676	where changes have taken place in the URL. No output will be written if there
1677	is no change in the given revision (range).
1678
1679	The --exclude option can be used to exclude a path in the URL. The specified
1680	path must be a relative path of the URL. Glob patterns such as * and ? are
1681	acceptable. Changes in an excluded path will not be considered in the patch.
1682	A changeset containing changes only in the excluded path will not be
1683	considered at all.
1684
1685	The --organisation option can be used to specify the name of your
1686	organisation. The command will attempt to parse the commit log message for
1687	each revision in the patch. It will remove all merge templates, replace links
1688	to Trac tickets with a simple string, and add information about the original
1689	changeset. If you specify the name of your organisation, it will replace Trac
1690	ticket links such as "ticket:123" to "Original \$organisation ticket 123",
1691	and report the orginal changeset with a message such as "Original
1692	\$organisation changeset 1000". Otherwise, it will report without the
1693	organisation name, e.g. "Original ticket 123" and "Original changeset 1000".
1694
1695	Valid options:
1696	--exclude arg : Exclude a path in the URL. Multiple paths can be
1697	specified by using a colon-separated list of paths, or
1698	by specifying this option multiple times.
1699	--organisation arg : Specify the name of your organisation.
1700	-r [--revision] arg : Specify a revision number or a revision number range.
1701	EOF
1702
1703	# Print usage message if requested
1704	if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1705	print $usage;
1706	return 1;
1707	}
1708
1709	# Process command line options and arguments
1710	# ----------------------------------------------------------------------------
1711	my (@exclude, $organisation, $revision);
1712	GetOptions (
1713	'exclude=s' => \@exclude,
1714	'organisation=s' => \$organisation,
1715	'r\|revision=s' => \$revision,
1716	);
1717
1718	# Excluded paths, convert glob into regular patterns
1719	@exclude = split (/:/, join (':', @exclude));
1720	for (@exclude) {
1721	s#\#[^/]#; # match any number of non-slash character
1722	s#\?#[^/]#; # match a non-slash character
1723	s#/*$##; # remove trailing slash
1724	}
1725
1726	# Organisation prefix
1727	$organisation = $organisation ? $organisation : 'original';
1728
1729	# Make sure revision option is set correctly
1730	my @revs = $revision ? split (/:/, $revision) : ();
1731	@revs = @revs [0, 1] if @revs > 2;
1732
1733	# Arguments
1734	my ($u, $outdir) = @ARGV;
1735
1736	if (not $u) {
1737	print $usage;
1738	return 1;
1739	}
1740
1741	my $url = Fcm::CmUrl->new (URL => $u);
1742	e_report $u, ': URL is not a URL, abort.' if not $url->is_url;
1743	e_report $u, ': URL does not exist, abort.' if not $url->url_exists;
1744	e_report $u, ': URL is not a valid branch in a FCM project, abort.'
1745	if not $url->branch;
1746
1747	$url->subdir ('');
1748
1749	if (@revs) {
1750	# If HEAD revision is given, convert it into a number
1751	# --------------------------------------------------------------------------
1752	for my $rev (@revs) {
1753	$rev = $url->svninfo (FLAG => 'Revision') if uc ($rev) eq 'HEAD';
1754	}
1755
1756	} else {
1757	# If no revision is given, use the HEAD
1758	# --------------------------------------------------------------------------
1759	$revs[0] = $url->svninfo (FLAG => 'Revision');
1760	}
1761
1762	$revs[1] = $revs[0] if @revs == 1;
1763
1764	# Check that output directory is set
1765	# ----------------------------------------------------------------------------
1766	$outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir;
1767
1768	if (-e $outdir) {
1769	# Ask user to confirm removal of old output directory if it exists
1770	my $reply = &main::get_input (
1771	TITLE => 'fcm mkpatch',
1772	MESSAGE => 'Output location ' . $outdir . ' exists. OK to overwrite?',
1773	TYPE => 'yn',
1774	DEFAULT => 'n',
1775	);
1776
1777	if ($reply ne 'y') {
1778	w_report 'fcm mkpatch: command aborted by user.';
1779	return 1;
1780	}
1781
1782	rmtree $outdir or die $outdir, ': cannot remove';
1783	}
1784
1785	# (Re-)create output directory
1786	mkpath $outdir or die $outdir, ': cannot create';
1787	print 'Output directory: ', $outdir, "\n";
1788
1789	# Get and process log of URL
1790	# ----------------------------------------------------------------------------
1791	my @script = (); # output script, from the log
1792	my %log = $url->svnlog (REV => \@revs);
1793	my $url_path = $url->path;
1794	my $file_count = 0;
1795
1796	for my $rev (sort {$a <=> $b} keys %log) {
1797	# Look at the changed paths for each revision
1798	my @paths;
1799
1800	# Skip excluded paths if necessary
1801	PATH: for my $path (sort keys %{ $log{$rev}{paths} }) {
1802	for my $exclude (@exclude) {
1803	(my $file = $path) =~ s#^$url_path/*##;
1804
1805	next PATH if $file =~ m#^$exclude(?:/*\|$)#;
1806	}
1807
1808	push @paths, $path;
1809	}
1810
1811	next unless @paths;
1812
1813	# Parse commit log message
1814	my @msg = split /\n/, $log{$rev}{msg};
1815	for (@msg) {
1816	# Re-instate line break
1817	$_ .= "\n";
1818
1819	# Remove line if it matches a merge template
1820	$_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/;
1821	$_ = '' if /^Custom merge into \S+:.+$/;
1822	$_ = '' if /^Merged into \S+: \S+ cf\. \S+$/;
1823
1824	# Modify Trac ticket link
1825	s/(?:#\|ticket:)(\d+)/[$organisation ticket $1]/g;
1826
1827	# Modify Trac changeset link
1828	s/(?:r\|changeset:)(\d+)/[$organisation changeset $1]/g;
1829	s/\[(\d+)\]/[$organisation changeset $1]/g;
1830	}
1831
1832	push @msg, '[' . $organisation . ' changeset ' . $rev . ']' . "\n";
1833
1834	# Write commit log message in a file
1835	my $f_revlog = File::Spec->catfile ($outdir, $rev . '-log');
1836	open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')';
1837	print FILE @msg;
1838	close FILE or die $f_revlog, ': cannot close (', $!, ')';
1839
1840	# Create a directory for this revision in the output directory
1841	my $outdir_rev = File::Spec->catfile ($outdir, $rev);
1842	mkpath $outdir_rev or die $outdir_rev, ': cannot create';
1843
1844	# Handle modified/copy/new path, export the path, + script to copy/add it
1845	for my $path (@paths) {
1846	next unless $log{$rev}{paths}{$path}{action} =~ /^[AMR]$/;
1847
1848	(my $file = $path) =~ s#^$url_path/*##;
1849
1850	# Download the file using "svn export"
1851	my $patch = File::Spec->catfile ($outdir_rev, $file_count++);
1852	my $url_file = $url->url . '/' . $file . '@' . $rev;
1853	&run_command ([qw/svn export -q -r/, $rev, $url_file, $patch]);
1854
1855	(my $patch_path = $patch) =~ s#^$outdir/*##;
1856
1857	# Script to copy the file, if required
1858	my $is_newfile = 0;
1859	if ($log{$rev}{paths}{$path}{action} eq 'A') {
1860	if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) {
1861	# History exists for this file
1862	my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'};
1863	my $copyfrom_rev = $log{$rev}{paths}{$path}{'copyfrom-rev'};
1864
1865	# Check whether file is copied from a file under the specified URL
1866	# It is likely to be a new file if it is copied from outside of the
1867	# specified URL.
1868	$is_newfile = not ($copyfrom_path =~ s#^$url_path/*##);
1869
1870	if ($is_newfile) {
1871	# File copied from outside of the specified URL
1872	# If it is copied from a branch, follow its history, stop on copy
1873	my $cp_url = Fcm::CmUrl->new (
1874	URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev,
1875	);
1876
1877	# Log of the copied file
1878	my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1);
1879
1880	# "First" revision of the copied file
1881	my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0];
1882	my %attrib = exists $cp_log{$cp_rev}{paths}{$cp_url->path}
1883	? %{ $cp_log{$cp_rev}{paths}{$cp_url->path} } : ();
1884
1885	# Check whether the "first" revision is copied from elsewhere.
1886	if (exists $attrib{'copyfrom-path'}) {
1887	# Check whether source exists in the current branch
1888	my $cp_cp_url = Fcm::CmUrl->new (
1889	URL => $url->root . $attrib{'copyfrom-path'} . '@' .
1890	$attrib{'copyfrom-rev'},
1891	);
1892
1893	$cp_cp_url->branch ($url->branch);
1894
1895	# If source exists in current branch, set up copy from the source
1896	if ($cp_cp_url->url_exists ($rev - 1)) {
1897	$is_newfile = 0;
1898	(my $cp_cp_path = $cp_cp_url->path) =~ s#^$url_path/*##;
1899
1900	push @script, 'svn copy ' . $cp_cp_path . ' ' . $file;
1901	}
1902	}
1903
1904	} else {
1905	# File copied from a location under the specified URL
1906	# Script to copy file
1907	push @script, 'svn copy ' . $copyfrom_path . ' ' . $file;
1908	}
1909
1910	} else {
1911	# History does not exist, must be a new file
1912	$is_newfile = 1;
1913	}
1914	}
1915
1916	# Copy the "patch" into the file
1917	push @script, 'cp -r ${fcm_patch_dir}/' . $patch_path . ' ' . $file;
1918
1919	# Script to add the file, if required
1920	push @script, 'svn add ' . $file
1921	if $log{$rev}{paths}{$path}{action} eq 'A' and $is_newfile;
1922	}
1923
1924	# Handle deleted path, script to delete it
1925	for my $path (@paths) {
1926	next unless $log{$rev}{paths}{$path}{action} eq 'D';
1927
1928	(my $file = $path) =~ s#^$url_path/*##;
1929
1930	push @script, 'svn delete ' . $file;
1931	}
1932
1933	# Script to commit the change
1934	push @script, 'svn commit -F ${fcm_patch_dir}/' . $rev . '-log';
1935	push @script, '';
1936	}
1937
1938	# Write the script if necessary. Otherwise remove output directory
1939	# ----------------------------------------------------------------------------
1940	if (@script) {
1941	# Add line break to each line in @script
1942	@script = map {($_ ? $_ . ' \|\| exit 1' . "\n" : "\n")} @script;
1943
1944	# Write script to output
1945	my $out = File::Spec->catfile ($outdir, 'fcm-import-patch');
1946	open FILE, '>', $out or die $out, ': cannot open (', $!, ')';
1947
1948	# Script header
1949	print FILE <<EOF;
1950	#!/bin/sh
1951	# ------------------------------------------------------------------------------
1952	# NAME
1953	# fcm-import-patch
1954	#
1955	# SYNOPSIS
1956	# fcm-import-patch TARGET
1957	#
1958	# DESCRIPTION
1959	# This script is generated automatically by the "fcm mkpatch" command,
1960	# together with the revision "patches" it creates. The script imports the
1961	# patches into TARGET, which must either be a URL or a working copy of a
1962	# valid project tree that can accept the import of the patches.
1963	#
1964	# Patch created from $organisation URL: $u
1965	# ------------------------------------------------------------------------------
1966
1967	this=`basename \$0`
1968
1969	# Check argument
1970	target=\$1
1971
1972	# First argument must be a URL or working copy
1973	if [[ -z \$target ]]; then
1974	echo "\$this: the first argument must be a URL or a working copy, abort." >&2
1975	exit 1
1976	fi
1977
1978	if [[ \$target == svn://* \|\| \$target == svn+ssh://* \|\| \\
1979	\$target == http://* \|\| \$target == https://* \|\| \\
1980	\$target == file://* ]]; then
1981	# A URL, checkout a working copy in a temporary location
1982	fcm_tmp_dir=`mktemp -d \$TMPDIR/\$0.XXXXXX`
1983	fcm_working_copy=\$fcm_tmp_dir
1984	svn checkout -q \$target \$fcm_working_copy \|\| exit 1
1985
1986	else
1987	# A working copy, check that it does not have local changes
1988	status=`svn status \$target`
1989
1990	if [[ -n \$status ]]; then
1991	echo "\$target: working copy contains changes, abort." >&2
1992	exit 1
1993	fi
1994
1995	fcm_working_copy=\$target
1996	fi
1997
1998	# Location of the patches, base on the location of this script
1999	cd `dirname \$0` \|\| exit 1
2000	fcm_patch_dir=\$PWD
2001
2002	# Change directory to the working copy
2003	cd \$fcm_working_copy \|\| exit 1
2004
2005	# Commands to apply patches
2006	EOF
2007
2008	# Script content
2009	print FILE @script;
2010
2011	# Script footer
2012	print FILE <<EOF;
2013	# Remove temporary working copy, if necessary
2014	if [[ -d \$fcm_tmp_dir && -w \$fcm_tmp_dir ]]; then
2015	rm -rf \$fcm_tmp_dir
2016	fi
2017
2018	echo "\$this: finished normally."
2019	#EOF
2020	EOF
2021
2022	close FILE or die $out, ': cannot close (', $!, ')';
2023
2024	# Add executable permission
2025	chmod 0755, $out;
2026
2027	# Diagnostic
2028	print $outdir, ': patch generated.', "\n";
2029
2030	} else {
2031	# Remove output directory
2032	rmtree $outdir or die $outdir, ': cannot remove';
2033
2034	# Diagnostic
2035	w_report 'No patch is required, abort.';
2036	}
2037
2038	return 1;
2039	}
2040
2041	# ------------------------------------------------------------------------------
2042	# SYNOPSIS
2043	# &Fcm::Cm::cm_svn ();
2044	#
2045	# DESCRIPTION
2046	# This is a generic wrapper for all "other" Subversion commands.
2047	# ------------------------------------------------------------------------------
2048
2049	sub cm_svn {
2050	&run_command (
2051	['svn', @_, @ARGV],
2052	PRINT => ($_[0] ne 'cat' and not grep {$_ eq '--xml'} @ARGV),
2053	METHOD => 'exec',
2054	);
2055	}
2056
2057	# ------------------------------------------------------------------------------
2058	# SYNOPSIS
2059	# &Fcm::Cm::cm_switch ();
2060	#
2061	# DESCRIPTION
2062	# This is a wrapper for the Subversion "switch" command.
2063	# ------------------------------------------------------------------------------
2064
2065	sub cm_switch {
2066	if (grep {$_ eq '-h' or $_ eq '--help'} @ARGV or not @ARGV) {
2067	# Print usage message if requested
2068	print <<EOF;
2069	usage: 1. switch URL [PATH]
2070	2. switch --relocate FROM TO [PATH...]
2071
2072	Note: if --relocate is not specified, "fcm switch" will only support the
2073	options --non-interactive, -r [--revision] and -q [--quiet].
2074
2075	EOF
2076
2077	&run_command ([qw/svn switch --help/], PRINT => 1, METHOD => 'exec');
2078
2079	} elsif (grep {$_ eq '--relocate'} @ARGV) {
2080	# If "--relocate" is specified, call the command "as is"
2081	cm_svn ('switch');
2082	}
2083
2084	# "--help" and "--relocate" not specified, implement custom switch command
2085
2086	# Get command line options
2087	my ($non_interactive, $rev, $quiet);
2088	GetOptions (
2089	'non-interactive' => \$non_interactive,
2090	'revision\|r=s' => \$rev,
2091	'quiet\|q' => \$quiet,
2092	);
2093
2094	# The remaining arguments
2095	$rev = 'HEAD' if not $rev;
2096
2097	# The remaining arguments
2098	my ($newurl_arg, $path) = @ARGV;
2099
2100	# Make sure we are in a working copy
2101	if ($path) {
2102	e_report $path, ': does not exist, abort.' if not -e $path;
2103
2104	} else {
2105	$path = cwd ();
2106	}
2107
2108	e_report $path, ': not a working copy, abort.' if not &is_wc ($path);
2109
2110	# Make sure we are at the top level of the working copy
2111	my $dir = &get_wct ($path);
2112
2113	# Check for merge template in the commit log file in the working copy
2114	my $ci_mesg = Fcm::CmCommitMessage->new (DIR => $dir);
2115	$ci_mesg->read_file;
2116	e_report (
2117	(($path eq $dir) ? $ci_mesg->base : $ci_mesg->file),
2118	': merge template exists, please remove it before running switch, abort.',
2119	) if $ci_mesg->auto_mesg;
2120
2121	# Check for any local modifications
2122	return if ! $non_interactive and &_abort_modified_wc ('fcm switch', $dir);
2123
2124	# Get current URL information associated with the working copy
2125	my $oldurl = Fcm::CmBranch->new (URL => &get_url_of_wc ($dir));
2126
2127	# Analyse new URL
2128	my $newurl = &_construct_branch_url ($newurl_arg, $oldurl);
2129
2130	# Construct the switch command
2131	my @command = (
2132	qw/svn switch/,
2133	($non_interactive ? '--non-interactive' : ()),
2134	($rev ? ('-r', $rev) : ()),
2135	($quiet ? '--quiet' : ()),
2136	$newurl->url,
2137	($dir eq cwd () ? () : $dir),
2138	);
2139
2140	# Execute the command
2141	&run_command (\@command, METHOD => 'exec', PRINT => 1);
2142	}
2143
2144	# ------------------------------------------------------------------------------
2145	# SYNOPSIS
2146	# $source = &_construct_branch_url ($src_url, $target);
2147	#
2148	# DESCRIPTION
2149	# The function takes a string $src_url, which is normally the SOURCE URL
2150	# argument for "merge" and "switch", and a target, which is an instance of a
2151	# Fcm::CmBranch object with a valid URL of a standard FCM branch. It returns
2152	# an instance of a Fcm::CmBranch object that represents a valid URL for
2153	# $src_url.
2154	# ------------------------------------------------------------------------------
2155
2156	sub _construct_branch_url {
2157	my ($src_url, $target) = @_;
2158
2159	my $source = Fcm::CmBranch->new (URL => $src_url);
2160
2161	if (not $source->is_url) {
2162	# Not a full URL, construct full URL based on current URL
2163	$source->url_peg ($target->url_peg);
2164
2165	my $path = '';
2166	my $project = $target->project;
2167
2168	# Construct the branch URL
2169	if ($src_url =~ m#^/*$project/(?:trunk\|branches\|tags)$#) {
2170	# Argument contains the full path under the repository root
2171	$path = $src_url;
2172
2173	} elsif ($src_url =~ m#^/trunk/(?:@\d+)?$# or
2174	$src_url =~ m#^/*(?:trunk\|branches\|tags)/+#) {
2175	# Argument contains the full branch name
2176	$src_url =~ s#^/*##;
2177	$path = $target->project_path . '/' . $src_url;
2178
2179	} else {
2180	# Argument contains the shorter branch name
2181	$src_url =~ s#^/*##;
2182	$path = $target->project_path . '/branches/' . $src_url;
2183	}
2184
2185	$source->path_peg ($path);
2186	}
2187
2188	# Replace source sub-directory with the target sub-directory
2189	$source->subdir ($target->subdir);
2190
2191	# Ensure that the branch name exists
2192	e_report $src_url, ': not a valid URL, abort.'
2193	if not $source->url_exists;
2194
2195	# Ensure that the branch name is valid
2196	e_report $src_url, ': not a standard branch in a FCM project, abort.'
2197	if not $source->branch;
2198
2199	# Ensure that the source and target URLs are in the same project
2200	e_report 'Source and target URLs are in different projects, abort.'
2201	if $source->project_url ne $target->project_url;
2202
2203	return $source;
2204	}
2205
2206	# ------------------------------------------------------------------------------
2207	# SYNOPSIS
2208	# &_abort_modified_wc ($title, [$wc]);
2209	#
2210	# DESCRIPTION
2211	# The function checks for any local modifications in a working copy and
2212	# prompts the user whether he/she wants to continue with the command. $title
2213	# is the title of the current command. If $wc is specified, it must be the
2214	# path to a working copy. Otherwise, the current working directory is used.
2215	# ------------------------------------------------------------------------------
2216
2217	sub _abort_modified_wc {
2218	my ($title, $wc) = @_;
2219
2220	my @status = &run_command ([qw/svn status/, ($wc ? $wc : ())], METHOD => 'qx');
2221
2222	if (@status) {
2223	print 'You have local modifications:', "\n", @status;
2224	my $reply = &main::get_input (
2225	TITLE => $title,
2226	MESSAGE => 'Are you sure you want to continue?',
2227	TYPE => 'yn',
2228	DEFAULT => 'n',
2229	);
2230
2231	# Abort if user gives any reply other than "y"
2232	if ($reply ne 'y') {
2233	w_report $title, ': command aborted by user.';
2234	return 1;
2235	}
2236	}
2237	}
2238
2239	# ------------------------------------------------------------------------------
2240
2241	1;
2242
2243	__END__

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: LMDZ6/branches/IPSL-CM6A-MR/tools/fcm/lib/Fcm/Cm.pm

Download in other formats: