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

#
# $Id: //guest/sandy_currier/utils/p4revert.pl#1 $
#

#
# 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.
#

#
# Unbuffer STDERR and STDOUT
select(STDERR);
$| = 1;			# Make STDERR be unbuffered.
select(STDOUT);
$| = 1;			# STDOUT too so, they can mix.

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

#
# local variables
@info = ();			# the output of p4 info
$clientname = "";		# the "Client name: "
$clientroot = "";		# the "Client root: "
$cwd = "";			# the current working directory
@Changes = ();			# the list of changes
@RealFiles = ();		# the list of real files

#
# now parse any args
# the usage message (for -h or on error)
$help = "$ThisCmd changelist
Function:
    $ThisCmd will revert a changelist.  It will back out the changelist
    with the following caveats: added files will be deleted unless
    the file has been edited since it was added (in which case it is
    skipped); deleted files will be re-constituted from the deleted
    version; and edited files will be by auto-merged (if possible)
    to the head of the codeline.  If there is a conflict, it will be
    left unresolved.

    All changes are left checked out and must be submitted by hand.

Args:
    \@changelist ...  the single change to backout
                      
Switches/Options:
    -h               Prints this help message
";

#
# parse command line
{
    my($i, $param);
    while($i <= $#ARGV) {
	# scan for a help switch
	if ($ARGV[$i] =~ /^-h/i) {
	    &DieHelp("", $help);
	}
	# scan for switches
	elsif ($ARGV[$i] =~ /^-debug/i) {
	    $debug = 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'\n", $help);
	    }
	    $i=$i+2;
	}
	# catch unsupported switches
	elsif ($ARGV[$i] =~ /^-/) {
	    &DieHelp("Unsupported switch \"$ARGV[$i]\"\n", $help);
	}
	else {
	    # swallow files or a changeset
	    if ($ARGV[$i] =~ /^\@\S+/) {
		my($tmp) = $ARGV[$i];
		$tmp =~ s|^\@||; # remove the @
		push(@Changes, $tmp);
	    }
	    else {
		# a change without a @
		push(@Changes, $ARGV[$i]);
	    }
	    $i++; $param++;
	}
    }
}


#
# if debugging, re-arrange variables
if ($debug) {
    $verbose = 2;
}


#
# Note: if there is no args, prompt for an input (explorer launch support)
if ($#Changes < 0) {
    &TheEnd(0);
}


#
# make sure that a valid client is selected
{
    my($client_string) = "Client name: ";
    my($root_string) = "Client root: ";
    my($cwd_string) = "Current directory: ";
    my(@tmp);
    @info = &ExecuteP4Cmd("$P4 info", $verbose, 1);
    if ($?) {
	die "$ThisCmd - could not execute '$P4 info'\n$info";
    }
    chomp(@info);
    # now get client name
    @tmp = grep(/^$client_string/,@info); # grep out the client name
    $clientname = &other2unix($tmp[0]);	# transfer to a scalar
    $clientname =~ s/^$client_string//; # ditch the uninteresting part
    if ($clientname eq "") {	# check things
	die "$ThisCmd - something wrong - no client name found from p4 info output";
    }
    # get the client root
    @tmp = grep(/^$root_string/,@info); # grep out the client name
    $clientroot = &other2unix($tmp[0]);	# transfer to a scalar
    $clientroot =~ s/^$root_string//; # ditch the uninteresting part
    if ($clientroot eq "") {	# check things
	die "$ThisCmd - something wrong - no client name found from p4 info output";
    }
    # get the cwd
    @tmp = grep(/^$cwd_string/,@info); # grep out the client name
    $cwd = &other2unix($tmp[0]);	# transfer to a scalar
    $cwd =~ s/^$cwd_string//; # ditch the uninteresting part
    if ($cwd eq "") {	# check things
	die "$ThisCmd - something wrong - no cwd found from p4 info output";
    }
}


#
# before continuing, grab the already opened files for statistics
{
    @oldfiles = &ExecuteP4Cmd("$P4 opened", $verbose);
    chomp(@oldfiles);
    # if no files, will get "File(s) not opened on this client"
    if ($oldfiles[0] =~ /^File\(s\) not opened on this client/) {
	undef @oldfiles;
    }
}


