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