cross-commit

#!/usr/bin/perl -w

use strict;
use Getopt::Long;
Getopt::Long::Configure("bundling", "pass_through");
use File::Spec;
use File::Temp qw(tempfile tempdir);


################################################################################
# Configure Script

# Whether or not to be chatty about what we're doing.
# Set this on the command line with --verbose.
our $VERBOSE = 1;

# A horizontal rule for formatting lines.
my $ss = "--------------------------------------------------------------------";

# Whether or not to continue when we encounter a potentially serious problem.
# Set this on the command line with --live-dangerously.
our $DOUBLEOH7 = 0;

# The branches to land on.
# Set this on the command line once for each branch with --branch <name>.
our @branches;

# Convenient shorthand for --branch HEAD and --branch MOZILLA_1_8_BRANCH.
# Set these on the command line with --trunk and --moz18.
my $TRUNK;
my $MOZ18;

# The branches to land on if the user doesn't specify a branch.
my @DEFAULT_BRANCHES = qw(HEAD MOZILLA_1_8_BRANCH);

# The CVS options.  Some of these may not make sense in the context
# of this script.  Use them at your own risk.  Note that -f and -r are both
# CVS options and CVS commit options (i.e. they can go either before
# the command as general CVS options or after the commit command as different
# commit-specific options). To avoid ambiguity, you must specify
# the CVS options as --cvs-f and --cvs-r.
our $CVS_OPTION_allow_root;
our $CVS_OPTION_a;
our $CVS_OPTION_b;
our $CVS_OPTION_T;
our $CVS_OPTION_d;
our $CVS_OPTION_e;
our $CVS_OPTION_f;
our $CVS_OPTION_n;
our $CVS_OPTION_Q;
our $CVS_OPTION_q;
our $CVS_OPTION_r;
our $CVS_OPTION_s;
our $CVS_OPTION_t;
our $CVS_OPTION_v;
our $CVS_OPTION_w;
our $CVS_OPTION_x;
our $CVS_OPTION_z;

our @CVS_OPTIONS;

# The CVS commit options: -l -R -r -F <file> -f and -m.
# Some of these may not make sense in the context of this script.
# Use them at your own risk.
our $CVS_COMMIT_OPTION_l;
our $CVS_COMMIT_OPTION_R;
our $CVS_COMMIT_OPTION_r;
our $CVS_COMMIT_OPTION_F;
our $CVS_COMMIT_OPTION_f;
our $CVS_COMMIT_OPTION_m;

our @CVS_COMMIT_OPTIONS;

# Retrieve configuration from a config file, if any.  Config files are just
# regular Perl files and can override the values of all configuration variables
# declared above with "our".
my $cfg_file;
if    (-e ".xcconfig")   { $cfg_file = ".xcconfig" }
elsif (-e "~/.xcconfig") { $cfg_file = "~/.xcconfig" }
if ($cfg_file) {
    my $return = do $cfg_file;
    die "couldn't parse $cfg_file: $@" if $@;
    die "couldn't do $cfg_file: $!"    unless defined $return;
    die "couldn't run $cfg_file"       unless $return;
}

# Parse options from the command line.
GetOptions(
            # Options specific to this script.
            "verbose"               => \$VERBOSE,
            "trunk"                 => \$TRUNK,
            "moz18"                 => \$MOZ18,
            "branch=s"              => \@branches,
            "live-dangerously"      => \$DOUBLEOH7,

            # CVS options (those that go between "cvs" and "commit").
            "allow-root=s"          => \$CVS_OPTION_allow_root,
            "a"                     => \$CVS_OPTION_a,
            "b=s"                   => \$CVS_OPTION_b,
            "T=s"                   => \$CVS_OPTION_T,
            "d=s"                   => \$CVS_OPTION_d,
            "e=s"                   => \$CVS_OPTION_e,
            "cvs-f"                 => \$CVS_OPTION_f,
            "n"                     => \$CVS_OPTION_n,
            "Q"                     => \$CVS_OPTION_Q,
            "q"                     => \$CVS_OPTION_q,
            "cvs-r"                 => \$CVS_OPTION_r,
            "s"                     => \$CVS_OPTION_s,
            "t"                     => \$CVS_OPTION_t,
            "v|version"             => \$CVS_OPTION_v,
            "w"                     => \$CVS_OPTION_w,
            "x"                     => \$CVS_OPTION_x,
            "z"                     => \$CVS_OPTION_z,

            # CVS commit options (those that go after "commit").
            "l"                     => \$CVS_COMMIT_OPTION_l,
            "R"                     => \$CVS_COMMIT_OPTION_R,
            "r"                     => \$CVS_COMMIT_OPTION_r,
            "F=s"                   => \$CVS_COMMIT_OPTION_F,
            "f"                     => \$CVS_COMMIT_OPTION_f,
            "m=s"                   => \$CVS_COMMIT_OPTION_m,
          );


