зеркало из https://github.com/mozilla/pjs.git
505 строки
19 KiB
Plaintext
505 строки
19 KiB
Plaintext
|
#!/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);
|
||
|
|
}
|