#
# handle multiple changes
$change = "";
foreach $change (@Changes) {
    my($tmp, $script, @output, $line);
    my($DescribeCmd) = "$P4 describe -s"; # this gets the filelist from the changelist if supplied
    # describe the changeset
    # get the file list with revision number
    @output = &ExecuteP4Cmd("$DescribeCmd $change", $verbose, 1);
    # see if @output contains a files
    chomp(@output);
    foreach $line (@output) {
	# if not a valid file line, punt and go to next one
	next unless ($line =~ /^\.\.\. \/\/depot\//);
	# push the complete file spec into the array
	$line =~ s|^\.\.\. ||;	# remove beginning text
	push(@RealFiles, $line);
	my($file, $revision, $action) = &SplitFilename3($line);
	# note: the first action is for work done within the codeline
	#       the second action is for merged work of some type...
	if ($action eq "edit" or $action eq "integrate") {
	    push(@EditFiles, $file);
	}
	elsif ($action eq "add" or $action eq "branch") {
	    my(@tmp);
	    # note: if the current head of the file is not revision 1, then
	    # it has been edited.  If so, just warn and do not delete...
	    @tmp = &ExecuteP4Cmd("$P4 files \"$file\"");
	    # ignore errors?
	    my($f, $r) = &SplitFilename3($tmp[0]);
	    if ($r and $r ne "1") {
		&PrintWarning("Warning: the added file \"$file\",
is no longer at revision 1; it will not be deleted");
		push(@SkippedFiles, $file);
	    }
	    else {
		push(@AddFiles, $file);
	    }
	}
	elsif ($action eq "delete") {
	    push(@DeleteFiles, $file);
	}
	else {
	    &PrintError("unknown action for line\n$line");
	}
    }
}


#
# Note: the file list is now known.
# perform the sequence of commands to backout this change
{
    &PrintMessage("\nAbout to backout change $Changes[0]:\n");
}


#
# now back out the change
{
    my($tmp, @output, $script, $previous, $file);
    $previous = $Changes[0] - 1;
    # this is executed after all the integrates have been performed
    @output = &ExecuteP4Cmd("$P4 sync \@$previous", $verbose);

    # now loop over all edits
    &PrintMessage("checking out files for edit and add...") if ($verbose);
    foreach $file (@EditFiles) {
	@output = &ExecuteP4Cmd("$P4 edit \"$file\"");
    }
    # now loop over all deleted files and add them back in
    foreach $file (@DeleteFiles) {
	@output = &ExecuteP4Cmd("$P4 add \"$file\"");
    }
    # now do second sync
    @output = &ExecuteP4Cmd("$P4 sync \@$Changes[0]", $verbose);
    # now do resolve -ay (keep the backed out changes)
    @output = &ExecuteP4Cmd("$P4 resolve -ay", $verbose);
    # now sync to head
    @output = &ExecuteP4Cmd("$P4 sync", $verbose);
    # now do resolve (this could result in conflicts...)
    @output = &ExecuteP4Cmd("$P4 resolve -am", $verbose, 1);
    # delete those files that were added in the changeset
    foreach $file (@AddFiles) {
	@output = &ExecuteP4Cmd("$P4 delete \"$file\"", $verbose);
	# ignore errors?
    }
    # never script a submit
}

#
# now print something
{
    my($tmp, $string);

    # print some statistics?...
    @newfiles = &ExecuteP4Cmd("$P4 opened", $verbose);
    chomp(@newfiles);
    # compare the old with the new, and print something
    # construct a hash
    # if no files, will get "File(s) not opened on this client"
    if ($newfiles[0] =~ /^File\(s\) not opened on this client/) {
	undef @newfiles;
    }
    else {
	foreach (@newfiles) {
	    # let the entire string be the key
	    if (!defined($new{$_})) {
		$new{$_} = 1;
	    }
	}
	# delete from the hash anything that matches from @oldfiles
	foreach (@oldfiles) {
	    if (defined($new{$_})) {
		delete $new{$_};
	    }
	}
    }
    $string = sprintf "edited  %3d file(s)", $#EditFiles+1;
    &PrintNote($string);
    $string = sprintf "added   %3d file(s)", $#DeleteFiles+1;
    &PrintNote($string);
    $string = sprintf "deleted %3d file(s)", $#AddFiles+1;
    &PrintNote($string);
    $string = sprintf "skipped %3d file(s)", $#SkippedFiles+1;
    &PrintNote($string);
    $string = sprintf "        %3d total files", ($#RealFiles+1); 
    &PrintNote($string);
}

#
# the end
&TheEnd();

#
# subroutines (these should come from an include file, but not
# enough time now to set it up)
#

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

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

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

# can handle, somewhat, either # or @...
# Note: the output of a 'p4 change ...' will not be of the form
# ... //depot/main/scm/tests/bar#4 edit
# ... //depot/main/scm/tests/xxx#1 add
# ... //depot/main/scm/tests/zzz#1 add
#
# the output of s 'p4 files ...' will be something like
# //depot/main/scm/tests/foo#4 - edit change 1833 (text)
# try to handle both here...
sub SplitFilename3 {
    my($thing) = @_;
    my($f, $tmp, $r, $a, $d, $junk);
    if ($thing =~ /\#/){
	($f, $tmp) = split('#', $thing);
	$d = "\#";
    }
    elsif ($thing =~ /\@/) {
	($f, $tmp) = split('@', $thing);
	$d = "\@";
    }
    else {
	# hoping that the thing passed in is really a file...
	$f = $thing;
    }
    return($f, $r, $a, $d) unless ($tmp); # if empty $tmp, just return now
    if ($tmp =~ / - /) {
	($r, $a) = split(/ - /, $tmp); # split on the first ' - ' (here's hoping again)
    }
    else {
	# if no ' - ', split on first space...
	($r, $a) = split(/ /, $tmp);
    }
    ($a, $junk) = split(' ', $a); # just use first word
    return($f, $r, $a, $d);
}

# should not be called by a server
sub TheEnd {
    my($tmp);
    print STDERR "$err exiting with $Error{'Errors'} Error(s) & $Error{'Warnings'} Warning(s)\n";
    # exit with the number of errors in the bottom 16 bits
    # and the number of warnings in the top
    # Note: make sure that if things shift off, that error is at least still set
    $tmp = $Error{'Warnings'} << 16;
    $tmp |= $Error{'Errors'};
    # explicitly set $! to the explicit value
    # see the documentation on die
    exit($tmp);
}

sub PrintError {
    my($text, $stream_p) = @_;
    my($tmp);
    # first, increment error count
    $Error{'Errors'}++;
    # make sure $? is set
    $? = 1;
    # prepend with the correct prefix
    $text =~ s/^(.*)$/$err $1/gm;
    # store error away
    push(@{$Error{'ErrorSummary'}}, $text);
    # add a \n
    $text = "$text\n";
    # print and log (maybe)
    if ($stream_p) {
	print $stream_p "$text";
    }
    else {
	print STDERR "$text";
    }
    $LogOutput = "$LogOutput$text" if (defined($LogOutput));
    return($tmp);
}

# will increment $Error{'Warnings'} and append $err to every line
sub PrintWarning {
    my($text, $stream_p) = @_;
    my($tmp);
    # first, increment warning count
    $Error{'Warnings'}++;
    # prepend with the correct prefix
    $text =~ s/^(.*)$/$err $1/gm;
    # store error away
    push(@{$Error{'WarningSummary'}}, $text);
    # add a \n
    $text = "$text\n";
    # print and log (maybe)
    if ($stream_p) {
	print $stream_p "$text";
    }
    else {
	print STDERR "$text";
    }
    $LogOutput = "$LogOutput$text" if (defined($LogOutput));
    return($tmp);
}

# will append $vb to every line
sub PrintMessage {
    my($text, $stream_p) = @_;
    my($tmp);
    # prepend with the correct prefix
    $text =~ s/^(.*)$/$vb $1/gm;
    # add a \n
    $text = "$text\n";
    # print and log (maybe)
    if ($verbose) {
	if ($stream_p) {
	    print $stream_p "$text";
	}
	else {
	    print STDOUT "$text";
	}
    }
    $LogOutput = "$LogOutput$text" if (defined($LogOutput));
    return($tmp);
}

# will append $err to every line (but not set or increment any error variables)
sub PrintNote {
    my($text, $stream_p) = @_;
    my($tmp);
    # 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";
    }
    $LogOutput = "$LogOutput$text" if (defined($LogOutput));
    return($tmp);
}