# The rest of the command line should be files or directories to commit.
# You can also leave it blank, in which case it'll check the current directory,
# just like "cvs commit" does.

push(@CVS_OPTIONS,
        $CVS_OPTION_allow_root ? ("--allow-root", $CVS_OPTION_allow_root) : (),
        $CVS_OPTION_a ? "-a"                   : (),
        $CVS_OPTION_b ? ("-b", $CVS_OPTION_b)  : (),
        $CVS_OPTION_T ? ("-T", $CVS_OPTION_T)  : (),
        $CVS_OPTION_d ? ("-d", $CVS_OPTION_d)  : (),
        $CVS_OPTION_e ? ("-e", $CVS_OPTION_e)  : (),
        $CVS_OPTION_f ? "-f"                   : (),
        $CVS_OPTION_n ? "-n"                   : (),
        $CVS_OPTION_Q ? "-Q"                   : (),
        $CVS_OPTION_q ? "-q"                   : (),
        $CVS_OPTION_r ? "-r"                   : (),
        $CVS_OPTION_s ? "-s"                   : (),
        $CVS_OPTION_t ? "-t"                   : (),
        $CVS_OPTION_v ? "-v"                   : (),
        $CVS_OPTION_w ? "-w"                   : (),
        $CVS_OPTION_x ? "-x"                   : (),
        $CVS_OPTION_z ? ("-z", $CVS_OPTION_z)  : (),
);

push(@CVS_COMMIT_OPTIONS,
        $CVS_COMMIT_OPTION_l ? "-l"                         : (),
        $CVS_COMMIT_OPTION_R ? "-R"                         : (),
        $CVS_COMMIT_OPTION_r ? "-r"                         : (),
        $CVS_COMMIT_OPTION_F ? ("-F", $CVS_COMMIT_OPTION_F) : (),
        $CVS_COMMIT_OPTION_f ? "-f"                         : (),
        $CVS_COMMIT_OPTION_m ? ("-m", $CVS_COMMIT_OPTION_m) : (),
);


################################################################################
# Initialize

# Duplicate the VERBOSE filehandle to STDOUT if we're being verbose;
# otherwise point it to /dev/null.
my $devnull = File::Spec->devnull();
open(VERBOSE, $VERBOSE ? ">-" : ">$devnull") or warn "Can't output verbose: $!";


################################################################################
# Get Modified Files and Current Branch

my $files = get_modified_files(\@ARGV);
if (scalar(keys(%$files)) == 0) {
    die "*** Didn't find any modified files.\n";
}
else {
    print VERBOSE "*** Modified Files:\n  " .
                  join("\n  ", sort(keys(%$files))) . "\n";
}

my $current_branch = get_current_branch($files);
print VERBOSE "*** Working Branch:\n  $current_branch\n";


################################################################################
# Get Branches to Land On

# Figure out what branches the user wants to land on.  Branches can be specified
# via "--branch <name>" or the "--trunk" and "--moz18" shortcuts.  If the user
# doesn't specify any branches, we land on the trunk and the MOZILLA_1_8_BRANCH.
push(@branches, "HEAD") if $TRUNK and !grep($_ eq "HEAD", @branches);
push(@branches, "MOZILLA_1_8_BRANCH")
  if $MOZ18 and !grep($_ eq "MOZILLA_1_8_BRANCH", @branches);
