Pairs.pl #6

#
# Example trigger to enforce a rule "files of suffix .x/.y need to be checked
# in as pairs".
#
# This script will do the following:
#	1. Return "success" (exit code 0) if the change has no applicable files
#	   in the changelist;
#	2. Otherwise, it checks that the files you've given are
#	   being submitted with the other component in that pair, and
#	   if not, reports an error.
#
# Unix usage:
#	perl /whatever/Pairs.pl %changelist% %serverport%
# NT usage:
#       c:/perl/bin/perl  c:/whatever/Pairs.pl %changelist% %serverport%
# (Note that the name of this script might need to be an "8.3" filename,
# depending on the version of Perl you're running.)
#
#
# Example 'triggers' section:
# (Note: since this is applicable to only filenames with certain
# suffixes, you might want to restrict the trigger to run when those files
# are submitted.  So, if this is looking at .cpp/.h/.txt/.html lines, you
# might want to have it run only on those files.)

#    Triggers:
#	exampleP  //.../*.cpp    "perl whatever/Pairs.pl %changelist% %serverport%"
#	exampleP  //.../*.h      "perl whatever/Pairs.pl %changelist% %serverport%"
#	exampleP  //.../*.html   "perl whatever/Pairs.pl %changelist% %serverport%"
#	exampleP  //.../*.txt    "perl whatever/Pairs.pl %changelist% %serverport%"
#
# Tested on Platforms:   FreeBSD, NT (as program, not service).
#
# Most recent version tested against: 2002.2
#
# You might need to...
# 1. You might need to run change the "$p4 = ......." line,
#    below, to add a username and password
#         ('p4 -u hardcodedusername  -P hardcodeduserpasswd -p $ServerPort')
#    if the default user it's connecting as isn't appropriate.

$ChangeNum = $ARGV[0];
$ServerPort = $ARGV[1];
$p4 = "p4 -p $ServerPort ";

$MaxErrs = 10;
$OptimizeErrorOutput = "yes";

#-------- enter the suffixes for the pairs, here -----------------------------------
$listpairs{"cpp"} = "h";	# x.cpp must have x.h checked in, and also vice versa.
$listpairs{"txt"} = "html";	# x.txt must have x.html checked in, and also vice versa.
#-----------------------------------------------------------------------------------

Fatal("Changelist $ChangeNum (1st arg) needs to be numeric!\n") unless ($ChangeNum =~ /^\d+$/);
Fatal("\%serverport\% (2nd arg) wasn't specified.\n") if ($ServerPort eq "");

# cannot use 'p4 describe -s changenum', so we get a list of open files
# this way...
@OpenedList = `$p4 opened -a -c $ChangeNum`;

#
# Algorithm used:
#	for each file in that's being submitted...
#		1. Figure out if it's "interesting" to this trigger, which is to say,
#		   that it ends with one of the suffixes listed in "listpairs".
#		2. If so, add it to the associative array "FilesToChange". The
#		   value of the array element is the name of the OTHER item in the
#		   pair. (So if "x.h" is being submitted, $FilesToChange{"x.h"} will
#		   map to "x.cpp".)
#	After creating this array, then step through it making sure that each
#	item mentioned as a value ("x.cpp") is also a valid index. That means
#	that ``$FilesToChange{"x.cpp"} should exist''). If not, it's an error.
#
chomp(@OpenedList);
foreach (@OpenedList) {
	my($tmp);
	next unless /^(\/\/.*)#\d+ - .*\s$ChangeNum\s.*/;
	if (($tmp = IsInterestingFile($1, %listpairs)) ne "") {
		$FilesToChange{"$1"} = $tmp;
		$nfiles++;
	}
}

if ($nfiles == -1) {
	Inform("No changes modify files that belong in a pair. (Exiting.)\n");
	exit(0);
}

$nerrs = 0;
foreach $f (sort keys %FilesToChange) {
	my($expected_pair) = $FilesToChange{"$f"};
	if (!defined($FilesToChange{"$expected_pair"})) {
		# errors are reported to STDOUT, since NT triggers don't copy STDERR to user.
		print "$f was submitted, but $expected_pair wasn't - both should be submitted.\n";
		$nerrs++;
	}
	if ($nerrs >= $MaxErrs) {   
		Warn("*** Only first $MaxErrs errors shown\n");
		last;
	}
}

if ($nerrs > 0) {
	Fatal("Errors found, submission refused\n");	# Note, this prints to STDOUT. See above.
}
exit(0);

sub IsInterestingFile {
	my($fname, %listpairs) = @_;

	foreach $l (keys %listpairs) {
		my($suffix1, $suffix2) = ($l, $listpairs{$l});
		return "$1.$suffix2"
			if ($fname =~ /^(.*)\.$suffix1/);
		return "$1.$suffix1"
			if ($fname =~ /^(.*)\.$suffix2/);
	}
	return "";
}

###############################################################################
# Note that all messages (warning/fatal/info) go to STDOUT, not STDERR. Trigger
# output to standard output is sent to the user; standard error isn't.
###############################################################################
sub TellUser {
	my($str, $msgtype) = @_;
	print "$str";
	print "\n" unless ($str =~ /\n$/);
	exit(1) if ($msgtype eq fatal);
}

sub Warn {
	TellUser(@_, warning);
}
sub Fatal {
	TellUser(@_, fatal);
}

sub Inform {
	TellUser(@_, inform);
}