sync-all

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Cwd;
   5
   6 my $defaultrepo;
   7 my @packages;
   8 my $verbose = 2;
   9 my $ignore_failure = 0;
  10 my $want_remote_repo = 0;
  11 my $checked_out_flag = 0;
  12 my $get_mode;
  13
  14 # Flags specific to a particular command
  15 my $local_repo_unnecessary = 0;
  16
  17 my %tags;
  18
  19 # Figure out where to get the other repositories from.
  20 sub getrepo {
  21     my $basedir = ".";
  22     my $repo;
  23
  24     if (defined($defaultrepo)) {
  25         $repo = $defaultrepo;
  26         chomp $repo;
  27     } else {
  28         # Figure out where to get the other repositories from,
  29         # based on where this GHC repo came from.
  30         my $branch = `git branch | grep "\* " | sed "s/^\* //"`; chomp $branch;
  31         my $remote = `git config branch.$branch.remote`;         chomp $remote;
  32         $repo = `git config remote.$remote.url`;       chomp $repo;
  33     }
  34
  35     my $repo_base;
  36     my $checked_out_tree;
  37
  38     if ($repo =~ /^...*:/) {
  39         # HTTP or SSH
  40         # Above regex says "at least two chars before the :", to avoid
  41         # catching Win32 drives ("C:\").
  42         $repo_base = $repo;
  43
  44         # --checked-out is needed if you want to use a checked-out repo
  45         # over SSH or HTTP
  46         if ($checked_out_flag) {
  47             $checked_out_tree = 1;
  48         } else {
  49             $checked_out_tree = 0;
  50         }
  51
  52         # Don't drop the last part of the path if specified with -r, as
  53         # it expects repos of the form:
  54         #
  55         #   http://darcs.haskell.org
  56         #
  57         # rather than
  58         #
  59         #   http://darcs.haskell.org/ghc
  60         #
  61         if (!$defaultrepo) {
  62             $repo_base =~ s#/[^/]+/?$##;
  63         }
  64     }
  65     elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
  66         # Local filesystem, either absolute or relative path
  67         # (assumes a checked-out tree):
  68         $repo_base = $repo;
  69         $checked_out_tree = 1;
  70     }
  71     else {
  72         die "Couldn't work out repo";
  73     }
  74
  75     return $repo_base, $checked_out_tree;
  76 }
  77
  78 sub parsePackages {
  79     my @repos;
  80     my $lineNum;
  81
  82     open IN, "< packages" or die "Can't open packages file";
  83     @repos = <IN>;
  84     close IN;
  85
  86     @packages = ();
  87     $lineNum = 0;
  88     foreach (@repos) {
  89         chomp;
  90         $lineNum++;
  91         if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
  92             my %line;
  93             $line{"localpath"}  = $1;
  94             $line{"tag"}        = $2;
  95             $line{"remotepath"} = $3;
  96             $line{"vcs"}        = $4;
  97             $line{"upstream"}   = $5;
  98             push @packages, \%line;
  99         }
 100         elsif (! /^(#.*)?$/) {
 101             die "Bad content on line $lineNum of packages file: $_";
 102         }
 103     }
 104 }
 105
 106 sub message {
 107     if ($verbose >= 2) {
 108         print "@_\n";
 109     }
 110 }
 111
 112 sub warning {
 113     if ($verbose >= 1) {
 114         print "warning: @_\n";
 115     }
 116 }
 117
 118 sub scm {
 119     my $dir = shift;
 120     my $scm = shift;
 121     my $pwd;
 122
 123     if ($dir eq '.') {
 124         message "== running $scm @_";
 125     } else {
 126         message "== $dir: running $scm @_";
 127         $pwd = getcwd();
 128         chdir($dir);
 129     }
 130
 131     system ($scm, @_) == 0
 132         or $ignore_failure
 133         or die "$scm failed: $?";
 134
 135     if ($dir ne '.') {
 136         chdir($pwd);
 137     }
 138 }
 139
 140 sub repoexists {
 141     my ($scm, $localpath) = @_;
 142
 143     if ($scm eq "darcs") {
 144         -d "$localpath/_darcs";
 145     }
 146     else {
 147         -d "$localpath/.git";
 148     }
 149 }
 150
 151 sub scmall {
 152     my $command = shift;
 153
 154     my $localpath;
 155     my $tag;
 156     my $remotepath;
 157     my $scm;
 158     my $upstream;
 159     my $line;
 160
 161     my $path;
 162     my $wd_before = getcwd;
 163
 164     my @scm_args;
 165
 166     my $pwd;
 167
 168     my ($repo_base, $checked_out_tree) = getrepo();
 169
 170     parsePackages;
 171
 172     for $line (@packages) {
 173
 174             $localpath  = $$line{"localpath"};
 175             $tag        = $$line{"tag"};
 176             $remotepath = $$line{"remotepath"};
 177             $scm        = $$line{"vcs"};
 178             $upstream   = $$line{"upstream"};
 179
 180             # Check the SCM is OK as early as possible
 181             die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
 182
 183             # Work out the path for this package in the repo we pulled from
 184             if ($checked_out_tree) {
 185                 $path = "$repo_base/$localpath";
 186             }
 187             else {
 188                 $path = "$repo_base/$remotepath";
 189             }
 190
 191             # Work out the arguments we should give to the SCM
 192             if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
 193                 @scm_args = (($scm eq "darcs" and "whatsnew")
 194                           or ($scm eq "git" and "status"));
 195
 196                 # Hack around 'darcs whatsnew' failing if there are no changes
 197                 $ignore_failure = 1;
 198             }
 199             elsif ($command =~ /^(?:pus|push)$/) {
 200                 @scm_args = "push";
 201                 $want_remote_repo = 1;
 202             }
 203             elsif ($command =~ /^(?:pul|pull)$/) {
 204                 @scm_args = "pull";
 205                 $want_remote_repo = 1;
 206                 # Q: should we append the -a argument for darcs repos?
 207             }
 208             elsif ($command =~ /^(?:g|ge|get)$/) {
 209                 # Skip any repositories we have not included the tag for
 210                 if (not defined($tags{$tag})) {
 211                     next;
 212                 }
 213
 214                 if (-d $localpath) {
 215                     warning("$localpath already present; omitting") if $localpath ne ".";
 216                     next;
 217                 }
 218
 219                 # The first time round the loop, default the get-mode
 220                 if (not defined($get_mode)) {
 221                     warning("adding --partial, to override use --complete");
 222                     $get_mode = "--partial";
 223                 }
 224
 225                 # The only command that doesn't need a repo
 226                 $local_repo_unnecessary = 1;
 227
 228                 if ($scm eq "darcs") {
 229                     # Note: we can only use the get-mode with darcs for now
 230                     @scm_args = ("get", $get_mode, $path, $localpath);
 231                 }
 232                 else {
 233                     @scm_args = ("clone", $path, $localpath);
 234                 }
 235             }
 236             elsif ($command =~ /^(?:s|se|sen|send)$/) {
 237                 @scm_args = (($scm eq "darcs" and "send")
 238                           or ($scm eq "git" and "send-email"));
 239                 $want_remote_repo = 1;
 240             }
 241             elsif ($command =~ /^set-origin$/) {
 242                 @scm_args = ("remote", "set-url", "origin", $path);
 243             }
 244             elsif ($command =~ /^set-push$/) {
 245                 @scm_args = ("remote", "set-url", "--push", "origin", $path);
 246                 print "foo\n", @scm_args;
 247             }
 248             elsif ($command =~ /^fetch$/) {
 249                 @scm_args = ("fetch", "origin");
 250             }
 251             elsif ($command =~ /^new$/) {
 252                 @scm_args = ("log", "origin..");
 253             }
 254             else {
 255                 die "Unknown command: $command";
 256             }
 257
 258             # Actually execute the command
 259             if (repoexists ($scm, $localpath)) {
 260                 if ($want_remote_repo) {
 261                     if ($scm eq "darcs") {
 262                         scm (".", $scm, @scm_args, @_, "--repodir=$localpath", $path);
 263                     } else {
 264                         # git pull doesn't like to be used with --work-dir
 265                         # I couldn't find an alternative to chdir() here
 266                         scm ($localpath, $scm, @scm_args, @_, $path, "master");
 267                     }
 268                 } else {
 269                     # git status *must* be used with --work-dir, if we don't chdir() to the dir
 270                     scm ($localpath, $scm, @scm_args, @_);
 271                 }
 272             }
 273             elsif ($local_repo_unnecessary) {
 274                 # Don't bother to change directory in this case
 275                 scm (".", $scm, @scm_args, @_);
 276             }
 277             elsif ($tag eq "") {
 278                 message "== Required repo $localpath is missing! Skipping";
 279             }
 280             else {
 281                 message "== $localpath repo not present; skipping";
 282             }
 283     }
 284 }
 285
 286 sub main {
 287     if (! -d ".git" || ! -d "compiler") {
 288         die "error: sync-all must be run from the top level of the ghc tree."
 289     }
 290
 291     $tags{"-"} = 1;
 292     $tags{"dph"} = 1;
 293
 294     while ($#_ ne -1) {
 295         my $arg = shift;
 296         # We handle -q here as well as lower down as we need to skip over it
 297         # if it comes before the source-control command
 298         if ($arg eq "-q") {
 299             $verbose = 1;
 300         }
 301         elsif ($arg eq "-s") {
 302             $verbose = 0;
 303         }
 304         elsif ($arg eq "-r") {
 305             $defaultrepo = shift;
 306         }
 307         elsif ($arg eq "--ignore-failure") {
 308             $ignore_failure = 1;
 309         }
 310         elsif ($arg eq "--complete" || $arg eq "--partial") {
 311             $get_mode = $arg;
 312         }
 313         # Use --checked-out if the remote repos are a checked-out tree,
 314         # rather than the master trees.
 315         elsif ($arg eq "--checked-out") {
 316             $checked_out_flag = 1;
 317         }
 318         # --<tag> says we grab the libs tagged 'tag' with
 319         # 'get'. It has no effect on the other commands.
 320         elsif ($arg =~ m/^--/) {
 321             $arg =~ s/^--//;
 322             $tags{$arg} = 1;
 323         }
 324         else {
 325             unshift @_, $arg;
 326             if (grep /^-q$/, @_) {
 327                 $verbose = 1;
 328             }
 329             last;
 330         }
 331     }
 332
 333     if ($#_ eq -1) {
 334         # Get the built in help
 335         my $help = <<END;
 336 What do you want to do?
 337 Supported commands:
 338
 339  * whatsnew
 340  * push
 341  * pull
 342  * get, with options:
 343   * --<package-tag>
 344   * --complete
 345   * --partial
 346  * fetch
 347  * send
 348  * set-origin
 349  * set-push
 350  * new
 351
 352 Available package-tags are:
 353 END
 354
 355         # Collect all the tags in the packages file
 356         my %available_tags;
 357         open IN, "< packages" or die "Can't open packages file";
 358         while (<IN>) {
 359             chomp;
 360             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
 361                 if (defined($2) && $2 ne "-") {
 362                     $available_tags{$2} = 1;
 363                 }
 364             }
 365             elsif (! /^(#.*)?$/) {
 366                 die "Bad line: $_";
 367             }
 368         }
 369         close IN;
 370
 371         # Show those tags and the help text
 372         my @available_tags = keys %available_tags;
 373         print "$help@available_tags\n";
 374         exit 1;
 375     }
 376     else {
 377         # Give the command and rest of the arguments to the main loop
 378         scmall @_;
 379     }
 380 }
 381
 382 main(@ARGV);
 383