Binary.pl #1

#
# $Id: //guest/paul_goffin/triggers/Binary.pl#1 $
#
# Example trigger to enforce a rule "files of suffix .x need to be checked
# in as type Z". (For example, ".gif" files must always be "binary" and ".sh"
# files should always be "text".)
#
# 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% %client%
# NT usage:
#       c:/perl/bin/perl  c:/whatever/Pairs.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.)
#
#
# 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:
#	exampleB  //.../*.gif  "perl whatever/Binary.pl %changelist% %serverport% %client%"
#	exampleB  //.../*.bmp  "perl whatever/Binary.pl %changelist% %serverport% %client%"
#	exampleB  //.../*.sh   "perl whatever/Binary.pl %changelist% %serverport% %client%"
#
# Tested on Platforms:   FreeBSD, NT (as program, not service).
#
# Known bugs:
#	1. Perforce triggers have problems [at the moment] running when the
#	   Perforce server is running as an NT server.
#
#
# Based on the example from Jeff Bowles
# Fixed problem with latest 99.2 server "Host:" option
# for clients.  Also improved way to get list of files in
# change being submitted. 
#

#-------- enter the suffixes for the pairs, here -----------------------------------
#$filetype{"sh"} = ".*text";	# x.sh is text
#	$errmsg{"sh"} = "filetype of .sh files should be text/xtext/ktext";
#$filetype{"gif"} = ".*binary";	# x.gif is binary
#	$errmsg{"gif"} = "filetype of .gif files should be binary";
$filetype{"pdf"} = ".*binary";	# *.pdf is binary
	$errmsg{"pdf"}= "filetype of .pdf files must be binary";
#-----------------------------------------------------------------------------------

$ChangeNum = $ARGV[0];
$ServerPort = $ARGV[1];
$ClientName = $ARGV[2];

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 "");

$mainP4env = "-p $ServerPort -u SUPERUSER -P SUPERUSERPASSWD";
$p4 = "p4 $mainP4env";

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

# Need to find  the "Host" of the client if any.
# Get the client description and search it for the "Host:" field

@Client = `$p4 client -o $ClientName`;
foreach (@Client) {
	chomp ($_);
                	if ($_) {
		my @fields = split;
                		if (($fields[0]) && ($fields[0] eq "Host:")) {
			if ($fields[1]) {
				$p4 = "p4 $mainP4env -H $fields[1] -c $ClientName";
	           		}
			else {
				$p4 = "p4 $mainP4env -c $ClientName";
			}
			last;
                    	 	}
                		if (($fields[0]) && ($fields[0] eq "Description:")) {
			# No host field present - backward compatibility
			$p4 = "p4 $mainP4env -c ClientName";
			last;
		}
	}
}
#print "\nMy P4 = $p4\n";

@OpenedList = `$p4 opened -c $ChangeNum`;  # cannot use 'p4 describe -s changenum', so we
				         # get a list of open files this way...
#
# Algorithm used:
#	Pry out the suffix/type for each file being submitted, and pass it to "CheckType".
#	It'll pass back "-1" for each bad file type.
#
chomp(@OpenedList);
foreach (@OpenedList) {
	my($tmp);
	next unless  /^(\/\/.*)#[0-9]* - .*\s$ChangeNum\s\((\S+)\).*/;
	if (CheckType($1, $2, %filetype) < 0) {
		$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);

sub CheckType {
	my($fname, $filetype, %filetypes) = @_;
	my($suffix) = $1
		if ($fname =~ /^.*\.([^\.]+)$/);
	if ($1 ne "" && defined($filetypes{$suffix}) && $filetype !~ /^$filetypes{$suffix}/ ) {
		Warn("$fname: $errmsg{$suffix}.\n");
		return (-1);
	}
	return 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);
}