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 =~ /^fetch$/) {
 245                 @scm_args = ("fetch", "origin");
 246             }
 247             elsif ($command =~ /^new$/) {
 248                 @scm_args = ("log", "origin..");
 249             }
 250             else {
 251                 die "Unknown command: $command";
 252             }
 253
 254             # Actually execute the command
 255             if (repoexists ($scm, $localpath)) {
 256                 if ($want_remote_repo) {
 257                     if ($scm eq "darcs") {
 258                         scm (".", $scm, @scm_args, @_, "--repodir=$localpath", $path);
 259                     } else {
 260                         # git pull doesn't like to be used with --work-dir
 261                         # I couldn't find an alternative to chdir() here
 262                         scm ($localpath, $scm, @scm_args, @_, $path, "master");
 263                     }
 264                 } else {
 265                     # git status *must* be used with --work-dir, if we don't chdir() to the dir
 266                     scm ($localpath, $scm, @scm_args, @_);
 267                 }
 268             }
 269             elsif ($local_repo_unnecessary) {
 270                 # Don't bother to change directory in this case
 271                 scm (".", $scm, @scm_args, @_);
 272             }
 273             elsif ($tag eq "") {
 274                 message "== Required repo $localpath is missing! Skipping";
 275             }
 276             else {
 277                 message "== $localpath repo not present; skipping";
 278             }
 279     }
 280 }
 281
 282 sub main {
 283     if (! -d ".git" || ! -d "compiler") {
 284         die "error: sync-all must be run from the top level of the ghc tree."
 285     }
 286
 287     $tags{"-"} = 1;
 288     $tags{"dph"} = 1;
 289
 290     while ($#_ ne -1) {
 291         my $arg = shift;
 292         # We handle -q here as well as lower down as we need to skip over it
 293         # if it comes before the source-control command
 294         if ($arg eq "-q") {
 295             $verbose = 1;
 296         }
 297         elsif ($arg eq "-s") {
 298             $verbose = 0;
 299         }
 300         elsif ($arg eq "-r") {
 301             $defaultrepo = shift;
 302         }
 303         elsif ($arg eq "--ignore-failure") {
 304             $ignore_failure = 1;
 305         }
 306         elsif ($arg eq "--complete" || $arg eq "--partial") {
 307             $get_mode = $arg;
 308         }
 309         # Use --checked-out if the remote repos are a checked-out tree,
 310         # rather than the master trees.
 311         elsif ($arg eq "--checked-out") {
 312             $checked_out_flag = 1;
 313         }
 314         # --<tag> says we grab the libs tagged 'tag' with
 315         # 'get'. It has no effect on the other commands.
 316         elsif ($arg =~ m/^--/) {
 317             $arg =~ s/^--//;
 318             $tags{$arg} = 1;
 319         }
 320         else {
 321             unshift @_, $arg;
 322             if (grep /^-q$/, @_) {
 323                 $verbose = 1;
 324             }
 325             last;
 326         }
 327     }
 328
 329     if ($#_ eq -1) {
 330         # Get the built in help
 331         my $help = <<END;
 332 What do you want to do?
 333 Supported commands:
 334
 335  * whatsnew
 336  * push
 337  * pull
 338  * get, with options:
 339   * --<package-tag>
 340   * --complete
 341   * --partial
 342  * fetch
 343  * send
 344  * set-origin
 345  * new
 346
 347 Available package-tags are:
 348 END
 349
 350         # Collect all the tags in the packages file
 351         my %available_tags;
 352         open IN, "< packages" or die "Can't open packages file";
 353         while (<IN>) {
 354             chomp;
 355             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
 356                 if (defined($2) && $2 ne "-") {
 357                     $available_tags{$2} = 1;
 358                 }
 359             }
 360             elsif (! /^(#.*)?$/) {
 361                 die "Bad line: $_";
 362             }
 363         }
 364         close IN;
 365
 366         # Show those tags and the help text
 367         my @available_tags = keys %available_tags;
 368         print "$help@available_tags\n";
 369         exit 1;
 370     }
 371     else {
 372         # Give the command and rest of the arguments to the main loop
 373         scmall @_;
 374     }
 375 }
 376
 377 main(@ARGV);
 378