Permalink
Fetching contributors…
Cannot retrieve contributors at this time
executable file 499 lines (438 sloc) 14.3 KB
#!/usr/bin/perl -w
use strict;
use Cwd;
# Usage:
#
# ./sync-all [-q] [-s] [--ignore-failure] [-r repo]
# [--nofib] [--testsuite] [--checked-out] cmd [git flags]
#
# Applies the command "cmd" to each repository in the tree.
# sync-all will try to do the right thing for both git and darcs repositories.
#
# e.g.
# ./sync-all -r http://darcs.haskell.org/ghc get
# To get any repos which do not exist in the local tree
#
# ./sync-all pull
# To pull everything from the default repos
#
# -------------- Flags -------------------
# -q says to be quite, and -s to be silent.
#
# --ignore-failure says to ignore errors and move on to the next repository
#
# -r repo says to use repo as the location of package repositories
#
# --checked-out says that the remote repo is in checked-out layout, as
# opposed to the layout used for the main repo. By default a repo on
# the local filesystem is assumed to be checked-out, and repos accessed
# via HTTP or SSH are assumed to be in the main repo layout; use
# --checked-out to override the latter.
#
# --nofib, --testsuite also get the nofib and testsuite repos respectively
#
# ------------ Which repos to use -------------
# sync-all uses the following algorithm to decide which remote repos to use
#
# It always computes the remote repos from a single base, $repo_base
# How is $repo_base set?
# If you say "-r repo", then that's $repo_base
# otherwise $repo_base is set by asking git where the ghc repo came
# from, and removing the last component (e.g. /ghc.git/ of /ghc/).
#
# Then sync-all iterates over the package found in the file
# ./packages; see that file for a description of the contents.
#
# If $repo_base looks like a local filesystem path, or if you give
# the --checked-out flag, sync-all works on repos of form
# $repo_base/<local-path>
# otherwise sync-all works on repos of form
# $repo_base/<remote-path>
# This logic lets you say
# both sync-all -r http://darcs.haskell.org/ghc-6.12 pull
# and sync-all -r ../HEAD pull
# The latter is called a "checked-out tree".
# NB: sync-all *ignores* the defaultrepo of all repos other than the
# root one. So the remote repos must be laid out in one of the two
# formats given by <local-path> and <remote-path> in the file 'packages'.
$| = 1; # autoflush stdout after each print, to avoid output after die
my $defaultrepo;
my @packages;
my $verbose = 2;
my $ignore_failure = 0;
my $want_remote_repo = 0;
my $checked_out_flag = 0;
my $get_mode;
# Flags specific to a particular command
my $local_repo_unnecessary = 0;
my %tags;
# Figure out where to get the other repositories from.
sub getrepo {
my $basedir = ".";
my $repo;
if (defined($defaultrepo)) {
$repo = $defaultrepo;
chomp $repo;
} else {
# Figure out where to get the other repositories from,
# based on where this GHC repo came from.
my $branch = `git branch | grep "\* " | sed "s/^\* //"`; chomp $branch;
my $remote = `git config branch.$branch.remote`; chomp $remote;
$repo = `git config remote.$remote.url`; chomp $repo;
}
my $repo_base;
my $checked_out_tree;
if ($repo =~ /^...*:/) {
# HTTP or SSH
# Above regex says "at least two chars before the :", to avoid
# catching Win32 drives ("C:\").
$repo_base = $repo;
# --checked-out is needed if you want to use a checked-out repo
# over SSH or HTTP
if ($checked_out_flag) {
$checked_out_tree = 1;
} else {
$checked_out_tree = 0;
}
# Don't drop the last part of the path if specified with -r, as
# it expects repos of the form:
#
# http://darcs.haskell.org
#
# rather than
#
# http://darcs.haskell.org/ghc
#
if (!$defaultrepo) {
$repo_base =~ s#/[^/]+/?$##;
}
}
elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
# Local filesystem, either absolute or relative path
# (assumes a checked-out tree):
$repo_base = $repo;
$checked_out_tree = 1;
}
else {
die "Couldn't work out repo";
}
return $repo_base, $checked_out_tree;
}
sub parsePackages {
my @repos;
my $lineNum;
open IN, "< packages" or die "Can't open packages file";
@repos = <IN>;
close IN;
@packages = ();
$lineNum = 0;
foreach (@repos) {
chomp;
$lineNum++;
if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
my %line;
$line{"localpath"} = $1;
$line{"tag"} = $2;
$line{"remotepath"} = $3;
$line{"vcs"} = $4;
$line{"upstream"} = $5;
push @packages, \%line;
}
elsif (! /^(#.*)?$/) {
die "Bad content on line $lineNum of packages file: $_";
}
}
}
sub message {
if ($verbose >= 2) {
print "@_\n";
}
}
sub warning {
if ($verbose >= 1) {
print "warning: @_\n";
}
}
sub scm {
my $dir = shift;
my $scm = shift;
my $pwd;
if ($dir eq '.') {
message "== running $scm @_";
} else {
message "== $dir: running $scm @_";
$pwd = getcwd();
chdir($dir);
}
system ($scm, @_) == 0
or $ignore_failure
or die "$scm failed: $?";
if ($dir ne '.') {
chdir($pwd);
}
}
sub repoexists {
my ($scm, $localpath) = @_;
if ($scm eq "darcs") {
-d "$localpath/_darcs";
}
else {
-d "$localpath/.git";
}
}
sub scmall {
my $command = shift;
my $localpath;
my $tag;
my $remotepath;
my $scm;
my $upstream;
my $line;
my $branch_name;
my $subcommand;
my $path;
my $wd_before = getcwd;
my @scm_args;
my $pwd;
my @args;
my ($repo_base, $checked_out_tree) = getrepo();
my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/;
parsePackages;
@args = ();
if ($command =~ /^remote$/) {
while (@_ > 0 && $_[0] =~ /^-/) {
push(@args,shift);
}
if (@_ < 1) { help(); }
$subcommand = shift;
if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') {
help();
}
while (@_ > 0 && $_[0] =~ /^-/) {
push(@args,shift);
}
if (($subcommand eq 'add' || $subcommand eq 'rm') && @_ < 1) {
help();
} elsif (@_ < 1) { # set-url
$branch_name = 'origin';
} else {
$branch_name = shift;
}
} elsif ($command eq 'new' || $command eq 'fetch') {
if (@_ < 1) {
$branch_name = 'origin';
} else {
$branch_name = shift;
}
}
push(@args, @_);
for $line (@packages) {
$localpath = $$line{"localpath"};
$tag = $$line{"tag"};
$remotepath = $$line{"remotepath"};
$scm = $$line{"vcs"};
$upstream = $$line{"upstream"};
# We can't create directories on GitHub, so we translate
# "package/foo" into "package-foo".
if ($is_github_repo) {
$remotepath =~ s/\//-/;
}
# Check the SCM is OK as early as possible
die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
# Work out the path for this package in the repo we pulled from
if ($checked_out_tree) {
$path = "$repo_base/$localpath";
}
else {
$path = "$repo_base/$remotepath";
}
# Work out the arguments we should give to the SCM
if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
@scm_args = (($scm eq "darcs" and "whatsnew")
or ($scm eq "git" and "status"));
# Hack around 'darcs whatsnew' failing if there are no changes
$ignore_failure = 1;
}
elsif ($command =~ /^(?:pus|push)$/) {
@scm_args = "push";
$want_remote_repo = 1;
}
elsif ($command =~ /^(?:pul|pull)$/) {
@scm_args = "pull";
$want_remote_repo = 1;
# Q: should we append the -a argument for darcs repos?
}
elsif ($command =~ /^(?:g|ge|get)$/) {
# Skip any repositories we have not included the tag for
if (not defined($tags{$tag})) {
next;
}
if (-d $localpath) {
warning("$localpath already present; omitting") if $localpath ne ".";
next;
}
# The first time round the loop, default the get-mode
if ($scm eq "darcs" && not defined($get_mode)) {
warning("adding --partial, to override use --complete");
$get_mode = "--partial";
}
# The only command that doesn't need a repo
$local_repo_unnecessary = 1;
if ($scm eq "darcs") {
# Note: we can only use the get-mode with darcs for now
@scm_args = ("get", $get_mode, $path, $localpath);
}
else {
@scm_args = ("clone", $path, $localpath);
}
}
elsif ($command =~ /^(?:s|se|sen|send)$/) {
@scm_args = (($scm eq "darcs" and "send")
or ($scm eq "git" and "send-email"));
$want_remote_repo = 1;
}
elsif ($command =~ /^fetch$/) {
@scm_args = ("fetch", "$branch_name");
}
elsif ($command =~ /^new$/) {
@scm_args = ("log", "$branch_name..");
}
elsif ($command =~ /^remote$/) {
if ($subcommand eq 'add') {
@scm_args = ("remote", "add", $branch_name, $path);
} elsif ($subcommand eq 'rm') {
@scm_args = ("remote", "rm", $branch_name);
} elsif ($subcommand eq 'set-url') {
@scm_args = ("remote", "set-url", $branch_name, $path);
}
}
elsif ($command =~ /^grep$/) {
@scm_args = ("grep");
# Hack around 'git grep' failing if there are no matches
$ignore_failure = 1;
}
else {
die "Unknown command: $command";
}
# Actually execute the command
if (repoexists ($scm, $localpath)) {
if ($want_remote_repo) {
if ($scm eq "darcs") {
scm (".", $scm, @scm_args, @args, "--repodir=$localpath", $path);
} else {
# git pull doesn't like to be used with --work-dir
# I couldn't find an alternative to chdir() here
scm ($localpath, $scm, @scm_args, @args, $path, "master");
}
} else {
# git status *must* be used with --work-dir, if we don't chdir() to the dir
scm ($localpath, $scm, @scm_args, @args);
}
}
elsif ($local_repo_unnecessary) {
# Don't bother to change directory in this case
scm (".", $scm, @scm_args, @args);
}
elsif ($tag eq "") {
message "== Required repo $localpath is missing! Skipping";
}
else {
message "== $localpath repo not present; skipping";
}
}
}
sub help()
{
# Get the built in help
my $help = <<END;
What do you want to do?
Supported commands:
* whatsnew
* push
* pull
* get, with options:
* --<package-tag>
* --complete
* --partial
* fetch
* send
* new
* remote add <branch-name>
* remote rm <branch-name>
* remote set-url [--push] <branch-name>
* grep
Available package-tags are:
END
# Collect all the tags in the packages file
my %available_tags;
open IN, "< packages" or die "Can't open packages file";
while (<IN>) {
chomp;
if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
if (defined($2) && $2 ne "-") {
$available_tags{$2} = 1;
}
}
elsif (! /^(#.*)?$/) {
die "Bad line: $_";
}
}
close IN;
# Show those tags and the help text
my @available_tags = keys %available_tags;
print "$help@available_tags\n";
exit 1;
}
sub main {
if (! -d ".git" || ! -d "compiler") {
die "error: sync-all must be run from the top level of the ghc tree."
}
$tags{"-"} = 1;
$tags{"dph"} = 1;
while ($#_ ne -1) {
my $arg = shift;
# We handle -q here as well as lower down as we need to skip over it
# if it comes before the source-control command
if ($arg eq "-q") {
$verbose = 1;
}
elsif ($arg eq "-s") {
$verbose = 0;
}
elsif ($arg eq "-r") {
$defaultrepo = shift;
}
elsif ($arg eq "--ignore-failure") {
$ignore_failure = 1;
}
elsif ($arg eq "--complete" || $arg eq "--partial") {
$get_mode = $arg;
}
# Use --checked-out if the remote repos are a checked-out tree,
# rather than the master trees.
elsif ($arg eq "--checked-out") {
$checked_out_flag = 1;
}
# --<tag> says we grab the libs tagged 'tag' with
# 'get'. It has no effect on the other commands.
elsif ($arg =~ m/^--/) {
$arg =~ s/^--//;
$tags{$arg} = 1;
}
else {
unshift @_, $arg;
if (grep /^-q$/, @_) {
$verbose = 1;
}
last;
}
}
if ($#_ eq -1) {
help();
}
else {
# Give the command and rest of the arguments to the main loop
scmall @_;
}
}
main(@ARGV);