Jobs.pl #2

#
# Example trigger to enforce a rule "submissions must have a job associated
# with them."
#
# This script will do the following:
#	1. Return "success" (exit code 0) if the change has
#	   at least one "job" associated with it;
#	2. Otherwise, reports an error.
#
# Unix usage:
#	perl /whatever/Jobs.pl %changelist% %serverport% %client%
# NT usage:
#       c:/perl/bin/perl  c:/whatever/Jobs.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:
#    Triggers:
#	exJobs  //...   "c:/perl/bin/perl c:/whatever/Jobs.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.
#

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

$MaxErrs = 10;
$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 "");

@ChangeInfo = `$p4 describe -s $ChangeNum`;

foreach $c (@ChangeInfo) {
	exit(0) if ($c =~ /Jobs fixed/);
};
#
# Note that errors are sent to <stdout> because the NT server copies THAT to
# the user's output.
#
if ($#ChangeInfo == -1) {
	Fatal("Cannot get 'p4 describe -s $ChangeNum' output. Refusing submission\n");
} else {
	Fatal("No job associated with change $ChangeNum - refusing submission\n");
}
# end of 'main' segment

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