$| = 1; # autoflush stdout after each print, to avoid output after die
+my $initial_working_directory;
+
my $defaultrepo;
my @packages;
my $verbose = 2;
my %tags;
+sub inDir {
+ my $dir = shift;
+ my $code = shift;
+
+ if ($dir ne '.') {
+ chdir($dir);
+ }
+
+ my $result = &$code();
+
+ if ($dir ne '.') {
+ chdir($initial_working_directory);
+ }
+ return $result;
+}
+
+sub parsePackages {
+ my @repos;
+ my $lineNum;
+
+ open IN, "< packages.conf"
+ or open IN, "< packages" # clashes with packages directory when using --bare
+ or die "Can't open packages file (or packages.conf)";
+ @repos = <IN>;
+ close IN;
+
+ @packages = ();
+ $lineNum = 0;
+ foreach (@repos) {
+ chomp;
+ $lineNum++;
+ if (/^([^# ]+) +([^ ]+) +([^ ]+)$/) {
+ my %line;
+ $line{"localpath"} = $1;
+ $line{"tag"} = $2;
+ $line{"remotepath"} = $3;
+ push @packages, \%line;
+ }
+ elsif (! /^(#.*)?$/) {
+ die "Bad content on line $lineNum of packages file: $_";
+ }
+ }
+}
+
+sub tryReadFile {
+ my $filename = shift;
+ my @lines;
+
+ open (FH, $filename) or return "";
+ @lines = <FH>;
+ close FH;
+ return join('', @lines);
+}
+
+sub message {
+ if ($verbose >= 2) {
+ print "@_\n";
+ }
+}
+
+sub warning {
+ if ($verbose >= 1) {
+ print "warning: @_\n";
+ }
+}
+
+sub gitNewWorkdir {
+ my $dir = shift;
+ my $target = shift;
+ my $target_dir = "$target/$dir";
+
+ if ($dir eq '.') {
+ message "== running git-new-workdir . $target_dir @_";
+ } else {
+ message "== $dir: running git-new-workdir . $target_dir @_";
+ chdir($dir);
+ }
+
+ system ("git-new-workdir", ".", $target_dir, @_) == 0
+ or $ignore_failure
+ or die "git-new-workdir failed: $?";
+
+ if ($dir ne '.') {
+ chdir($initial_working_directory);
+ }
+}
+
+sub git {
+ my $dir = shift;
+ my @args = @_;
+
+ &inDir($dir, sub {
+ my $prefix = $dir eq '.' ? "" : "$dir: ";
+ message "== ${prefix}running git @args";
+
+ system ("git", @args) == 0
+ or $ignore_failure
+ or die "git failed: $?";
+ });
+}
+
+sub readgit {
+ my $dir = shift;
+ my @args = @_;
+
+ &inDir($dir, sub {
+ open my $fh, '-|', 'git', @args
+ or die "Executing git @args failed: $!";
+ my $line = <$fh>;
+ $line = "" unless defined($line);
+ chomp $line;
+ close $fh;
+ return $line;
+ });
+}
+
+sub configure_repository {
+ my $localpath = shift;
+
+ &git($localpath, "config", "--local", "core.ignorecase", "true");
+
+ my $autocrlf = &readgit($localpath, 'config', '--get', 'core.autocrlf');
+ if ($autocrlf eq "true") {
+ &git($localpath, "config", "--local", "core.autocrlf", "false");
+ &git($localpath, "reset", "--hard");
+ }
+}
+
# Figure out where to get the other repositories from.
sub getrepo {
my $repo;
} else {
# Figure out where to get the other repositories from,
# based on where this GHC repo came from.
- my $git_dir = $bare_flag ? "--git-dir=ghc.git" : "";
- my $branch = `git $git_dir branch | grep "\* " | sed "s/^\* //"`; chomp $branch;
- my $remote = `git $git_dir config branch.$branch.remote`; chomp $remote;
+ my $git_dir = $bare_flag ? "ghc.git" : ".";
+ my $branch = &readgit($git_dir, "rev-parse", "--abbrev-ref", "HEAD");
+ die "Bad branch: $branch"
+ unless $branch =~ /^[a-zA-Z][a-zA-Z0-9.-]*$/;
+ my $remote = &readgit($git_dir, "config", "branch.$branch.remote");
if ($remote eq "") {
# remotes are not mandatory for branches (e.g. not recorded by default for bare repos)
$remote = "origin";
}
- $repo = `git $git_dir config remote.$remote.url`; chomp $repo;
+ die "Bad remote: $remote"
+ unless $remote =~ /^[a-zA-Z][a-zA-Z0-9.-]*$/;
+ $repo = &readgit($git_dir, "config", "remote.$remote.url");
}
my $repo_base;
return $repo_base, $checked_out_tree;
}
-sub parsePackages {
- my @repos;
- my $lineNum;
-
- open IN, "< packages.conf"
- or open IN, "< packages" # clashes with packages directory when using --bare
- or die "Can't open packages file (or packages.conf)";
- @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;
- 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 scmall {
+sub gitall {
my $command = shift;
my $localpath;
my $tag;
my $remotepath;
- my $scm;
my $line;
my $branch_name;
my $subcommand;
my $path;
- my $wd_before = getcwd;
- my $pwd;
my @args;
my $started;
}
if (@_ < 1) { help(1); }
$subcommand = shift;
- if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') {
+ if ($subcommand ne 'add' &&
+ $subcommand ne 'rm' &&
+ $subcommand ne 'set-branches' &&
+ $subcommand ne 'set-url') {
help(1);
}
while (@_ > 0 && $_[0] =~ /^-/) {
for $line (@packages) {
$tag = $$line{"tag"};
- $scm = $$line{"vcs"};
# Use the "remote" structure for bare git repositories
- $localpath = ($bare_flag && $scm eq "git") ?
+ $localpath = ($bare_flag) ?
$$line{"remotepath"} : $$line{"localpath"};
$remotepath = ($checked_out_tree) ?
$$line{"localpath"} : $$line{"remotepath"};
close RESUME;
rename "resume.tmp", "resume";
- # Check the SCM is OK as early as possible
- die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
-
# We can't create directories on GitHub, so we translate
# "packages/foo" into "package-foo".
if ($is_github_repo) {
# Construct the path for this package in the repo we pulled from
$path = "$repo_base/$remotepath";
- if ($command =~ /^(?:g|ge|get)$/) {
+ if ($command eq "get") {
+ next if $remotepath eq "-"; # "git submodule init/update" will get this later
+
# Skip any repositories we have not included the tag for
if (not defined($tags{$tag})) {
$tags{$tag} = 0;
if (-d $localpath) {
warning("$localpath already present; omitting")
if $localpath ne ".";
- if ($scm eq "git") {
- scm ($localpath, $scm, "config", "core.ignorecase", "true");
- }
+ &configure_repository($localpath);
next;
}
# Note that we use "." as the path, as $localpath
# doesn't exist yet.
- if ($scm eq "darcs") {
- # The first time round the loop, default the get-mode
- if (not defined($get_mode)) {
- warning("adding --partial, to override use --complete");
- $get_mode = "--partial";
- }
- scm (".", $scm, "get", $get_mode, $path, $localpath, @args);
- }
- else {
- my @argsWithBare = @args;
- push @argsWithBare, $bare_flag if $bare_flag;
- scm (".", $scm, "clone", $path, $localpath, @argsWithBare);
- scm ($localpath, $scm, "config", "core.ignorecase", "true");
- }
+ my @argsWithBare = @args;
+ push @argsWithBare, $bare_flag if $bare_flag;
+ &git(".", "clone", $path, $localpath, @argsWithBare);
+ &configure_repository($localpath);
next;
}
- my $darcs_repo_present = 1 if -d "$localpath/_darcs";
- my $git_repo_present = 1 if -d "$localpath/.git" || ($bare_flag && -d "$localpath");
- if ($darcs_repo_present) {
- if ($git_repo_present) {
- die "Found both _darcs and .git in $localpath";
- }
- $scm = "darcs";
- } elsif ($git_repo_present) {
- $scm = "git";
- } elsif ($tag eq "") {
- die "Required repo $localpath is missing";
- } else {
- message "== $localpath repo not present; skipping";
- next;
- }
-
- # Work out the arguments we should give to the SCM
- if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
- if ($scm eq "darcs") {
- $command = "whatsnew";
- }
- elsif ($scm eq "git") {
- $command = "status";
+ my $git_repo_present = 1 if -e "$localpath/.git" || ($bare_flag && -d "$localpath");
+ if (not $git_repo_present) {
+ if ($tag eq "") {
+ die "Required repo $localpath is missing";
}
else {
- die "Unknown scm";
+ message "== $localpath repo not present; skipping";
+ next;
}
+ }
- # Hack around 'darcs whatsnew' failing if there are no changes
- $ignore_failure = 1;
- scm ($localpath, $scm, $command, @args);
+ # Work out the arguments we should give to the SCM
+ if ($command eq "status") {
+ &git($localpath, $command, @args);
}
- elsif ($command =~ /^commit$/) {
+ elsif ($command eq "commit") {
# git fails if there is nothing to commit, so ignore failures
$ignore_failure = 1;
- scm ($localpath, $scm, "commit", @args);
- }
- elsif ($command =~ /^(?:pus|push)$/) {
- scm ($localpath, $scm, "push", @args);
- }
- elsif ($command =~ /^(?:pul|pull)$/) {
- scm ($localpath, $scm, "pull", @args);
+ &git($localpath, "commit", @args);
+ }
+ elsif ($command eq "check_submodules") {
+ # If we have a submodule then check whether it is up-to-date
+ if ($remotepath eq "-") {
+ my %remote_heads;
+
+ message "== Checking sub-module $localpath";
+
+ chdir($localpath);
+
+ open my $lsremote, '-|', 'git', 'ls-remote', '--heads', '-q'
+ or die "Executing ls-remote failed: $!";
+ while (<$lsremote>) {
+ if (/^([0-9a-f]{40})\s*refs\/heads\//) {
+ $remote_heads{$1} = 1;
+ }
+ else {
+ die "Bad output from ls-remote: $_";
+ }
+ }
+ close($lsremote);
+
+ my $myhead = &readgit('.', 'rev-parse', '--verify', 'HEAD');
+
+ if (not defined($remote_heads{$myhead})) {
+ die "Sub module $localpath needs to be pushed; see http://hackage.haskell.org/trac/ghc/wiki/Repositories/Upstream";
+ }
+
+ chdir($initial_working_directory);
+ }
}
- elsif ($command =~ /^(?:s|se|sen|send)$/) {
- if ($scm eq "darcs") {
- $command = "send";
+ elsif ($command eq "push") {
+ # We don't automatically push to the submodules. If you want
+ # to push to them then you need to use a special command, as
+ # described on
+ # http://hackage.haskell.org/trac/ghc/wiki/Repositories/Upstream
+ if ($remotepath ne "-") {
+ &git($localpath, "push", @args);
}
- elsif ($scm eq "git") {
- $command = "send-email";
+ }
+ elsif ($command eq "pull") {
+ my $realcmd;
+ my @realargs;
+ if ($remotepath eq "-") {
+ # Only fetch for the submodules. "git submodule update"
+ # will take care of making us point to the right commit.
+ $realcmd = "fetch";
+ # we like "sync-all pull --rebase" to work:
+ @realargs = grep(!/--rebase/,@args);
}
else {
- die "Unknown scm";
+ $realcmd = "pull";
+ @realargs = @args;
}
- scm ($localpath, $scm, $command, @args);
+ &git($localpath, $realcmd, @realargs);
}
- elsif ($command =~ /^fetch$/) {
- scm ($localpath, $scm, "fetch", @args);
+ elsif ($command eq "new-workdir") {
+ gitNewWorkdir ($localpath, @args);
}
- elsif ($command =~ /^new$/) {
+ elsif ($command eq "send") {
+ $command = "send-email";
+ &git($localpath, $command, @args);
+ }
+ elsif ($command eq "fetch") {
+ &git($localpath, "fetch", @args);
+ }
+ elsif ($command eq "new") {
my @scm_args = ("log", "$branch_name..");
- scm ($localpath, $scm, @scm_args, @args);
+ &git($localpath, @scm_args, @args);
}
- elsif ($command =~ /^log$/) {
- scm ($localpath, $scm, "log", @args);
+ elsif ($command eq "log") {
+ &git($localpath, "log", @args);
}
- elsif ($command =~ /^remote$/) {
+ elsif ($command eq "remote") {
my @scm_args;
+ my $rpath;
$ignore_failure = 1;
+ if ($remotepath eq '-') {
+ $rpath = "$repo_base/$localpath";
+ } else {
+ $rpath = $path;
+ }
if ($subcommand eq 'add') {
- @scm_args = ("remote", "add", $branch_name, $path);
+ @scm_args = ("remote", "add", $branch_name, $rpath);
} elsif ($subcommand eq 'rm') {
@scm_args = ("remote", "rm", $branch_name);
+ } elsif ($subcommand eq 'set-branches') {
+ @scm_args = ("remote", "set-branches", $branch_name);
} elsif ($subcommand eq 'set-url') {
- @scm_args = ("remote", "set-url", $branch_name, $path);
+ @scm_args = ("remote", "set-url", $branch_name, $rpath);
}
- scm ($localpath, $scm, @scm_args, @args);
+ &git($localpath, @scm_args, @args);
}
- elsif ($command =~ /^checkout$/) {
+ elsif ($command eq "checkout") {
# Not all repos are necessarily branched, so ignore failure
$ignore_failure = 1;
- scm ($localpath, $scm, "checkout", @args)
- unless $scm eq "darcs";
+ &git($localpath, "checkout", @args);
}
- elsif ($command =~ /^grep$/) {
+ elsif ($command eq "grep") {
# Hack around 'git grep' failing if there are no matches
$ignore_failure = 1;
- scm ($localpath, $scm, "grep", @args)
- unless $scm eq "darcs";
+ &git($localpath, "grep", @args);
+ }
+ elsif ($command eq "diff") {
+ &git($localpath, "diff", @args);
}
- elsif ($command =~ /^diff$/) {
- scm ($localpath, $scm, "diff", @args)
- unless $scm eq "darcs";
+ elsif ($command eq "clean") {
+ &git($localpath, "clean", @args);
}
- elsif ($command =~ /^clean$/) {
- scm ($localpath, $scm, "clean", @args)
- unless $scm eq "darcs";
+ elsif ($command eq "reset") {
+ &git($localpath, "reset", @args);
}
- elsif ($command =~ /^reset$/) {
- scm ($localpath, $scm, "reset", @args)
- unless $scm eq "darcs";
+ elsif ($command eq "branch") {
+ &git($localpath, "branch", @args);
}
- elsif ($command =~ /^branch$/) {
- scm ($localpath, $scm, "branch", @args)
- unless $scm eq "darcs";
+ elsif ($command eq "config") {
+ &git($localpath, "config", @args);
}
- elsif ($command =~ /^config$/) {
- scm ($localpath, $scm, "config", @args)
- unless $scm eq "darcs";
+ elsif ($command eq "repack") {
+ &git($localpath, "repack", @args);
}
- elsif ($command =~ /^repack$/) {
- scm ($localpath, $scm, "repack", @args)
- if $scm eq "git"
+ elsif ($command eq "format-patch") {
+ &git($localpath, "format-patch", @args);
}
- elsif ($command =~ /^format-patch$/) {
- scm ($localpath, $scm, "format-patch", @args)
- if $scm eq "git"
+ elsif ($command eq "gc") {
+ &git($localpath, "gc", @args);
}
- elsif ($command =~ /^gc$/) {
- scm ($localpath, $scm, "gc", @args)
- unless $scm eq "darcs";
+ elsif ($command eq "tag") {
+ &git($localpath, "tag", @args);
+ }
+ elsif ($command eq "compare") {
+ # Don't compare the subrepos; it doesn't work properly as
+ # they aren't on a branch.
+ next if $remotepath eq "-";
+
+ my $compareto;
+ if ($#args eq -1) {
+ $compareto = $path;
+ }
+ elsif ($#args eq 0) {
+ $compareto = "$args[0]/$localpath";
+ }
+ elsif ($#args eq 1 && $args[0] eq "-b") {
+ $compareto = "$args[1]/$remotepath";
+ }
+ else {
+ die "Bad args for compare";
+ }
+ print "$localpath";
+ print (' ' x (40 - length($localpath)));
+ my $branch = &readgit($localpath, "rev-parse", "--abbrev-ref", "HEAD");
+ die "Bad branch: $branch"
+ unless $branch =~ /^[a-zA-Z][a-zA-Z0-9.-]*$/;
+ my $us = &readgit(".", "ls-remote", $localpath, "refs/heads/$branch");
+ my $them = &readgit(".", "ls-remote", $compareto, "refs/heads/$branch");
+ $us =~ s/[[:space:]].*//;
+ $them =~ s/[[:space:]].*//;
+ die "Bad commit of mine: $us" unless (length($us) eq 40);
+ die "Bad commit of theirs: $them" unless (length($them) eq 40);
+ if ($us eq $them) {
+ print "same\n";
+ }
+ else {
+ print "DIFFERENT\n";
+ }
}
else {
die "Unknown command: $command";
would point to the ghc repository, and for a remote repository it
points to the directory containing "ghc.git".
+compare
+compare reporoot
+compare -b reporoot
+
+ Compare the git HEADs of the repos to the origin repos, or the
+ repos under reporoot (which is assumde to be a checked-out tree
+ unless the -b flag is used).
+
+ 1 line is printed for each repo, indicating whether the repo is
+ at the "same" or a "DIFFERENT" commit.
+
These commands just run the equivalent git command on each repository, passing
any extra arguments to git:
grep
log
new
+ new-workdir
pull
push
repack
reset
send
status
+ tag
-------------- Flags -------------------
These flags are given *before* the command and modify the way sync-all behaves.
}
else {
# Give the command and rest of the arguments to the main loop
- scmall @_;
+ # We normalise command names here to avoid duplicating the
+ # abbreviations that we allow.
+ my $command = shift;
+
+ if ($command =~ /^(?:g|ge|get)$/) {
+ $command = "get";
+ }
+ elsif ($command =~ /^(?:pus|push)$/) {
+ $command = "push";
+ }
+ elsif ($command =~ /^(?:pul|pull)$/) {
+ $command = "pull";
+ }
+ elsif ($command =~ /^(?:s|se|sen|send)$/) {
+ $command = "send";
+ }
+ elsif ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
+ $command = "status";
+ }
+
+ if ($command eq "push") {
+ &gitall("check_submodules", @_);
+ }
+
+ &gitall($command, @_);
+
+ my @submodule_args = grep(/^-q/,@_);
+
+ if ($command eq "get") {
+ &git(".", "submodule", "init", @submodule_args);
+ }
+ if ($command eq "pull") {
+ my $gitConfig = &tryReadFile(".git/config");
+ if ($gitConfig !~ /submodule/) {
+ &git(".", "submodule", "init", @submodule_args);
+ }
+ }
+ if ($command eq "get" or $command eq "pull") {
+ my $gitConfig = &tryReadFile(".git/config");
+ if ($gitConfig !~ /submodule/) {
+ &git(".", "submodule", "init", @submodule_args);
+ }
+ &git(".", "submodule", "update", @submodule_args);
+ }
}
}
+BEGIN {
+ $initial_working_directory = getcwd();
+}
+
END {
my $ec = $?;
- my $pwd = getcwd();
+
+ chdir($initial_working_directory);
message "== Checking for old haddock repo";
if (-d "utils/haddock/.git") {
============================
EOF
}
- chdir($pwd);
+ chdir($initial_working_directory);
}
message "== Checking for old binary repo";
============================
EOF
}
- chdir($pwd);
+ chdir($initial_working_directory);
+ }
+
+ message "== Checking for old mtl repo";
+ if (-d "libraries/mtl/.git") {
+ chdir("libraries/mtl");
+ if ((system "git log -1 c67d8f7247c612dc35242bc67e616f7ea35eadb9 > /dev/null 2> /dev/null") == 0) {
+ print <<EOF;
+============================
+ATTENTION!
+
+You have an old mtl repository in your GHC tree!
+
+Please remove it (e.g. "rm -r libraries/mtl"), and then run
+"./sync-all get" to get the new repository.
+============================
+EOF
+ }
+ chdir($initial_working_directory);
+ }
+
+ message "== Checking for old Cabal repo";
+ if (-d "libraries/Cabal/.git") {
+ chdir("libraries/Cabal");
+ if ((system "git log -1 c8ebd66a32865f72ae03ee0663c62df3d77f08fe > /dev/null 2> /dev/null") == 0) {
+ print <<EOF;
+============================
+ATTENTION!
+
+You have an old Cabal repository in your GHC tree!
+
+Please remove it (e.g. "rm -r libraries/Cabal"), and then run
+"./sync-all get" to get the new repository.
+============================
+EOF
+ }
+ chdir($initial_working_directory);
+ }
+
+ message "== Checking for old time from tarball";
+ if (-d "libraries/time" and ! -e "libraries/time/.git") {
+ print <<EOF;
+============================
+ATTENTION!
+
+You have an old time package in your GHC tree!
+
+Please remove it (e.g. "rm -r libraries/time"), and then run
+"./sync-all get" to get the new repository.
+============================
+EOF
}
$? = $ec;
git.haskell.org / ghc.git / blobdiff