Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

Cm.pm @ 4772

Last change on this file since 4772 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

Rev	Line
[1578]	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: LMDZ5/trunk/tools/fcm/lib/Fcm/Cm.pm @ 4772

Download in other formats: