lockbranch.pl #1

#
# Trigger to allow non-super users the ability to
# "lock" areas of the depot against submissions.
#
# A "well known directory" needs to be allocated on the
# server and this script must be modified to point to it.
# Files in this directory should be simple text files
# containing simple directory paths (one per line) which
# are to be locked against further submissions.
#
# Simple file matching is employed - so wildcards
# are not useful.
#
# This script will do the following:
#	1. Return "success" (exit code 0) if the lock files
#        area has no files in it.
#	2. Otherwise, it checks that the files you've given are
#	   not in any list of locked areas.  If they are,
#	   if not, reports an error.
#
# Unix usage:
#	perl /whatever/Lockbranch.pl %changelist% %serverport% %client%
# NT usage:
#       c:/perl/bin/perl  c:/whatever/lockbranch.pl %changelist% %serverport% %client%
# (Note that the name of this script might need to be an "8.3" filename,
# depending on the version of Perl you're running.)
#
#
# Tested on Platforms:    NT (as program, not service).
#
#

# NT needs case-insensitive filename matching
use locale;

$ChangeNum = $ARGV[0];
$ServerPort = $ARGV[1];
$ClientName = $ARGV[2];
$p4 = "p4 -p $ServerPort -c $ClientName -u <review_user>";

$nerrs = 0;
$MaxErrs = 5;
$OptimizeErrorOutput = "yes";

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

#
# check my "cache" of locks.
#

$a = `$p4 counter lockchange`;
$b = `$p4 counter lockcache`;

if ($a > $b) { 	# cache is stale - build a new one
	open(LC, ">lockcache");
	
	# Get the list of "closed paths" - if any.
	
	@LockFilesList = `$p4 files //depot/locks/*`;

	foreach (@LockFilesList) {
		/^(\/\/.*)#/; # the name of the file before the rev spec.
      		@Closedlist = `$p4 print -q $1`;
		foreach (@Closedlist) {
			if ( index ($_, "#") == -1) {   # not a comment
				$x = lc ($_);       # NT case insensitive
				chomp ($x);
				print LC $x;
				print LC "\n";  
			}
		}
	}
	`$p4 counter lockcache $a`;  # update the counter
	close (LC);
}
#
# Build a list of files in the changelist
#

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

#
#  Now the slow bit.
#  Cycle round the list of locked areas , compare with
#  all files in the submission. if anything matches - reject.
#

open (LC, "lockcache");

while ( defined ($locked = <LC>)) {
	foreach (@OpenedList) {
		/^(\/\/.*)#[0-9]* - .*\s$ChangeNum\s\((\S+)\)\s.*/; # split up the file name
		if (index (lc($1), $locked) != -1) {  # found the path  (NT case insensitive)
		    	Warn("$1: submissions locked\n");
			$nerrs++;
		}
		if ($nerrs >= $MaxErrs) {   
			Fatal("*** 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);

###############################################################################
# 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);
}