push(@branches, @DEFAULT_BRANCHES) if scalar(@branches) == 0;
print VERBOSE "*** Committing to Branches:\n  " . join("\n  ", @branches) .
              "\n";

################################################################################
# Check for Problems

# Make sure the changes apply cleanly to all branches the user wants
# to land them on.
my @conflicts;
foreach my $branch (@branches) {
    print VERBOSE "*** Checking for conflicts on $branch... ";
    foreach my $spec (sort(keys(%$files))) {
        my ($rv, $output, $errors) =
          run_cvs("update", [cvs_branch($branch), $spec], 1, 1);
        if ($rv != 0) {
            # These are spurious errors that go away once we check in
            # the removal to the working branch, so we can ignore them.
            # XXX Can we really?  Might they not also occur in other situations
            # where we shouldn't ignore them?
            if ($errors =~ m/removed $spec was modified by second party/) {
                print VERBOSE "(we can safely ignore this conflict)\n";
                next;
            }
            push(@conflicts, $branch);
        }
    }
}
if (scalar(@conflicts) > 0) {
    die "Conflicts found on " . join(", ", @conflicts) . ".\n"
        . "Please resolve them, then try your commit again.\n";
}
else {
    print VERBOSE "No conflicts found; good.\n";
}


################################################################################
# Land on Some Branch

# From now on, if we encounter an error, we should try to return the user's tree
# to its original state, so override the die handler with a function that tries
# to CVS update the tree back to the original working branch.
local $SIG{__DIE__} = sub {
    my ($message) = @_;

    print $message;
    print VERBOSE "*** Returning your tree to its original working branch... ";
    run_cvs("update", [cvs_branch($current_branch), keys(%$files)]);
    die;
};

# We gotta land somewhere once and then merge those changes into other branches.
my $land_branch;
if (grep($_ eq $current_branch, @branches)) {
    # The changes are landing on the current branch.  Groovy, let's land
    # there first.  It matters for additions and removals, I think.
    $land_branch = $current_branch;
}
else {
    # Just land on the first branch in the list.
    $land_branch = $branches[0];
    print VERBOSE "*** Switching to $land_branch... ";
    run_cvs("update", [cvs_branch($land_branch), keys(%$files)]);
}

print VERBOSE "*** Committing to $land_branch... ";
my ($rv, $output, $errors) =
  run_cvs("commit", [@CVS_COMMIT_OPTIONS, keys(%$files)]);


################################################################################
# Extract Commit Info

print VERBOSE "*** Extracting commit info.\n";
my @lines = (split/\n/, $output);
for ( my $i = 0 ; $i < scalar(@lines); $i++ ) {
    if ($lines[$i] =~ m/^(?:Checking in|Removing) (.*);$/) {
        my $spec = $1;
        print VERBOSE "  $spec: ";
        my $entry = $files->{$spec};
        $entry or die " not on the list of files committed!\n";
        $i += 2;
        $lines[$i] =~ m/^(initial|new)\srevision:\s
                        ([\d\.]+|delete)(?:;\s
                        previous\srevision:\s
                        ([\d\.]+))?$/x;
        if ($1 eq "new") {
            print VERBOSE "$3 -> $2.\n";
            $entry->{new_rev} = $2 eq "delete" ? "" : $2;
            $entry->{old_rev} = $3;
        }
        elsif ($1 eq "initial") {
            print VERBOSE "new file -> $2.\n";
            $entry->{new_rev} = $2;
            $entry->{old_rev} = "";
        }
        else {
            die "can't figure out its old and new revisions!\n";
        }
    }
}


################################################################################
# Check In to Other Branches

