sync-all

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Cwd;
   5
   6 # Figure out where to get the other repositories from,
   7 # based on where this GHC repo came from.
   8 my $branch = `git branch | grep "\* " | sed "s/^\* //"`; chomp $branch;
   9 my $remote = `git config branch.$branch.remote`;         chomp $remote;
  10 my $defaultrepo = `git config remote.$remote.url`;       chomp $defaultrepo;
  11
  12 my $defaultrepo_base;
  13 my $checked_out_tree;
  14
  15 if ($defaultrepo =~ /^...*:/) {
  16     # HTTP or SSH
  17     # Above regex says "at least two chars before the :", to avoid
  18     # catching Win32 drives ("C:\").
  19     $defaultrepo_base = $defaultrepo;
  20     $defaultrepo_base =~ s#/[^/]+/?$##;
  21     $checked_out_tree = 0;
  22 }
  23 elsif ($defaultrepo =~ /^\/|\.\.\/|.:(\/|\\)/) {
  24     # Local filesystem, either absolute or relative path
  25     # (assumes a checked-out tree):
  26     $defaultrepo_base = $defaultrepo;
  27     $checked_out_tree = 1;
  28 }
  29 else {
  30     die "Couldn't work out defaultrepo";
  31 }
  32
  33 my $verbose = 2;
  34 my $get_mode;
  35
  36 # Flags specific to a particular command
  37 my $ignore_failure = 0;
  38 my $local_repo_unnecessary = 0;
  39
  40 # Always define the empty tag so that we fetch the /required/ packages
  41 my %tags;
  42 $tags{""} = 1;
  43
  44 sub message {
  45     if ($verbose >= 2) {
  46         print "@_\n";
  47     }
  48 }
  49
  50 sub warning {
  51     if ($verbose >= 1) {
  52         print "warning: @_\n";
  53     }
  54 }
  55
  56 sub scm {
  57     my $scm = shift;
  58
  59     message "== running $scm @_";
  60     system ($scm, @_) == 0
  61         or $ignore_failure
  62         or die "$scm failed: $?";
  63 }
  64
  65 sub repoexists {
  66     my ($scm, $localpath) = @_;
  67
  68     if ($scm eq "darcs") {
  69         -d "$localpath/_darcs";
  70     }
  71     else {
  72         -d "$localpath/.git";
  73     }
  74 }
  75
  76 sub scmall {
  77     my $command = shift;
  78
  79     my $localpath;
  80     my $tag;
  81     my $remotepath;
  82     my $scm;
  83
  84     my $path;
  85     my $wd_before = getcwd;
  86
  87     my @scm_args;
  88
  89     open IN, "< packages" or die "Can't open packages file";
  90     while (<IN>) {
  91         chomp;
  92         if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
  93             $localpath = $1;
  94             $tag = defined($2) ? $2 : "";
  95             $remotepath = $3;
  96             $scm = $4;
  97
  98             # Check the SCM is OK as early as possible
  99             die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
 100
 101             # Work out the path for this package in the repo we pulled from
 102             if ($checked_out_tree) {
 103                 $path = "$defaultrepo_base/$localpath";
 104             }
 105             else {
 106                 $path = "$defaultrepo_base/$remotepath";
 107             }
 108
 109             # Work out the arguments we should give to the SCM
 110             if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
 111                 @scm_args = (($scm eq "darcs" and "whatsnew")
 112                           or ($scm eq "git" and "status"));
 113
 114                 # Hack around 'darcs whatsnew' failing if there are no changes
 115                 $ignore_failure = 1;
 116             }
 117             elsif ($command =~ /^(?:pus|push)$/) {
 118                 @scm_args = "push";
 119             }
 120             elsif ($command =~ /^(?:pul|pull)$/) {
 121                 @scm_args = "pull";
 122                 # Q: should we append the -a argument for darcs repos?
 123             }
 124             elsif ($command =~ /^(?:g|ge|get)$/) {
 125                 # Skip any repositories we have not included the tag for
 126                 if (not defined($tags{$tag})) {
 127                     next;
 128                 }
 129
 130                 if (-d $localpath) {
 131                     warning("$localpath already present; omitting") if $localpath ne ".";
 132                     next;
 133                 }
 134
 135                 # The first time round the loop, default the get-mode
 136                 if (not defined($get_mode)) {
 137                     warning("adding --partial, to override use --complete");
 138                     $get_mode = "--partial";
 139                 }
 140
 141                 # The only command that doesn't need a repo
 142                 $local_repo_unnecessary = 1;
 143
 144                 if ($scm eq "darcs") {
 145                     # Note: we can only use the get-mode with darcs for now
 146                     @scm_args = ("get", $get_mode, $path, $localpath);
 147                 }
 148                 else {
 149                     @scm_args = ("clone", $path, $localpath);
 150                 }
 151             }
 152             elsif ($command =~ /^(?:s|se|sen|send)$/) {
 153                 @scm_args = (($scm eq "darcs" and "send")
 154                           or ($scm eq "git" and "send-email"));
 155             }
 156             else {
 157                 die "Unknown command: $command";
 158             }
 159
 160             # Actually execute the command
 161             chdir $wd_before or die "Could not change to $wd_before";
 162             if (repoexists ($scm, $localpath)) {
 163                 chdir $localpath or die "Could not change to $localpath";
 164                 scm ($scm, @scm_args, @_);
 165             }
 166             elsif ($local_repo_unnecessary) {
 167                 # Don't bother to change directory in this case
 168                 scm ($scm, @scm_args, @_);
 169             }
 170             elsif ($tag eq "") {
 171                 message "== Required repo $localpath is missing! Skipping";
 172             }
 173             else {
 174                 message "== $localpath repo not present; skipping";
 175             }
 176         }
 177         elsif (! /^(#.*)?$/) {
 178             die "Bad line: $_";
 179         }
 180     }
 181     close IN;
 182 }
 183
 184 sub main {
 185     if (! -d ".git" || ! -d "compiler") {
 186         die "error: sync-all must be run from the top level of the ghc tree."
 187     }
 188
 189     while ($#_ ne -1) {
 190         my $arg = shift;
 191         # We handle -q here as well as lower down as we need to skip over it
 192         # if it comes before the source-control command
 193         if ($arg eq "-q") {
 194             $verbose = 1;
 195         }
 196         elsif ($arg eq "-s") {
 197             $verbose = 0;
 198         }
 199         elsif ($arg eq "--ignore-failure") {
 200             $ignore_failure = 1;
 201         }
 202         elsif ($arg eq "--complete" || $arg eq "--partial") {
 203             $get_mode = $arg;
 204         }
 205         # --<tag> says we grab the libs tagged 'tag' with
 206         # 'get'. It has no effect on the other commands.
 207         elsif ($arg =~ m/^--/) {
 208             $arg =~ s/^--//;
 209             $tags{$arg} = 1;
 210         }
 211         else {
 212             unshift @_, $arg;
 213             if (grep /^-q$/, @_) {
 214                 $verbose = 1;
 215             }
 216             last;
 217         }
 218     }
 219
 220     if ($#_ eq -1) {
 221         # Get the built in help
 222         my $help = <<END;
 223 What do you want to do?
 224 Supported commands:
 225
 226  * whatsnew
 227  * push
 228  * pull
 229  * get, with options:
 230   * --<package-tag>
 231   * --complete
 232   * --partial
 233  * send
 234
 235 Available package-tags are:
 236 END
 237
 238         # Collect all the tags in the packages file
 239         my %available_tags;
 240         open IN, "< packages" or die "Can't open packages file";
 241         while (<IN>) {
 242             chomp;
 243             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
 244                 if (defined($2)) {
 245                     $available_tags{$2} = 1;
 246                 }
 247             }
 248             elsif (! /^(#.*)?$/) {
 249                 die "Bad line: $_";
 250             }
 251         }
 252         close IN;
 253
 254         # Show those tags and the help text
 255         my @available_tags = keys %available_tags;
 256         print "$help@available_tags";
 257         exit 1;
 258     }
 259     else {
 260         # Give the command and rest of the arguments to the main loop
 261         scmall @_;
 262     }
 263 }
 264
 265 main(@ARGV);
 266