p4submit.pl #2

eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
  & eval 'exec perl -S $0 $argv:q'
  if 0;
#  THE PRECEEDING STUFF EXECS perl via $PATH
# -*-Fundamental-*-

#
# $Id: //guest/sandy_currier/utils/p4submit.pl#2 $
#

#
# Copyright (c) 2000, Sandy Currier (sandy@releng.com)
# Distributed under the GNU GENERAL PUBLIC LICENSE:
#
#      This program is free software; you can redistribute it and/or modify
#      it under the terms of the GNU General Public License as published by
#      the Free Software Foundation; either version 1, or (at your option)
#      any later version.
#
#      This program is distributed in the hope that it will be useful,
#      but WITHOUT ANY WARRANTY; without even the implied warranty of
#      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#      GNU General Public License for more details.
#
#      You should have received a copy of the GNU General Public License
#      along with this program; if not, write to the Free Software Foundation,
#      Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
#

# first, see if unix or NT or what...
# need a recent version of perl on NT to have win32 module/config stuff
BEGIN: {
    require 5.004;
    unless ($Platform{'os'}) {
	unless ($Platform{'os'} = $^O) {
	    require Config;
	    $Platform{'os'} = $Config::Config{'osname'};
	    $Platform{'os'} = $Config::Config{'osname'};
	}
    }
    # bottom layer OS specific variables/constants
    if ($Platform{'os'}=~/Win/i) {
	#########################
	# win32
	#########################
	$Platform{'os'} = "win32";
	$Platform{'pd'} = '\\';
    } else {
	#########################
	# unix
	#########################
	$Platform{'os'} = "unix";
	$Platform{'pd'} = '/';
    }
}

#
# Unbuffer STDERR and STDOUT
select(STDERR);
$| = 1;			# Make STDERR be unbuffered.
select(STDOUT);
$| = 1;			# STDOUT too so, they can mix.
if ($Platform{'os'}=~/Win/i) {
    $Platform{'tmp'} = &other2unix("$ENV{'TEMP'}"); # a temp file for writing
} else {
    $Platform{'tmp'} = "/tmp"; # a temp file for writing
}

#
# set up some globals
# Note: assume that the PATH EV is going to be used to find p4
$ThisCmd = "p4submit.pl";	# this command name
$verbose = 0;
$P4 = "p4";			# the p4 command to execute (can either be
				# absolute or relative)
$vb = ">>>";
$err = "***";
$printonly = 0;
$Platform{'tmp'} = "$Platform{'tmp'}/$ThisCmd.$$";

#
# user defined variables
@Files = ();			# the list of files
$c = "";			# changenumber
$d = "";			# description
$force = "";			# force switch
$minimum = 8;			# the minimum description length
$regexp = "";			# a regexp match
$identical = "";		# 