foreach my $branch (@branches) {
    next if $branch eq $land_branch;

    foreach my $spec (sort(keys(%$files))) {
        my $entry = $files->{$spec};

        if ($entry->{old_rev} && $entry->{new_rev}) {
            print VERBOSE "*** Merging $spec changes from $entry->{old_rev} " .
                          "to $entry->{new_rev} into $branch... ";
            run_cvs("update", [cvs_branch($branch), "-j", $entry->{old_rev},
                               "-j", $entry->{new_rev}, $spec]);
        }
        elsif ($entry->{old_rev}) {
            print VERBOSE "*** Removing $spec on $branch... ";
            # CVS doesn't tag removed files with a new revision number,
            # so we merge from the old revision to the branch itself.
            run_cvs("update", [cvs_branch($branch), "-j", $entry->{old_rev},
                               "-j", $land_branch, $spec]);
        }
        elsif ($entry->{new_rev}) {
            print VERBOSE "*** Adding $spec on $branch... ";
            run_cvs("update", [cvs_branch($branch), "-j", $entry->{new_rev},
                               $spec]);
        }

        print VERBOSE "*** Committing $spec on $branch... ";
        run_cvs("commit", [@CVS_COMMIT_OPTIONS, $spec]);
    }
}

print VERBOSE "*** Returning your tree to its original working branch... ";
run_cvs("update", [cvs_branch($current_branch), keys(%$files)]);

################################################################################
# Utility Functions

# Returns a hash of modified files indexed by file spec.
sub get_modified_files {
    my ($args) = @_;

    # We figure out which files are modified by running "cvs update"
    # and grepping for /^(M|A) /.  We run the command in dry run mode so we
    # don't actually update the files in the process.
    # XXX perhaps we should update them, since we won't be able to commit them
    # if they aren't up-to-date; on the other hand, CVS makes you update them
    # manually rather than automatically upon commit, so perhaps there's method
    # to its madness.

    print VERBOSE "*** Looking for modified files... ";
    my ($rv, $output, $errors) = run_cvs("update", $args, 1);
    # Break the output into lines and filter for lines about changes.
    my @lines = grep(m/^(M|A|R) /, split(/\n/, $output));
    my %files;
    foreach my $line (@lines) {
        $line =~ m/^(M|A|R) (.*)/;
        $files{$2} = get_cvs_file($2);
        $files{$2}->{change_type} = $1;
    }
    return \%files;
}

# Given a file spec, returns a hash of information about the file extracted
# from the CVS/Entries file.
sub get_cvs_file {
    my ($spec) = @_;
    my ($volume, $directories, $filename) = File::Spec->splitpath($spec);
    my $cvsdir = $directories ? File::Spec->catdir($directories, "CVS") : "CVS";
    my $files = File::Spec->catpath($volume, $cvsdir, "Entries");
    open(ENTRIES, "<", $files)
      or die "Can't read entries file $files for file $spec: $!";
    while (<ENTRIES>) {
        my ($name, $revision, $timestamp, $conflict, $options, $tagdate) =
          ($_ =~ m|/([^/]*)    # filename
                   /([^/]*)    # revision
                   /([^/+]*)   # timestamp
                   (\+[^/]*)?  # (optional) conflict
                   /([^/]*)    # options
                   /([^/]*)    # tag/date
                  |x);
        next if $name ne $filename;
        close ENTRIES;
        return { name => $name, revision => $revision, conflict => $conflict,
                 options => $options, tagdate => $tagdate };
    }
    die "Couldn't find entry for file $spec in entries file $files.";
}

# Given a set of files, extracts their current working branch, testing for
# multiple branches and date-based tags in the process.
sub get_current_branch {
    my ($files) = @_;
    my %branches;
    foreach my $filename (keys %$files) {
        my $entry = $files->{$filename};
        $entry->{tagdate} =~ m/^(T|D)?(.*)/;
        if    ($1 and $1 eq "D") { warn "$filename checked out by date $1\n" }
        elsif ($2 eq "")         { $branches{"HEAD"}++ }
        else                     { $branches{$2}++ }
        if (scalar(keys(%branches)) > 1 && !$DOUBLEOH7) {
            die("Modified files checked out from multiple branches:\n  "
                . join("\n  ", map("$_: $files->{$_}->{tagdate}",
                                   sort(keys(%$files))))
                . "Sounds scary, so I'm stopping.  Want me to continue?\n"
                . "Run me again with --live-dangerously and tell my authors\n"
                . "how it went.\n");
        }
    }
    return (keys(%branches))[0];
}

