sync-all: Allow - in submodule URLs
[ghc.git] / sync-all
1 #!/usr/bin/env perl
2
3 use warnings;
4 use strict;
5 use Cwd;
6 use English;
7
8 $| = 1; # autoflush stdout after each print, to avoid output after die
9
10 my $initial_working_directory;
11 my $exit_via_die;
12
13 my $defaultrepo;
14 my @packages;
15 my $verbose = 2;
16 my $try_to_resume = 0;
17 my $ignore_failure = 0;
18 my $checked_out_flag = 0; # NOT the opposite of bare_flag (describes remote repo state)
19 my $get_mode;
20 my $bare_flag = ""; # NOT the opposite of checked_out_flag (describes local repo state)
21
22 my %tags;
23
24 my $GITHUB = qr!(?:git@|git://|https://|http://|ssh://git@)github.com!;
25
26 sub inDir {
27     my $dir = shift;
28     my $code = shift;
29
30     if ($dir ne '.') {
31         chdir($dir);
32     }
33
34     my $result = &$code();
35
36     if ($dir ne '.') {
37         chdir($initial_working_directory);
38     }
39     return $result;
40 }
41
42 sub parsePackages {
43     my @repos;
44     my $lineNum;
45
46     open IN, "< packages.conf"
47         or open IN, "< packages" # clashes with packages directory when using --bare
48         or die "Can't open packages file (or packages.conf)";
49     @repos = <IN>;
50     close IN;
51
52     @packages = ();
53     $lineNum = 0;
54     foreach (@repos) {
55         chomp;
56         $lineNum++;
57         if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
58             my %line;
59             $line{"localpath"}  = $1;
60             $line{"tag"}        = $2;
61             $line{"remotepath"} = $3;
62             $line{"upstreamurl"}= $4;
63             push @packages, \%line;
64
65             $tags{$2} = 0;
66         }
67         elsif (! /^(#.*)?$/) {
68             die "Bad content on line $lineNum of packages file: $_";
69         }
70     }
71 }
72
73 sub tryReadFile {
74     my $filename = shift;
75     my @lines;
76
77     open (FH, $filename) or return "";
78     @lines = <FH>;
79     close FH;
80     return join('', @lines);
81 }
82
83 sub message {
84     if ($verbose >= 2) {
85         print "@_\n";
86     }
87 }
88
89 sub warning {
90     if ($verbose >= 1) {
91         print "warning: @_\n";
92     }
93 }
94
95 sub gitNewWorkdir {
96     my $dir = shift;
97     my $target = shift;
98     my $target_dir = "$target/$dir";
99
100     if ($dir eq '.') {
101         message "== running git-new-workdir . $target_dir @_";
102     } else {
103         message "== $dir: running git-new-workdir . $target_dir @_";
104         chdir($dir);
105     }
106
107     system ("git-new-workdir", ".", $target_dir, @_) == 0
108         or $ignore_failure
109         or die "git-new-workdir failed: $?";
110
111     if ($dir ne '.') {
112         chdir($initial_working_directory);
113     }
114 }
115
116 sub git {
117     my $dir = shift;
118     my @args = @_;
119
120     &inDir($dir, sub {
121         my $prefix = $dir eq '.' ? "" : "$dir: ";
122         message "== ${prefix}running git @args";
123
124         system ("git", @args) == 0
125             or $ignore_failure
126             or die "git failed: $?";
127     });
128 }
129
130 sub readgitline {
131     my $dir = shift;
132     my @args = @_;
133
134     &inDir($dir, sub {
135         open my $fh, '-|', 'git', @args
136             or die "Executing git @args failed: $!";
137         my $line = <$fh>;
138         $line = "" unless defined($line);
139         chomp $line;
140         close $fh;
141         return $line;
142     });
143 }
144
145 sub readgit {
146     my $dir = shift;
147     my @args = @_;
148
149     &inDir($dir, sub {
150         open my $fh, '-|', 'git', @args
151             or die "Executing git @args failed: $!";
152         my $ret;
153         $ret .= $_ while <$fh>;
154         close $fh;
155         return $ret;
156     });
157 }
158
159 sub configure_repository {
160     my $localpath = shift;
161
162     &git($localpath, "config", "--local", "core.ignorecase", "true");
163
164     my $autocrlf = &readgitline($localpath, 'config', '--get', 'core.autocrlf');
165     if ($autocrlf eq "true") {
166         &git($localpath, "config", "--local", "core.autocrlf", "false");
167         &git($localpath, "reset", "--hard");
168     }
169 }
170
171 # Figure out where to get the other repositories from.
172 sub getrepo {
173     my $repo;
174
175     if (defined($defaultrepo)) {
176         $repo = $defaultrepo;
177         chomp $repo;
178     } else {
179         # Figure out where to get the other repositories from,
180         # based on where this GHC repo came from.
181         my $git_dir = $bare_flag ? "ghc.git" : ".";
182         my $branch = &readgitline($git_dir, "rev-parse", "--abbrev-ref", "HEAD");
183         die "Bad branch: $branch"
184             unless $branch =~ m!^[a-zA-Z][a-zA-Z0-9./-]*$!;
185         my $remote = &readgitline($git_dir, "config", "branch.$branch.remote");
186         if ($remote eq "") {
187             # remotes are not mandatory for branches (e.g. not recorded by default for bare repos)
188             $remote = "origin";
189         }
190         die "Bad remote: $remote"
191             unless $remote =~ m!^[a-zA-Z][a-zA-Z0-9./-]*$!;
192         $repo = &readgitline($git_dir, "config", "remote.$remote.url");
193     }
194
195     my $repo_base;
196     my $checked_out_tree;
197     my $repo_local = 0;
198
199     if ($repo =~ /^...*:/) {
200         # HTTP or SSH
201         # Above regex says "at least two chars before the :", to avoid
202         # catching Win32 drives ("C:\").
203         $repo_base = $repo;
204
205         # --checked-out is needed if you want to use a checked-out repo
206         # over SSH or HTTP
207         if ($checked_out_flag) {
208             $checked_out_tree = 1;
209         } else {
210             $checked_out_tree = 0;
211         }
212
213         # Don't drop the last part of the path if specified with -r, as
214         # it expects repos of the form:
215         #
216         #   http://git.haskell.org
217         #
218         # rather than
219         #
220         #   http://git.haskell.org/ghc
221         #
222         if (!$defaultrepo) {
223             $repo_base =~ s#/[^/]+/?$##;
224         }
225     }
226     elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
227         # Local filesystem, either absolute (C:/ or /) or relative (../) path
228         $repo_local = 1;
229         $repo_base = $repo;
230         if (-f "$repo/HEAD") {
231             # assume a local mirror:
232             $checked_out_tree = 0;
233             $repo_base =~ s#/[^/]+/?$##;
234         } elsif (-d "$repo/ghc.git") {
235             # assume a local mirror:
236             $checked_out_tree = 0;
237         } else {
238             # assume a checked-out tree:
239             $checked_out_tree = 1;
240         }
241     }
242     else {
243         die "Couldn't work out repo";
244     }
245
246     return $repo_base, $checked_out_tree, $repo_local;
247 }
248
249 sub gitall {
250     my $command = shift;
251
252     my $localpath;
253     my $tag;
254     my $remotepath;
255     my $line;
256     my $branch_name;
257     my $subcommand;
258
259     my $path;
260
261     my @args;
262
263     my $started;
264     my $doing;
265     my $start_repo;
266
267     my ($repo_base, $checked_out_tree, $repo_local) = getrepo();
268
269     my $is_github_repo = $repo_base =~ $GITHUB;
270
271     @args = ();
272
273     if ($command =~ /^remote$/) {
274         while (@_ > 0 && $_[0] =~ /^-/) {
275             push(@args,shift);
276         }
277         if (@_ < 1) { help(1); }
278         $subcommand = shift;
279         if ($subcommand ne 'add' &&
280             $subcommand ne 'rm' &&
281             $subcommand ne 'set-branches' &&
282             $subcommand ne 'set-url') {
283             help(1);
284         }
285         while (@_ > 0 && $_[0] =~ /^-/) {
286             push(@args,shift);
287         }
288         if (($subcommand eq 'add' || $subcommand eq 'rm') && @_ < 1) {
289             help(1);
290         } elsif (@_ < 1) { # set-url
291             $branch_name = 'origin';
292         } else {
293             $branch_name = shift;
294         }
295     } elsif ($command eq 'new') {
296         if (@_ < 1) {
297             $branch_name = 'origin';
298         } else {
299             $branch_name = shift;
300         }
301     }
302
303     push(@args, @_);
304
305     # $doing is a good enough approximation to what we are doing that
306     # we can use it to check that --resume is resuming the right command
307     $doing = join(" ", ($command, @args));
308     $started = 1;
309     if ($try_to_resume && -f "resume") {
310         my $what;
311         open RESUME, "< resume"
312             or die "Can't open resume file";
313         $start_repo = <RESUME>;
314         chomp $start_repo;
315         $what = <RESUME>;
316         chomp $what;
317         close RESUME;
318         if ($what eq $doing) {
319             $started = 0;
320         }
321     }
322
323     for $line (@packages) {
324         $tag        = $$line{"tag"};
325         # Use the "remote" structure for bare git repositories
326         $localpath  = ($bare_flag) ?
327                       $$line{"remotepath"} : $$line{"localpath"};
328         $remotepath = ($checked_out_tree) ?
329                       $$line{"localpath"}  : $$line{"remotepath"};
330
331         if (!$started) {
332             if ($start_repo eq $localpath) {
333                 $started = 1;
334             }
335             else {
336                 next;
337             }
338         }
339
340         open RESUME, "> resume.tmp";
341         print RESUME "$localpath\n";
342         print RESUME "$doing\n";
343         close RESUME;
344         rename "resume.tmp", "resume";
345
346         # We can't create directories on GitHub, so we translate
347         # "packages/foo" into "package-foo".
348         if ($is_github_repo) {
349             $remotepath =~ s/\//-/;
350         }
351
352         # Construct the path for this package in the repo we pulled from
353         $path = "$repo_base/$remotepath";
354
355         if ($command eq "get") {
356             next if $remotepath eq "-"; # "git submodule init/update" will get this later
357
358             # Skip any repositories we have not included the tag for
359             if (not defined($tags{$tag})) {
360                 $tags{$tag} = 0;
361             }
362             if ($tags{$tag} == 0) {
363                 next;
364             }
365
366             if (-d $localpath) {
367                 warning("$localpath already present; omitting")
368                     if $localpath ne ".";
369                 &configure_repository($localpath);
370                 next;
371             }
372
373             # Note that we use "." as the path, as $localpath
374             # doesn't exist yet.
375             my @argsWithBare = @args;
376             push @argsWithBare, $bare_flag if $bare_flag;
377             &git(".", "clone", $path, $localpath, @argsWithBare);
378             &configure_repository($localpath);
379             next;
380         }
381
382         my $git_repo_present = 1 if -e "$localpath/.git" || ($bare_flag && -d "$localpath");
383         if (not $git_repo_present) {
384             if ($tag eq "") {
385                 die "Required repo $localpath is missing";
386             }
387             else {
388                  message "== $localpath repo not present; skipping";
389                  next;
390             }
391         }
392
393         # Work out the arguments we should give to the SCM
394         if ($command eq "status") {
395             &git($localpath, $command, @args);
396         }
397         elsif ($command eq "commit") {
398             # git fails if there is nothing to commit, so ignore failures
399             $ignore_failure = 1;
400             &git($localpath, "commit", @args);
401         }
402         elsif ($command eq "check_submodules") {
403             # If we have a submodule then check whether it is up-to-date
404             if ($remotepath eq "-") {
405                 my %remote_heads;
406
407                 message "== Checking sub-module $localpath";
408
409                 chdir($localpath);
410
411                 open my $lsremote, '-|', 'git', 'ls-remote', '--heads', '-q'
412                     or die "Executing ls-remote failed: $!";
413                 while (<$lsremote>) {
414                     if (/^([0-9a-f]{40})\s*refs\/heads\//) {
415                         $remote_heads{$1} = 1;
416                     }
417                     else {
418                         die "Bad output from ls-remote: $_";
419                     }
420                 }
421                 close($lsremote);
422
423                 my $myhead = &readgitline('.', 'rev-parse', '--verify', 'HEAD');
424
425                 if (not defined($remote_heads{$myhead})) {
426                     die "Sub module $localpath needs to be pushed; see http://ghc.haskell.org/trac/ghc/wiki/Repositories/Upstream";
427                 }
428                 
429                 chdir($initial_working_directory);
430             }
431         }
432         elsif ($command eq "push") {
433             # We don't automatically push to the submodules. If you want
434             # to push to them then you need to use a special command, as
435             # described on
436             # http://ghc.haskell.org/trac/ghc/wiki/Repositories/Upstream
437             if ($remotepath ne "-") {
438                 &git($localpath, "push", @args);
439             }
440         }
441         elsif ($command eq "pull") {
442             my $realcmd;
443             my @realargs;
444             if ($remotepath eq "-") {
445                 # Only fetch for the submodules. "git submodule update"
446                 # will take care of making us point to the right commit.
447                 $realcmd = "fetch";
448                 # we like "sync-all pull --rebase" to work:
449                 @realargs = grep(!/--rebase/,@args);
450             }
451             else {
452                 $realcmd = "pull";
453                 @realargs = @args;
454             }
455             &git($localpath, $realcmd, @realargs);
456         }
457         elsif ($command eq "new-workdir") {
458             gitNewWorkdir ($localpath, @args);
459         }
460         elsif ($command eq "send") {
461             $command = "send-email";
462             &git($localpath, $command, @args);
463         }
464         elsif ($command eq "fetch") {
465             &git($localpath, "fetch", @args);
466         }
467         elsif ($command eq "new") {
468             my @scm_args = ("log", "$branch_name..");
469             &git($localpath, @scm_args, @args);
470         }
471         elsif ($command eq "log") {
472             &git($localpath, "log", @args);
473         }
474         elsif ($command eq "remote") {
475             my @scm_args;
476             my $rpath;
477             $ignore_failure = 1;
478             if ($remotepath eq '-') {
479                 $rpath = "$localpath.git"; # N.B.: $localpath lacks the .git suffix
480                 if ($localpath =~ m!^(?:libraries|utils)/!) {
481                     # FIXME: This is just a simple heuristic to
482                     # infer the remotepath for Git submodules. A
483                     # proper solution would require to parse the
484                     # .gitmodules file to obtain the actual
485                     # localpath<->remotepath mapping.
486                     $rpath =~ s!^(?:libraries|utils)/!packages/!;
487                 }
488                 $rpath = "$repo_base/$rpath";
489             } else {
490                 $rpath = $path;
491             }
492             if ($subcommand eq 'add') {
493                 @scm_args = ("remote", "add", $branch_name, $rpath);
494             } elsif ($subcommand eq 'rm') {
495                 @scm_args = ("remote", "rm", $branch_name);
496             } elsif ($subcommand eq 'set-branches') {
497                 @scm_args = ("remote", "set-branches", $branch_name);
498             } elsif ($subcommand eq 'set-url') {
499                 @scm_args = ("remote", "set-url", $branch_name, $rpath);
500             }
501             &git($localpath, @scm_args, @args);
502         }
503         elsif ($command eq "checkout") {
504             # Not all repos are necessarily branched, so ignore failure
505             $ignore_failure = 1;
506             &git($localpath, "checkout", @args);
507         }
508         elsif ($command eq "grep") {
509             # Hack around 'git grep' failing if there are no matches
510             $ignore_failure = 1;
511             &git($localpath, "grep", @args);
512         }
513         elsif ($command eq "diff") {
514             &git($localpath, "diff", @args);
515         }
516         elsif ($command eq "clean") {
517             &git($localpath, "clean", @args);
518         }
519         elsif ($command eq "reset") {
520             &git($localpath, "reset", @args);
521         }
522         elsif ($command eq "branch") {
523             &git($localpath, "branch", @args);
524         }
525         elsif ($command eq "config") {
526             &git($localpath, "config", @args);
527         }
528         elsif ($command eq "repack") {
529             &git($localpath, "repack", @args);
530         }
531         elsif ($command eq "format-patch") {
532             &git($localpath, "format-patch", @args);
533         }
534         elsif ($command eq "gc") {
535             &git($localpath, "gc", @args);
536         }
537         elsif ($command eq "tag") {
538             &git($localpath, "tag", @args);
539         }
540         elsif ($command eq "compare") {
541             # Don't compare the subrepos; it doesn't work properly as
542             # they aren't on a branch.
543             next if $remotepath eq "-";
544
545             my $compareto;
546             if ($#args eq -1) {
547                 $compareto = $path;
548             }
549             elsif ($#args eq 0) {
550                 $compareto = "$args[0]/$localpath";
551             }
552             elsif ($#args eq 1 && $args[0] eq "-b") {
553                 $compareto = "$args[1]/$remotepath";
554             }
555             else {
556                 die "Bad args for compare";
557             }
558             print "$localpath";
559             print (' ' x (40 - length($localpath)));
560             my $branch = &readgitline($localpath, "rev-parse", "--abbrev-ref", "HEAD");
561             die "Bad branch: $branch"
562                 unless $branch =~ m!^[a-zA-Z][a-zA-Z0-9./-]*$!;
563             my $us   = &readgitline(".", "ls-remote", $localpath, "refs/heads/$branch");
564             my $them = &readgitline(".", "ls-remote", $compareto, "refs/heads/$branch");
565             $us   =~ s/[[:space:]].*//;
566             $them =~ s/[[:space:]].*//;
567             die "Bad commit of mine: $us"     unless (length($us)   eq 40);
568             die "Bad commit of theirs: $them" unless (length($them) eq 40);
569             if ($us eq $them) {
570                 print "same\n";
571             }
572             else {
573                 print "DIFFERENT\n";
574             }
575         }
576         else {
577             die "Unknown command: $command";
578         }
579     }
580
581     unlink "resume";
582 }
583
584 sub gitInitSubmodules {
585     &git(".", "submodule", "init", @_);
586
587     my ($repo_base, $checked_out_tree, $repo_local) = getrepo();
588
589     my $submodulespaths = &readgit(".", "config", "--get-regexp", "^submodule[.].*[.]url");
590     # if we came from github, change the urls appropriately
591     while ($submodulespaths =~ m!^(submodule.(?:libraries|utils)/[a-zA-Z0-9-]+.url) ($GITHUB)/ghc/packages/([a-zA-Z0-9-]+).git$!gm) {
592         &git(".", "config", $1, "$2/ghc/packages-$3");
593     }
594
595     # if we came from a local repository, grab our submodules from their
596     # checkouts over there, if they exist.
597     if ($repo_local) {
598         while ($submodulespaths =~ m!^(submodule.((?:libraries|utils)/[a-zA-Z0-9-]+).url) .*$!gm) {
599             if (-e "$repo_base/$2/.git") {
600                 &git(".", "config", $1, "$repo_base/$2");
601             }
602         }
603     }
604 }
605
606 sub checkCurrentBranchIsMaster {
607     my $branch = `git symbolic-ref HEAD`;
608     $branch =~ s/refs\/heads\///;
609     $branch =~ s/\n//;
610
611     if ($branch !~ /master/) {
612         print "\nWarning: You are trying to 'pull' while on branch '$branch'.\n"
613             . "Updates to this script will happen on the master branch which\n"
614             . "means the version on this branch may be out of date.\n\n";
615     }
616 }
617
618 sub help
619 {
620         my $exit = shift;
621
622         my $tags = join ' ', sort (grep !/^-$/, keys %tags);
623
624         # Get the built in help
625         my $help = <<END;
626 Usage:
627
628 ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare]
629            [--<tag>] [--no-<tag>] [--resume]
630            cmd [git flags]
631
632     where <tag> is one of: $tags
633
634 Applies the command "cmd" to each repository in the tree.
635
636 A full repository tree is obtained by first cloning the ghc
637 repository, then getting the subrepositories with "sync-all get":
638
639   \$ git clone http://git.haskell.org/ghc.git
640   \$ cd ghc
641   \$ ./sync-all get
642
643 After this, "./sync-all pull" will pull from the original repository
644 tree.
645
646 A remote pointing to another local repository tree can be added like
647 this:
648
649   \$ ./sync-all -r /path/to/ghc remote add otherlocal
650
651 and then we can pull from this other tree with
652
653   \$ ./sync-all pull otherlocal
654
655 -------------- Commands -----------------
656 get
657
658     Clones all sub-repositories from the same place that the ghc
659     repository was cloned from. See "which repos to use" below
660     for details of how the subrepositories are laid out.
661
662     There are various --<package-tag> options that can be given
663     before "get" that enable extra repositories. The full list is
664     given at the end of this help. For example:
665
666     ./sync-all --nofib get
667
668     would get the nofib repository in addition to the usual set of
669     subrepositories.
670
671 remote add <remote-name>
672 remote rm <remote-name>
673 remote set-url [--push] <remote-name>
674
675     Runs a "git remote" command on each subrepository, adjusting the
676     repository location in each case appropriately. For example, to
677     add a new remote pointing to the upstream repositories:
678
679     ./sync-all -r http://git.haskell.org remote add upstream
680
681     The -r flag points to the root of the repository tree (see "which
682     repos to use" below). For a repository on the local filesystem it
683     would point to the ghc repository, and for a remote repository it
684     points to the directory containing "ghc.git".
685
686 compare
687 compare reporoot
688 compare -b reporoot
689
690     Compare the git HEADs of the repos to the origin repos, or the
691     repos under reporoot (which is assumde to be a checked-out tree
692     unless the -b flag is used).
693
694     1 line is printed for each repo, indicating whether the repo is
695     at the "same" or a "DIFFERENT" commit.
696
697 These commands just run the equivalent git command on each repository, passing
698 any extra arguments to git:
699
700   branch
701   checkout
702   clean
703   commit
704   config
705   diff
706   fetch
707   format-patch
708   gc
709   grep
710   log
711   new
712   new-workdir
713   pull
714   push
715   repack
716   reset
717   send
718   status
719   tag
720
721 -------------- Flags -------------------
722 These flags are given *before* the command and modify the way sync-all behaves.
723 Flags given *after* the command are passed to git.
724
725   -q says to be quiet, and -s to be silent.
726
727   --resume will restart a command that failed, from the repo at which it
728   failed. This means you don't need to wait while, e.g., "pull" goes through
729   all the repos it's just pulled, and tries to pull them again.
730
731   --ignore-failure says to ignore errors and move on to the next repository
732
733   -r repo says to use repo as the location of package repositories
734
735   --checked-out says that the remote repo is in checked-out layout, as opposed
736   to the layout used for the main repo. By default a repo on the local
737   filesystem is assumed to be checked-out, and repos accessed via HTTP or SSH
738   are assumed to be in the main repo layout; use --checked-out to override the
739   latter.
740
741   --bare says that the local repo is in bare layout, same as the main repo. It
742   also means that these repos are bare. You only have to use this flag if you
743   don't have a bare ghc.git in the current directory and would like to 'get'
744   all of the repos bare. Requires packages.conf to be present in the current
745   directory (a renamed packages file from the main ghc repo).
746
747   Note: --checked-out and --bare flags are NOT the opposite of each other.
748         --checked-out: describes the layout of the remote repository tree.
749         --bare:        describes the layout of the local repository tree.
750
751   --nofib also clones the nofib benchmark suite
752
753   --extra also clone some extra library packages
754
755   --no-dph avoids cloning the dph packages
756
757
758 ------------ Checking out a branch -------------
759 To check out a branch you can run the following command:
760
761   \$ ./sync-all checkout ghc-7.4
762
763
764 ------------ Which repos to use -------------
765 sync-all uses the following algorithm to decide which remote repos to use
766
767 It always computes the remote repos from a single base, <repo_base> How is
768 <repo_base> set? If you say "-r repo", then that's <repo_base> otherwise
769 <repo_base> is set by asking git where the ghc repo came from, and removing the
770 last component (e.g. /ghc.git/ or /ghc/).
771
772 Then sync-all iterates over the package found in the file ./packages; see that
773 file for a description of the contents.
774
775 If <repo_base> looks like a local filesystem path, or if you give the
776 --checked-out flag, sync-all works on repos of form:
777
778   <repo_base>/<local-path>
779
780 otherwise sync-all works on repos of form:
781
782   <repo_base>/<remote-path>
783
784 This logic lets you say
785   both    sync-all -r http://example.org/ghc-6.12 remote add ghc-6.12
786   and     sync-all -r ../working remote add working
787 The latter is called a "checked-out tree".
788
789 sync-all *ignores* the defaultrepo of all repos other than the root one. So the
790 remote repos must be laid out in one of the two formats given by <local-path>
791 and <remote-path> in the file 'packages'.
792
793 Available package-tags are:
794 END
795
796         # Collect all the tags in the packages file
797         my %available_tags;
798         open IN, "< packages.conf"
799             or open IN, "< packages" # clashes with packages directory when using --bare
800             or die "Can't open packages file (or packages.conf)";
801         while (<IN>) {
802             chomp;
803             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
804                 if (defined($2) && $2 ne "-") {
805                     $available_tags{$2} = 1;
806                 }
807             }
808             elsif (! /^(#.*)?$/) {
809                 die "Bad line: $_";
810             }
811         }
812         close IN;
813
814         # Show those tags and the help text
815         my @available_tags = keys %available_tags;
816         print "$help@available_tags\n\n";
817         exit $exit;
818 }
819
820 sub main {
821
822     &parsePackages();
823
824     $tags{"-"} = 1;
825     $tags{"dph"} = 1;
826     if ($OSNAME =~ /^(MSWin32|Cygwin|msys)$/) {
827         $tags{"windows"} = 1;
828     }
829
830     while ($#_ ne -1) {
831         my $arg = shift;
832         # We handle -q here as well as lower down as we need to skip over it
833         # if it comes before the source-control command
834         if ($arg eq "-q") {
835             $verbose = 1;
836         }
837         elsif ($arg eq "-s") {
838             $verbose = 0;
839         }
840         elsif ($arg eq "-r") {
841             $defaultrepo = shift;
842         }
843         elsif ($arg eq "--resume") {
844             $try_to_resume = 1;
845         }
846         elsif ($arg eq "--ignore-failure") {
847             $ignore_failure = 1;
848         }
849         elsif ($arg eq "--complete" || $arg eq "--partial") {
850             $get_mode = $arg;
851         }
852         # Use --checked-out if the _remote_ repos are a checked-out tree,
853         # rather than the master trees.
854         elsif ($arg eq "--checked-out") {
855             $checked_out_flag = 1;
856         }
857         # Use --bare if the _local_ repos are bare repos,
858         # rather than a checked-out tree.
859         elsif ($arg eq "--bare") {
860             $bare_flag = $arg;
861         }
862         elsif ($arg eq "--help") {
863             help(0);
864         }
865         # --<tag> says we grab the libs tagged 'tag' with
866         # 'get'. It has no effect on the other commands.
867         elsif ($arg =~ m/^--no-(.*)$/ && defined($tags{$1})) {
868             $tags{$1} = 0;
869         }
870         elsif ($arg =~ m/^--(.*)$/ && defined($tags{$1})) {
871             $tags{$1} = 1;
872         }
873         elsif ($arg =~ m/^-/) {
874             die "Unrecognised flag: $arg";
875         }
876         else {
877             unshift @_, $arg;
878             if (grep /^-q$/, @_) {
879                 $verbose = 1;
880             }
881             last;
882         }
883     }
884
885     # check for ghc repositories in cwd
886     my $checked_out_found = 1 if (-d ".git" && -d "compiler");
887     my $bare_found = 1 if (-d "ghc.git");
888
889     if ($bare_flag && ! $bare_found && ! $defaultrepo) {
890         die "error: bare repository ghc.git not found.\n"
891           . "       Either clone a bare ghc repo first or specify the repo location. E.g.:\n"
892           . "       ./sync-all --bare [--nofib --extra] -r http://git.haskell.org get\n"
893     }
894     elsif ($bare_found) {
895         $bare_flag = "--bare";
896     }
897     elsif (! $bare_flag && ! $checked_out_found) {
898         die "error: sync-all must be run from the top level of the ghc tree.";
899     }
900
901     if ($#_ eq -1) {
902         help(1);
903     }
904     else {
905         # Give the command and rest of the arguments to the main loop
906         # We normalise command names here to avoid duplicating the
907         # abbreviations that we allow.
908         my $command = shift;
909
910         if ($command =~ /^(?:g|ge|get)$/) {
911             $command = "get";
912         }
913         elsif ($command =~ /^(?:pus|push)$/) {
914             $command = "push";
915         }
916         elsif ($command =~ /^(?:pul|pull)$/) {
917             $command = "pull";
918         }
919         elsif ($command =~ /^(?:s|se|sen|send)$/) {
920             $command = "send";
921         }
922         elsif ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
923             $command = "status";
924         }
925
926         if ($command eq "push") {
927             &gitall("check_submodules", @_);
928         }
929
930         &gitall($command, @_);
931
932         my @submodule_args = grep(/^-q/,@_);
933
934         if ($command eq "get") {
935             &gitInitSubmodules(@submodule_args);
936         }
937
938         if ($command eq "pull") {
939             my $gitConfig = &tryReadFile(".git/config");
940             if ($gitConfig !~ /submodule/) {
941                 &gitInitSubmodules(@submodule_args);
942             }
943         }
944         if ($command eq "get" or $command eq "pull") {
945             my $gitConfig = &tryReadFile(".git/config");
946             if ($gitConfig !~ /submodule/) {
947                 &gitInitSubmodules(@submodule_args);
948             }
949             &git(".", "submodule", "update", @submodule_args);
950         }
951     }
952 }
953
954 BEGIN {
955     my %argvHash = map { $_, 1 } @ARGV;
956     if ($argvHash {"pull"}) {
957         checkCurrentBranchIsMaster();
958     }
959     $initial_working_directory = getcwd();
960
961     $SIG{__DIE__} = sub {
962       die @_ if $^S;
963       $exit_via_die = 1;
964     };
965
966     my @obsolete_dirs = qw!
967         testsuite
968         libraries/base
969         libraries/ghc-prim
970         libraries/template-haskell
971         libraries/integer-gmp
972         libraries/integer-simple
973         !;
974     for my $dir (@obsolete_dirs) {
975         if (-d "$dir/.git") {
976             print <<EOF;
977 ============================
978 ATTENTION!
979
980 You have a left-over $dir/.git folder in your GHC tree!
981
982 Please backup or remove it (e.g. "rm -r $dir/.git") before
983 proceeding as the aforesaid Git repository is now tracked as part of
984 the ghc Git repository (see #8545 for more details)
985 ============================
986 EOF
987             die "detected obsolete $dir/.git folder"
988         }
989     }
990 }
991
992 END {
993     return if $exit_via_die;
994     my $ec = $?;
995
996     chdir($initial_working_directory);
997
998     my @obsolete_dirs = (
999         ["utils/haddock",    "87e2ca11c3d1b1bc49900fba0b5c5c6f85650718"],
1000         ["libraries/binary", "749ac0efbde3b14901417364a872796598747aaf"],
1001         ["libraries/mtl",    "c67d8f7247c612dc35242bc67e616f7ea35eadb9"],
1002         ["libraries/Cabal",  "c8ebd66a32865f72ae03ee0663c62df3d77f08fe"],
1003         );
1004     for (@obsolete_dirs) {
1005         my ($dir, $hash) = $_;
1006         my $name = $dir =~ m!/([^/]+)$!;
1007         message "== Checking for old $name repo";
1008         if (-d "$dir/.git") {
1009             chdir($dir);
1010             if ((system "git log -1 $hash > /dev/null 2> /dev/null") == 0) {
1011                 print <<EOF;
1012 ============================
1013 ATTENTION!
1014
1015 You have an old $name repository in your GHC tree!
1016
1017 Please remove it (e.g. "rm -r $dir"), and then run
1018 "./sync-all get" to get the new repository.
1019 ============================
1020 EOF
1021             }
1022             chdir($initial_working_directory);
1023         }
1024     }
1025     message "== Checking for old time from tarball";
1026     if (-d "libraries/time" and ! -e "libraries/time/.git") {
1027             print <<EOF;
1028 ============================
1029 ATTENTION!
1030
1031 You have an old time package in your GHC tree!
1032
1033 Please remove it (e.g. "rm -r libraries/time"), and then run
1034 "./sync-all get" to get the new repository.
1035 ============================
1036 EOF
1037     }
1038
1039     message "== Checking for obsolete Git repo URL";
1040     my $repo_url = &readgitline(".", 'config', '--get', 'remote.origin.url');
1041     if ($repo_url =~ /^http:\/\/darcs.haskell.org/) {
1042             print <<EOF;
1043 ============================
1044 ATTENTION!
1045
1046 You seem to be using obsolete Git repository URLs.
1047
1048 Please run
1049
1050   ./sync-all -r git://git.haskell.org remote set-url
1051
1052 or (in case port 9418/tcp is filtered by your firewall)
1053
1054   ./sync-all -r http://git.haskell.org remote set-url
1055
1056 to update your local checkout to use the new Git URLs.
1057 ============================
1058 EOF
1059     }
1060
1061     $? = $ec;
1062 }
1063
1064 main(@ARGV);
1065