Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc.git] / sync-all
1 #!/usr/bin/perl -w
2
3 use strict;
4 use Cwd;
5
6 # Usage:
7 #
8 # ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare]
9 #            [--nofib] [--extra] [--testsuite] [--resume] cmd [git flags]
10 #
11 # Applies the command "cmd" to each repository in the tree.
12 # sync-all will try to do the right thing for both git and darcs repositories.
13 #
14 # e.g.
15 #      ./sync-all -r http://darcs.haskell.org/ghc get
16 #          To get any repos which do not exist in the local tree
17 #
18 #      ./sync-all pull
19 #          To pull everything from the default repos
20 #
21 # -------------- Flags -------------------
22 #   -q says to be quite, and -s to be silent.
23 #
24 #   --resume will restart a command that failed, from the repo at which
25 #   it failed. This means you don't need to wait while, e.g., "pull"
26 #   goes through all the repos it's just pulled, and tries to pull them
27 #   again.
28 #
29 #   --ignore-failure says to ignore errors and move on to the next repository
30 #
31 #   -r repo says to use repo as the location of package repositories
32 #
33 #   --checked-out says that the remote repo is in checked-out layout, as
34 #   opposed to the layout used for the main repo.  By default a repo on
35 #   the local filesystem is assumed to be checked-out, and repos accessed
36 #   via HTTP or SSH are assumed to be in the main repo layout; use
37 #   --checked-out to override the latter.
38 #
39 #   --bare says that the local repo is in bare layout, same as the main repo.
40 #   It also means that these repos are bare. You only have to use this flag if
41 #   you don't have a bare ghc.git in the current directory and would like to 'get'
42 #   all of the repos bare. Requires packages.conf to be present in the current
43 #   directory (a renamed packages file from the main ghc repo).
44 #
45 #   --nofib, --testsuite also get the nofib and testsuite repos respectively
46 #
47 # ------------ Which repos to use -------------
48 # sync-all uses the following algorithm to decide which remote repos to use
49 #
50 #  It always computes the remote repos from a single base, $repo_base
51 #  How is $repo_base set?  
52 #    If you say "-r repo", then that's $repo_base
53 #    otherwise $repo_base is set by asking git where the ghc repo came
54 #    from, and removing the last component (e.g. /ghc.git/ of /ghc/).
55 #
56 #  Then sync-all iterates over the package found in the file
57 #  ./packages; see that file for a description of the contents.
58
59 #    If $repo_base looks like a local filesystem path, or if you give
60 #    the --checked-out flag, sync-all works on repos of form
61 #          $repo_base/<local-path>
62 #    otherwise sync-all works on repos of form
63 #          $repo_base/<remote-path>
64 #    This logic lets you say
65 #      both    sync-all -r http://darcs.haskell.org/ghc-6.12 pull
66 #      and     sync-all -r ../HEAD pull
67 #    The latter is called a "checked-out tree".
68
69 # NB: sync-all *ignores* the defaultrepo of all repos other than the
70 # root one.  So the remote repos must be laid out in one of the two
71 # formats given by <local-path> and <remote-path> in the file 'packages'.
72
73 $| = 1; # autoflush stdout after each print, to avoid output after die
74
75 my $defaultrepo;
76 my @packages;
77 my $verbose = 2;
78 my $try_to_resume = 0;
79 my $ignore_failure = 0;
80 my $checked_out_flag = 0; # NOT the opposite of bare_flag (describes remote repo state)
81 my $get_mode;
82 my $bare_flag = ""; # NOT the opposite of checked_out_flag (describes local repo state)
83
84 my %tags;
85
86 # Figure out where to get the other repositories from.
87 sub getrepo {
88     my $repo;
89
90     if (defined($defaultrepo)) {
91         $repo = $defaultrepo;
92         chomp $repo;
93     } else {
94         # Figure out where to get the other repositories from,
95         # based on where this GHC repo came from.
96         my $git_dir = $bare_flag ? "--git-dir=ghc.git" : "";
97         my $branch  = `git $git_dir branch | grep "\* " | sed "s/^\* //"`; chomp $branch;
98         my $remote  = `git $git_dir config branch.$branch.remote`;         chomp $remote;
99         if ($remote eq "") {
100             # remotes are not mandatory for branches (e.g. not recorded by default for bare repos)
101             $remote = "origin";
102         }
103         $repo       = `git $git_dir config remote.$remote.url`;            chomp $repo;
104     }
105
106     my $repo_base;
107     my $checked_out_tree;
108
109     if ($repo =~ /^...*:/) {
110         # HTTP or SSH
111         # Above regex says "at least two chars before the :", to avoid
112         # catching Win32 drives ("C:\").
113         $repo_base = $repo;
114
115         # --checked-out is needed if you want to use a checked-out repo
116         # over SSH or HTTP
117         if ($checked_out_flag) {
118             $checked_out_tree = 1;
119         } else {
120             $checked_out_tree = 0;
121         }
122
123         # Don't drop the last part of the path if specified with -r, as
124         # it expects repos of the form:
125         #
126         #   http://darcs.haskell.org
127         #
128         # rather than
129         #   
130         #   http://darcs.haskell.org/ghc
131         #
132         if (!$defaultrepo) {
133             $repo_base =~ s#/[^/]+/?$##;
134         }
135     }
136     elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
137         # Local filesystem, either absolute (C:/ or /) or relative (../) path
138         $repo_base = $repo;
139         if (-f "$repo/HEAD") {
140             # assume a local mirror:
141             $checked_out_tree = 0;
142             $repo_base =~ s#/[^/]+/?$##;
143         } elsif (-d "$repo/ghc.git") {
144             # assume a local mirror:
145             $checked_out_tree = 0;
146         } else {
147             # assume a checked-out tree:
148             $checked_out_tree = 1;
149         }
150     }
151     else {
152         die "Couldn't work out repo";
153     }
154
155     return $repo_base, $checked_out_tree;
156 }
157
158 sub parsePackages {
159     my @repos;
160     my $lineNum;
161
162     open IN, "< packages.conf"
163         or open IN, "< packages" # clashes with packages directory when using --bare
164         or die "Can't open packages file (or packages.conf)";
165     @repos = <IN>;
166     close IN;
167
168     @packages = ();
169     $lineNum = 0;
170     foreach (@repos) {
171         chomp;
172         $lineNum++;
173         if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
174             my %line;
175             $line{"localpath"}  = $1;
176             $line{"tag"}        = $2;
177             $line{"remotepath"} = $3;
178             $line{"vcs"}        = $4;
179             push @packages, \%line;
180         }
181         elsif (! /^(#.*)?$/) {
182             die "Bad content on line $lineNum of packages file: $_";
183         }
184     }
185 }
186
187 sub message {
188     if ($verbose >= 2) {
189         print "@_\n";
190     }
191 }
192
193 sub warning {
194     if ($verbose >= 1) {
195         print "warning: @_\n";
196     }
197 }
198
199 sub scm {
200     my $dir = shift;
201     my $scm = shift;
202     my $pwd;
203
204     if ($dir eq '.') {
205         message "== running $scm @_";
206     } else {
207         message "== $dir: running $scm @_";
208         $pwd = getcwd();
209         chdir($dir);
210     }
211
212     system ($scm, @_) == 0
213         or $ignore_failure
214         or die "$scm failed: $?";
215
216     if ($dir ne '.') {
217         chdir($pwd);
218     }
219 }
220
221 sub scmall {
222     my $command = shift;
223     
224     my $localpath;
225     my $tag;
226     my $remotepath;
227     my $scm;
228     my $line;
229     my $branch_name;
230     my $subcommand;
231
232     my $path;
233     my $wd_before = getcwd;
234
235     my $pwd;
236     my @args;
237
238     my $started;
239     my $doing;
240     my $start_repo;
241
242     my ($repo_base, $checked_out_tree) = getrepo();
243
244     my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/;
245
246     parsePackages;
247
248     @args = ();
249
250     if ($command =~ /^remote$/) {
251         while (@_ > 0 && $_[0] =~ /^-/) {
252             push(@args,shift);
253         }
254         if (@_ < 1) { help(); }
255         $subcommand = shift;
256         if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') {
257             help();
258         }
259         while (@_ > 0 && $_[0] =~ /^-/) {
260             push(@args,shift);
261         }
262         if (($subcommand eq 'add' || $subcommand eq 'rm') && @_ < 1) {
263             help();
264         } elsif (@_ < 1) { # set-url
265             $branch_name = 'origin';
266         } else {
267             $branch_name = shift;
268         }
269     } elsif ($command eq 'new') {
270         if (@_ < 1) {
271             $branch_name = 'origin';
272         } else {
273             $branch_name = shift;
274         }
275     }
276
277     push(@args, @_);
278
279     # $doing is a good enough approximation to what we are doing that
280     # we can use it to check that --resume is resuming the right command
281     $doing = join(" ", ($command, @args));
282     $started = 1;
283     if ($try_to_resume && -f "resume") {
284         my $what;
285         open RESUME, "< resume"
286             or die "Can't open resume file";
287         $start_repo = <RESUME>;
288         chomp $start_repo;
289         $what = <RESUME>;
290         chomp $what;
291         close RESUME;
292         if ($what eq $doing) {
293             $started = 0;
294         }
295     }
296
297     for $line (@packages) {
298         $tag        = $$line{"tag"};
299         $scm        = $$line{"vcs"};
300         # Use the "remote" structure for bare git repositories
301         $localpath  = ($bare_flag && $scm eq "git") ?
302                       $$line{"remotepath"} : $$line{"localpath"};
303         $remotepath = ($checked_out_tree) ?
304                       $$line{"localpath"}  : $$line{"remotepath"};
305
306         if (!$started) {
307             if ($start_repo eq $localpath) {
308                 $started = 1;
309             }
310             else {
311                 next;
312             }
313         }
314
315         open RESUME, "> resume.tmp";
316         print RESUME "$localpath\n";
317         print RESUME "$doing\n";
318         close RESUME;
319         rename "resume.tmp", "resume";
320
321         # Check the SCM is OK as early as possible
322         die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
323
324         # We can't create directories on GitHub, so we translate
325         # "packages/foo" into "package-foo".
326         if ($is_github_repo) {
327             $remotepath =~ s/\//-/;
328         }
329
330         # Construct the path for this package in the repo we pulled from
331         $path = "$repo_base/$remotepath";
332
333         if ($command =~ /^(?:g|ge|get)$/) {
334             # Skip any repositories we have not included the tag for
335             if (not defined($tags{$tag})) {
336                 $tags{$tag} = 0;
337             }
338             if ($tags{$tag} == 0) {
339                 next;
340             }
341             
342             if (-d $localpath) {
343                 warning("$localpath already present; omitting")
344                     if $localpath ne ".";
345                 if ($scm eq "git") {
346                     scm ($localpath, $scm, "config", "core.ignorecase", "true");
347                 }
348                 next;
349             }
350
351             # Note that we use "." as the path, as $localpath
352             # doesn't exist yet.
353             if ($scm eq "darcs") {
354                 # The first time round the loop, default the get-mode
355                 if (not defined($get_mode)) {
356                     warning("adding --partial, to override use --complete");
357                     $get_mode = "--partial";
358                 }
359                 scm (".", $scm, "get", $get_mode, $path, $localpath, @args);
360             }
361             else {
362                 my @argsWithBare = @args;
363                 push @argsWithBare, $bare_flag if $bare_flag;
364                 scm (".", $scm, "clone", $path, $localpath, @argsWithBare);
365                 scm ($localpath, $scm, "config", "core.ignorecase", "true");
366             }
367             next;
368         }
369
370         my $darcs_repo_present = 1 if -d "$localpath/_darcs";
371         my $git_repo_present = 1 if -d "$localpath/.git" || ($bare_flag && -d "$localpath");
372         if ($darcs_repo_present) {
373             if ($git_repo_present) {
374                 die "Found both _darcs and .git in $localpath";
375             }
376             $scm = "darcs";
377         } elsif ($git_repo_present) {
378             $scm = "git";
379         } elsif ($tag eq "") {
380             die "Required repo $localpath is missing";
381         } else {
382              message "== $localpath repo not present; skipping";
383              next;
384         }
385
386         # Work out the arguments we should give to the SCM
387         if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
388             if ($scm eq "darcs") {
389                 $command = "whatsnew";
390             }
391             elsif ($scm eq "git") {
392                 $command = "status";
393             }
394             else {
395                 die "Unknown scm";
396             }
397
398             # Hack around 'darcs whatsnew' failing if there are no changes
399             $ignore_failure = 1;
400             scm ($localpath, $scm, $command, @args);
401         }
402         elsif ($command =~ /^commit$/) {
403             # git fails if there is nothing to commit, so ignore failures
404             $ignore_failure = 1;
405             scm ($localpath, $scm, "commit", @args);
406         }
407         elsif ($command =~ /^(?:pus|push)$/) {
408             scm ($localpath, $scm, "push", @args);
409         }
410         elsif ($command =~ /^(?:pul|pull)$/) {
411             scm ($localpath, $scm, "pull", @args);
412         }
413         elsif ($command =~ /^(?:s|se|sen|send)$/) {
414             if ($scm eq "darcs") {
415                 $command = "send";
416             }
417             elsif ($scm eq "git") {
418                 $command = "send-email";
419             }
420             else {
421                 die "Unknown scm";
422             }
423             scm ($localpath, $scm, $command, @args);
424         }
425         elsif ($command =~ /^fetch$/) {
426             scm ($localpath, $scm, "fetch", @args);
427         }
428         elsif ($command =~ /^new$/) {
429             my @scm_args = ("log", "$branch_name..");
430             scm ($localpath, $scm, @scm_args, @args);
431         }
432         elsif ($command =~ /^log$/) {
433             scm ($localpath, $scm, "log", @args);
434         }
435         elsif ($command =~ /^remote$/) {
436             my @scm_args;
437             $ignore_failure = 1;
438             if ($subcommand eq 'add') {
439                 @scm_args = ("remote", "add", $branch_name, $path);
440             } elsif ($subcommand eq 'rm') {
441                 @scm_args = ("remote", "rm", $branch_name);
442             } elsif ($subcommand eq 'set-url') {
443                 @scm_args = ("remote", "set-url", $branch_name, $path);
444             }
445             scm ($localpath, $scm, @scm_args, @args);
446         }
447         elsif ($command =~ /^checkout$/) {
448             # Not all repos are necessarily branched, so ignore failure
449             $ignore_failure = 1;
450             scm ($localpath, $scm, "checkout", @args)
451                 unless $scm eq "darcs";
452         }
453         elsif ($command =~ /^grep$/) {
454             # Hack around 'git grep' failing if there are no matches
455             $ignore_failure = 1;
456             scm ($localpath, $scm, "grep", @args)
457                 unless $scm eq "darcs";
458         }
459         elsif ($command =~ /^clean$/) {
460             scm ($localpath, $scm, "clean", @args)
461                 unless $scm eq "darcs";
462         }
463         elsif ($command =~ /^reset$/) {
464             scm ($localpath, $scm, "reset", @args)
465                 unless $scm eq "darcs";
466         }
467         elsif ($command =~ /^config$/) {
468             scm ($localpath, $scm, "config", @args)
469                 unless $scm eq "darcs";
470         }
471         else {
472             die "Unknown command: $command";
473         }
474     }
475
476     unlink "resume";
477 }
478
479 sub help()
480 {
481         # Get the built in help
482         my $help = <<END;
483 Usage:
484
485   ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare]
486              [--package-tag1] ... [--package-tagN] command
487
488 Supported commands:
489
490  * whatsnew
491  * commit
492  * push
493  * pull
494  * get, with options:
495   * --<package-tag>
496   * --complete
497   * --partial
498  * fetch
499  * send
500  * new
501  * remote add <remote-name>
502  * remote rm <remote-name>
503  * remote set-url [--push] <remote-name>
504  * checkout
505  * grep
506  * clean
507  * reset
508  * config
509  * log
510
511 Note: --cheched-out and --bare flags are NOT the opposite of each other.
512       --checked-out: describes the layout of the remote repository tree.
513       --bare:        describes the layout of the local repository tree.
514
515 Available package-tags are:
516 END
517
518         # Collect all the tags in the packages file
519         my %available_tags;
520         open IN, "< packages.conf"
521             or open IN, "< packages" # clashes with packages directory when using --bare
522             or die "Can't open packages file (or packages.conf)";
523         while (<IN>) {
524             chomp;
525             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
526                 if (defined($2) && $2 ne "-") {
527                     $available_tags{$2} = 1;
528                 }
529             }
530             elsif (! /^(#.*)?$/) {
531                 die "Bad line: $_";
532             }
533         }
534         close IN;
535         
536         # Show those tags and the help text
537         my @available_tags = keys %available_tags;
538         print "$help@available_tags\n";
539         exit 1;
540 }
541
542 sub main {
543
544     $tags{"-"} = 1;
545     $tags{"dph"} = 1;
546
547     while ($#_ ne -1) {
548         my $arg = shift;
549         # We handle -q here as well as lower down as we need to skip over it
550         # if it comes before the source-control command
551         if ($arg eq "-q") {
552             $verbose = 1;
553         }
554         elsif ($arg eq "-s") {
555             $verbose = 0;
556         }
557         elsif ($arg eq "-r") {
558             $defaultrepo = shift;
559         }
560         elsif ($arg eq "--resume") {
561             $try_to_resume = 1;
562         }
563         elsif ($arg eq "--ignore-failure") {
564             $ignore_failure = 1;
565         }
566         elsif ($arg eq "--complete" || $arg eq "--partial") {
567             $get_mode = $arg;
568         }
569         # Use --checked-out if the _remote_ repos are a checked-out tree,
570         # rather than the master trees.
571         elsif ($arg eq "--checked-out") {
572             $checked_out_flag = 1;
573         }
574         # Use --bare if the _local_ repos are bare repos,
575         # rather than a checked-out tree.
576         elsif ($arg eq "--bare") {
577             $bare_flag = $arg;
578         }
579         # --<tag> says we grab the libs tagged 'tag' with
580         # 'get'. It has no effect on the other commands.
581         elsif ($arg =~ m/^--no-(.*)$/) {
582             $tags{$1} = 0;
583         }
584         elsif ($arg =~ m/^--(.*)$/) {
585             $tags{$1} = 1;
586         }
587         else {
588             unshift @_, $arg;
589             if (grep /^-q$/, @_) {
590                 $verbose = 1;
591             }
592             last;
593         }
594     }
595
596     # check for ghc repositories in cwd
597     my $checked_out_found = 1 if (-d ".git" && -d "compiler");
598     my $bare_found = 1 if (-d "ghc.git");
599
600     if ($bare_flag && ! $bare_found && ! $defaultrepo) {
601         die "error: bare repository ghc.git not found.\n"
602           . "       Either clone a bare ghc repo first or specify the repo location. E.g.:\n"
603           . "       ./sync-all --bare [--testsuite --nofib --extra] -r http://darcs.haskell.org/ get\n"
604     }
605     elsif ($bare_found) {
606         $bare_flag = "--bare";
607     }
608     elsif (! $bare_flag && ! $checked_out_found) {
609         die "error: sync-all must be run from the top level of the ghc tree.";
610     }
611
612     if ($#_ eq -1) {
613         help();
614     }
615     else {
616         # Give the command and rest of the arguments to the main loop
617         scmall @_;
618     }
619 }
620
621 END {
622     my $ec = $?;
623     my $pwd = getcwd();
624
625     message "== Checking for old haddock repo";
626     if (-d "utils/haddock/.git") {
627         chdir("utils/haddock");
628         if ((system "git log -1 87e2ca11c3d1b1bc49900fba0b5c5c6f85650718 > /dev/null 2> /dev/null") == 0) {
629             print <<EOF;
630 ============================
631 ATTENTION!
632
633 You have an old haddock repository in your GHC tree!
634
635 Please remove it (e.g. "rm -r utils/haddock"), and then run
636 "./syncs-all get" to get the new repository.
637 ============================
638 EOF
639         }
640         chdir($pwd);
641     }
642
643     message "== Checking for old binary repo";
644     if (-d "libraries/binary/.git") {
645         chdir("libraries/binary");
646         if ((system "git log -1 749ac0efbde3b14901417364a872796598747aaf > /dev/null 2> /dev/null") == 0) {
647             print <<EOF;
648 ============================
649 ATTENTION!
650
651 You have an old binary repository in your GHC tree!
652
653 Please remove it (e.g. "rm -r libraries/binary"), and then run
654 "./syncs-all get" to get the new repository.
655 ============================
656 EOF
657         }
658         chdir($pwd);
659     }
660
661     $? = $ec;
662 }
663
664 main(@ARGV);
665