# Runs a CVS command and outputs the results.  Runs the command in dry run mode
# if dry run is enabled globally ($DRY_RUN) or for this specific function call;
# and dies on error by default, but can be set to merely warn on error.
# Returns the return value of the CVS command, its output, and its errors.
sub run_cvs {
    my ($cmd, $args, $dry_run, $warn_on_err) = @_;
    # Let callers override dry run setting, since certain information gathering
    # routines always run in dry run mode no matter what the global setting is.

    my ($rv, $output, $errors) =
      system_capture("cvs",
                     @CVS_OPTIONS,
                     $dry_run && !$CVS_OPTION_n ? "-n" : (),
                     $cmd,
                     @$args);
    if ($rv != 0) {
        if (!$warn_on_err) {
            die "\n$errors\n$ss\n";
        }
        warn "\n$errors\n$ss\n"
    }
    else {
        print VERBOSE "\n$output\n$ss\n";
    }
    return ($rv, $output, $errors);
}

# Returns the appropriate CVS command line argument for specifying a branch.
# Usually this is -r <branch name>, but if we're dealing with the special HEAD
# branch it's -A instead.
sub cvs_branch {
    my ($branch) = @_;
    return $branch eq "HEAD" ? "-A" : ("-r", $branch);
}

# Runs a command and captures its output and errors.
# Returns the command's exit code, output, and errors.
sub system_capture {
    # XXX This should be using in-memory files, but they require that we close
    # STDOUT and STDERR before reopening them on the in-memory files, and doing
    # that on STDERR causes CVS to choke with return value 256.
  
    my ($command, @args) = @_;
  
    my ($rv, $output, $errors);
  
    # Back up the original STDOUT and STDERR so we can restore them later.
    open(OLDOUT, ">&STDOUT") or die "Can't back up STDOUT to OLDOUT: $!";
    open(OLDERR, ">&STDERR") or die "Can't back up STDERR to OLDERR: $!";
    use vars qw( *OLDOUT *OLDERR ); # suppress "used only once" warnings
  
    # Close and reopen STDOUT and STDERR to in-memory files, which are just
    # scalars that take output and append it to their value.
    # XXX Disabled in-memory files in favor of temp files until in-memory issues
    # can be worked out.
    #close(STDOUT);
    #close(STDERR);
    #open(STDOUT, ">", \$output) or die "Can't open STDOUT to output var: $!";
    #open(STDERR, ">", \$errors) or die "Can't open STDERR to errors var: $!";
    my $outfile = tempfile();
    my $errfile = tempfile();
    # Perl 5.6.1 filehandle duplication doesn't support the three-argument form
    # of open, so we can't just open(STDOUT, ">&", $outfile); instead we have to
    # create an alias OUTFILE and then do open(STDOUT, ">&OUTFILE").
    local *OUTFILE = *$outfile;
    local *ERRFILE = *$errfile;
    use vars qw( *OUTFILE *ERRFILE ); # suppress "used only once" warnings
    open(STDOUT, ">&OUTFILE") or open(STDOUT, ">&OLDOUT")
                                 and die "Can't dupe STDOUT to output file: $!";
    open(STDERR, ">&ERRFILE") or open(STDOUT, ">&OLDOUT")
                                 and open(STDERR, ">&OLDERR")
                                 and die "Can't dupe STDERR to errors file: $!";
  
    # Run the command.
    print VERBOSE "$command " . join(" ", @args) . "\n";
    $rv = system($command, @args);
  
    # Grab output and errors from the temp files.  In a block to localize $/.
    # XXX None of this would be necessary if in-memory files was working.
    {
        local $/ = undef;
        seek($outfile, 0, 0);
        seek($errfile, 0, 0);
        $output = <$outfile>;
        $errors = <$errfile>;
    }

    # Restore original STDOUT and STDERR.
    close(STDOUT);
    close(STDERR);
    open(STDOUT, ">&OLDOUT") or die "Can't restore STDOUT from OLDOUT: $!";
    open(STDERR, ">&OLDERR") or die "Can't restore STDERR from OLDERR: $!";

    return ($rv, $output, $errors);
}