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.git" 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 $scm = shift;
 120
 121     message "== running $scm @_";
 122     system ($scm, @_) == 0
 123         or $ignore_failure
 124         or die "$scm failed: $?";
 125 }
 126
 127 sub repoexists {
 128     my ($scm, $localpath) = @_;
 129
 130     if ($scm eq "darcs") {
 131         -d "$localpath/_darcs";
 132     }
 133     else {
 134         -d "$localpath/.git";
 135     }
 136 }
 137
 138 sub scmall {
 139     my $command = shift;
 140
 141     my $localpath;
 142     my $tag;
 143     my $remotepath;
 144     my $scm;
 145     my $upstream;
 146     my $line;
 147
 148     my $path;
 149     my $wd_before = getcwd;
 150
 151     my @scm_args;
 152
 153     my ($repo_base, $checked_out_tree) = getrepo();
 154
 155     parsePackages;
 156
 157     for $line (@packages) {
 158
 159             $localpath  = $$line{"localpath"};
 160             $tag        = $$line{"tag"};
 161             $remotepath = $$line{"remotepath"};
 162             $scm        = $$line{"vcs"};
 163             $upstream   = $$line{"upstream"};
 164
 165             # Check the SCM is OK as early as possible
 166             die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
 167
 168             # Work out the path for this package in the repo we pulled from
 169             if ($checked_out_tree) {
 170                 $path = "$repo_base/$localpath";
 171             }
 172             else {
 173                 $path = "$repo_base/$remotepath";
 174             }
 175
 176             # Work out the arguments we should give to the SCM
 177             if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
 178                 @scm_args = (($scm eq "darcs" and "whatsnew")
 179                           or ($scm eq "git" and "status"));
 180
 181                 # Hack around 'darcs whatsnew' failing if there are no changes
 182                 $ignore_failure = 1;
 183             }
 184             elsif ($command =~ /^(?:pus|push)$/) {
 185                 @scm_args = "push";
 186                 $want_remote_repo = 1;
 187             }
 188             elsif ($command =~ /^(?:pul|pull)$/) {
 189                 @scm_args = "pull";
 190                 $want_remote_repo = 1;
 191                 # Q: should we append the -a argument for darcs repos?
 192             }
 193             elsif ($command =~ /^(?:g|ge|get)$/) {
 194                 # Skip any repositories we have not included the tag for
 195                 if (not defined($tags{$tag})) {
 196                     next;
 197                 }
 198
 199                 if (-d $localpath) {
 200                     warning("$localpath already present; omitting") if $localpath ne ".";
 201                     next;
 202                 }
 203
 204                 # The first time round the loop, default the get-mode
 205                 if (not defined($get_mode)) {
 206                     warning("adding --partial, to override use --complete");
 207                     $get_mode = "--partial";
 208                 }
 209
 210                 # The only command that doesn't need a repo
 211                 $local_repo_unnecessary = 1;
 212
 213                 if ($scm eq "darcs") {
 214                     # Note: we can only use the get-mode with darcs for now
 215                     @scm_args = ("get", $get_mode, $path, $localpath);
 216                 }
 217                 else {
 218                     @scm_args = ("clone", $path, $localpath);
 219                 }
 220             }
 221             elsif ($command =~ /^(?:s|se|sen|send)$/) {
 222                 @scm_args = (($scm eq "darcs" and "send")
 223                           or ($scm eq "git" and "send-email"));
 224                 $want_remote_repo = 1;
 225             }
 226             else {
 227                 die "Unknown command: $command";
 228             }
 229
 230             # Actually execute the command
 231             if (repoexists ($scm, $localpath)) {
 232                 if ($want_remote_repo) {
 233                     if ($scm eq "darcs") {
 234                         scm ($scm, @scm_args, @_, "--repodir=$localpath", $path);
 235                     } else {
 236                         # git pull doesn't like to be used with --work-dir
 237                         scm ($scm, "--git-dir=$localpath/.git", @scm_args, @_, $path, "master");
 238                     }
 239                 } else {
 240                     # git status *must* be used with --work-dir, if we don't chdir() to the dir
 241                     scm ($scm, "--git-dir=$localpath/.git", "--work-tree=$localpath", @scm_args, @_);
 242                 }
 243             }
 244             elsif ($local_repo_unnecessary) {
 245                 # Don't bother to change directory in this case
 246                 scm ($scm, @scm_args, @_);
 247             }
 248             elsif ($tag eq "") {
 249                 message "== Required repo $localpath is missing! Skipping";
 250             }
 251             else {
 252                 message "== $localpath repo not present; skipping";
 253             }
 254     }
 255 }
 256
 257 sub main {
 258     if (! -d ".git" || ! -d "compiler") {
 259         die "error: sync-all must be run from the top level of the ghc tree."
 260     }
 261
 262     $tags{"-"} = 1;
 263     $tags{"dph"} = 1;
 264
 265     while ($#_ ne -1) {
 266         my $arg = shift;
 267         # We handle -q here as well as lower down as we need to skip over it
 268         # if it comes before the source-control command
 269         if ($arg eq "-q") {
 270             $verbose = 1;
 271         }
 272         elsif ($arg eq "-s") {
 273             $verbose = 0;
 274         }
 275         elsif ($arg eq "-r") {
 276             $defaultrepo = shift;
 277         }
 278         elsif ($arg eq "--ignore-failure") {
 279             $ignore_failure = 1;
 280         }
 281         elsif ($arg eq "--complete" || $arg eq "--partial") {
 282             $get_mode = $arg;
 283         }
 284         # Use --checked-out if the remote repos are a checked-out tree,
 285         # rather than the master trees.
 286         elsif ($arg eq "--checked-out") {
 287             $checked_out_flag = 1;
 288         }
 289         # --<tag> says we grab the libs tagged 'tag' with
 290         # 'get'. It has no effect on the other commands.
 291         elsif ($arg =~ m/^--/) {
 292             $arg =~ s/^--//;
 293             $tags{$arg} = 1;
 294         }
 295         else {
 296             unshift @_, $arg;
 297             if (grep /^-q$/, @_) {
 298                 $verbose = 1;
 299             }
 300             last;
 301         }
 302     }
 303
 304     if ($#_ eq -1) {
 305         # Get the built in help
 306         my $help = <<END;
 307 What do you want to do?
 308 Supported commands:
 309
 310  * whatsnew
 311  * push
 312  * pull
 313  * get, with options:
 314   * --<package-tag>
 315   * --complete
 316   * --partial
 317  * send
 318
 319 Available package-tags are:
 320 END
 321
 322         # Collect all the tags in the packages file
 323         my %available_tags;
 324         open IN, "< packages" or die "Can't open packages file";
 325         while (<IN>) {
 326             chomp;
 327             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
 328                 if (defined($2) && $2 ne "-") {
 329                     $available_tags{$2} = 1;
 330                 }
 331             }
 332             elsif (! /^(#.*)?$/) {
 333                 die "Bad line: $_";
 334             }
 335         }
 336         close IN;
 337
 338         # Show those tags and the help text
 339         my @available_tags = keys %available_tags;
 340         print "$help@available_tags\n";
 341         exit 1;
 342     }
 343     else {
 344         # Give the command and rest of the arguments to the main loop
 345         scmall @_;
 346     }
 347 }
 348
 349 main(@ARGV);
 350