#
# now parse any args
# the usage message (for -h or on error)
$help = "$ThisCmd description [-c changenumber] [files ...]
Function:
    $ThisCmd will submit either the default changelist or a 
    specified changelist.  An optional list of files is supported.
    If supplied while the default changelist is being used, only
    those files will be submitted.  If supplied with a numbered
    changelist, the files that do match will be moved to the
    default changelist.  In either case, the files MUST be
    in depot syntax (//depot/...).

    The first 'non-switch' argument is the description and must
    be delimited by '\"'.

Args:
    \"description\"  The description for the change
    files ...      Files in DEPOT SYNTAX
                      
Switches/Options:
    -h             Prints this help message
    -f             Force.  Normally, $ThisCmd prints the
                   changelist to STDOUT and prompts on STDIN
                   whether or not to proceed.  -f will turn
                   this functionality off.
    -P4 \"p4 ...\"   By setting the value of 'P4', one can add
                   any supported p4 switch to all the p4
                   commands that this script invokes.  This can
                   by used to set the -c, -d, -H, -p, -P,
                   -s, or -u switches to the p4 command.
    -regexp <...>  A perl regexp to be used to match for files
                   to submit.  Those files not matching are not
                   submitted.
    -identical     If set, will revert files that are identical
                   before submitting the changelist
";
# future functionality
#      -update          Instead of submitting the change, will
#                       update the change description.  If the
#                       default changelist is implied, will
#                       create a numbered changelist with those
#                       specified files in it.  If a numbered
#                       changeset is specified, will 

#
# parse command line
{
    my($i, $param);
    while($i <= $#ARGV) {
	# scan for a help switch
	if ($ARGV[$i] =~ /^-h/i) {
	    &DieHelp("", $help);
	}
	elsif ($ARGV[$i] =~ /^-f/i) {
	    $force = 1;
	    $i++;
	}
	elsif ($ARGV[$i] =~ /^-ident/i) {
	    $identical = 1;
	    $i++;
	}
	# scan for variable definitions (-variable value)
	elsif ($ARGV[$i] =~ /^-\w+/ and defined($ARGV[$i+1]) and $ARGV[$i+1] !~ /^-[^-]/) {
	    # NOTE: nt has a difficult time with '=' on a command line...
	    # process any variable value switches
	    my($var) = $ARGV[$i];
	    $var =~ s/^-//;
	    my($value) = $ARGV[$i+1];
	    if (defined $$var) {
		$$var = $value;
	    }
	    else {
		&DieHelp("Unknown parameter '$var'", $help);
	    }
	    $i=$i+2;
	}
	# catch unsupported switches
	elsif ($ARGV[$i] =~ /^-/) {
	    &DieHelp("Unsupported switch \"$ARGV[$i]\"", $help);
	}	
	# snarf first arg
	elsif ($param == 0) {
	    $d = $ARGV[$i];
	    $i++; $param++;
	}
	else {
	    # swallow files, if any
	    push(@Files, $ARGV[$i]);
	    $i++; $param++;
	}
    }
}

#
# check args
if (!$c and length($d) < $minimum) {
    &DieHelp("A change description of at least $minimum characters is required", $help);
}
if ($c and $c !~ /^[0-9]+$/) {
    &DieHelp("A changelist argument must consist of only numbers", $help);
}

#
# if the default changelist is being used
$errors = &P4Submit($c, $d, @Files);

&Exit($errors);


#
# subroutines
#

sub Exit {
    my($val) = @_;
    unlink $Platform{'tmp'};
    exit($val);
}

sub DieHelp {
    my($str, $help) = @_;
    print STDOUT "Usage: $help\n$err $str\n";
    exit(2);
}

# will convert a random OS delimited pathname to a perl pathname
sub other2unix {
    my($filename) = @_;
    my($pattern) = $Platform{'pd'};
    $pattern =~ s/(\W)/\\$1/g;	# escape wildchars
    $filename =~ s|$pattern|/|g;
    return("/") if ($filename =~ /^\/+$/); # if just /+, return just /
    if ($filename =~ /^\/\//) {
	# add them back in later
	$filename =~ s|/+|/|g;	# remove doubles
	$filename = "/$filename";
    }
    else {
	$filename =~ s|/+|/|g;	# remove doubles
    }
    # remove trailing
    $filename =~ s|/+$||;
    return($filename);
}

# will print an error
sub PrintError {
    my($text, $stream_p) = @_;
    my($tmp);
    # make sure $? is set
    $? = 1;
    # prepend with the correct prefix
    $text =~ s/^(.*)$/$err $1/gm;
    # add a \n
    $text = "$text\n";
    # print and log (maybe)
    if ($stream_p) {
	print $stream_p "$text";
    }
    else {
	print STDERR "$text";
    }
    return($tmp);
}

#
# Note: this will actually execute any command...
# returns the action of the revision of the specified file#revision
sub ExecuteP4Cmd {
    my($script, $verbose, $print_output, $no_error_check, $stream_p) = @_;
    my(@output);
    if ($stream_p) {
	print $stream_p "$vb\n$vb running: $script\n$vb\n" if ($verbose);
    }
    else {
	print STDOUT "$vb\n$vb running: $script\n$vb\n" if ($verbose);
    }
    if (!$Platform{'nt'} and $Platform{'os'} eq "win32") {
	@output = `$script` unless ($printonly);
    }
    else {
	@output = `$script 2>&1` unless ($printonly);
    }
    if ($stream_p) {
	print $stream_p "@output" if ($print_output);
    } else {
	print STDOUT "@output" if ($print_output);
    }
    if (!$no_error_check and $?) {
	# now what - just keep going
	&PrintError("$ThisCmd - something happened with '$script'\n$?", $stream_p);
    }
    return(@output);
}

sub P4Submit {
    my($changenum, $description, @files) = @_;
    my($p4submit, $error, @default, @change, @output, @movefiles, $skip_p, $input);

    #
    # first, grab the default changelist
    @default = &ExecuteP4Cmd("$P4 change -o $changenum", $verbose);
    chomp(@default);
    if ($?) {
	&PrintError("$ThisCmd: exiting do to above '$P4 change -o' error");
	&Exit(1);
    }

    #
    # if @files is supplied, replace the file list with those files
    $skip_p = 0;
    if ($#files >= 0 or $regexp) {
	# cheap way of replacing files
	foreach (@default) {
	    push @change, $_ unless ($skip_p);
	    if (/^Files:/) {
		$skip_p = 1;
		next;
	    }
	    push @movefiles, $_ if ($skip_p and $_ ne "");
	}
	unless ($skip_p) {
	    # if there were no files listed in the first place, then
	    push @change, "Files:\n";
	}
	# if a regexp is supplied, use it.  Regardless, add those files supplied on the CLI
	if ($regexp) {
	    foreach my $file (@movefiles) {
		if (grep(/$regexp/, $file)) {
		    push @change, $file;
		}
	    }
	}
	foreach (@files) {
	    push @change, "\t$_ # how'd you get up there\n";
	}
    }
    else {
	@change = @default;
    }
    undef @default;

    #
    # Insert the log message...
    # prepend $description with the correct tab prefix
    $skip_p = 0;
    if ($description) {
	$description =~ s/^(.*)$/\t$1/gm;
	foreach (@change) {
	    $skip_p = 0 if (/^Files/);
	    next if ($skip_p);
	    push @default, $_;
	    if (/^Description:/) {
		# add in description
		push @default, $description;
		$skip_p = 1;
	    }
	}
    }
    else {
	@default = @change;
    }

    #
    # if $identical, revert identical files
    if ($identical) {
	my(@tmpfiles, @revertedfiles);
	# loop over @default a get the file list
	$skip_p = 0;
	foreach (@default) {
	    if (/^Files:/) {
		$skip_p = 1;
		next;
	    }
	    push @tmpfiles, $_ if ($skip_p and $_ ne "");
	}
	# remove the syntax around the files catalogued in @movefiles
	foreach (@tmpfiles) {
	    s|^\s*||;		# remove leading spaces
	    s|\s*\#.*$||;	# remove trailing comments
	}
	@revertedfiles = &RevertUnchangedFiles(\@tmpfiles);
	# now remove these from @default
	foreach my $file (@revertedfiles) {
	    @default = grep(!/^\t$file \#/, @default);
	}
    }

    #
    # prompt
    unless ($force) {
	foreach my $line (@default) {
	    print STDOUT "$line\n";
	}
	print STDOUT "\nAbout to submit the above.  Proceed? [yes] ";
	$input = <STDIN>;
	chomp($input);
	unless ($input eq "" or $input =~ /^y/i) {
	    print "Aborting on user input...\n";
	    &Exit(0);
	}
    }

    #
    # if this is a numbered changelist and there are files to
    # move back to the default changelist...
    if ($changenum) {
	foreach my $file (@movefiles) {
	    my($foo);
	    $file =~ s|\s*\# .+$||; # remove trailing comments
	    $file =~ s|^\s*||;	# remove leading spaces
	    $foo = quotemeta($file);
	    if (grep(!/^$foo$/, @files)) {
		# move it to the default changelist
		@output = &ExecuteP4Cmd("$P4 -s reopen -c default \"$file\"", $verbose);
		if ($? or grep(/^error:/i, @output) or !grep(/^exit:\s+0/i, @output)) {
		    my($bar) = join(//, @output);
		    &PrintError("$ThisCmd: could not move '$file' to the default changelist\n$bar");
		    &Exit(1);
		}
	    }
	}
    }

    #
    # Start the submit...
    $p4submit = "$P4 -s submit -i >$Platform{'tmp'} 2>&1";
    if (!open(SUBMITW, "| $p4submit")) {
	&PrintError("$ThisCmd: open \"| $p4submit\" failed: $!\n");
	&Exit(1);
    }

    # stuff it
    foreach (@default) {
	$error = print SUBMITW "$_\n";
	unless ($error) {
	    &PrintError("$ThisCmd: could not print '$error' to SUBMITW\n$!");
	    # print the tmp file anyway
	}
    }
    $error = close SUBMITW;
    unless ($error) {
	&PrintError("$ThisCmd: could not cleanly close SUBMITW\n$?");
	# try print the tmp file anyway
    }

    # OK, now we inspect the output from "p4 submit".
    if (!open(SUBMITR, "<$Platform{'tmp'}")) {
	&PrintError("$ThisCmd: open \"<$Platform{'tmp'}\" failed: $!");
	&Exit(1);
    }

    @output = <SUBMITR>;
    close SUBMITR;
    if ($? or grep(/^error:/i, @output) or !grep(/^exit:\s+0/i, @output)) {
	# an error occured - print the whole thing and exit
	my($foo) = join(//, @output);
	&PrintError("$ThisCmd: an error occured during the submit:\n$foo\n");
	&Exit(1);
    }
    else {
	foreach (@output) {
	    print STDOUT $_;
	}
    }
    return(0);
}

#
# revert unchanged files
sub RevertUnchangedFiles {
    my($arrayref) = @_;
    my(@revertedfiles);
    # note: diff returns files in workspace syntax
    my(@output) = &ExecuteP4Cmd("$P4 -s diff -sr", $verbose);
    chomp(@output);
    my(@files) = grep(/^info: /, @output);
    # @files are the list of files that are the same
    foreach my $file (@files) { 
	$file =~ s|^info: ||;	# remove info: token
	$file =~ s|\#.*$||;	# remove revision stuff
	my($realfilename) = &GetFilenameFromSyntax($file, "depot");
	my($safefile) = quotemeta($realfilename);
	next unless (grep(/^$safefile$/, @{$arrayref})); # only delete our files
	@output = &ExecuteP4Cmd("$P4 -s revert \"$file\"", $verbose);
	if (grep(/^error:/, @output) or $?) {
	    &PrintError("Could not revert file $file\n@output");
	    &Exit(1);
	}
	push @revertedfiles, $file;
    }
    return(@revertedfiles);
}

sub GetFilenameFromSyntax {
    my($file, $syntax) = @_;
    my($realfilename, @tmp);
    my(@out) = &ExecuteP4Cmd("$P4 where \"$file\"");
    if ($Platform{'os'} eq "win32") {
	@tmp = split(/ ([a-zA-Z]:\\)/, $out[0]);
	if ($#tmp == 2) {
	    # the expected number
	    my($foo, $bar) = split(/ \/\//, $tmp[0]);
	    if ($syntax eq "depot") {
		$realfilename = "$foo";
	    }
	    elsif ($syntax eq "client") {
		$realfilename = "//$bar";
	    }
	    else {
		$out[0] =~ / ([a-zA-Z]:\\)/;
		$realfilename = "$1$tmp[1]";
	    }
	}
    }
    else {
	@tmp = split(/ \//, $out[0]);
	if ($#tmp == 3) {
	    # the expected number
	    if ($syntax eq "depot") {
		$realfilename = "/$tmp[0]";
	    }
	    elsif ($syntax eq "client") {
		$realfilename = "/$tmp[1]";
	    }
	    else {
		$realfilename = "/$tmp[2]";
	    }
	}
    }
    unless ($realfilename) {
	die "Could not determine the workspace mapping of $file";
    }
    return($realfilename);
}