adapt to the new async exceptions API
[ghc.git] / sync-all
1 #!/usr/bin/perl -w
2
3 use strict;
4 use Cwd;
5
6 # Figure out where to get the other repositories from,
7 # based on where this GHC repo came from.
8 my $branch = `git branch | grep "\* " | sed "s/^\* //"`; chomp $branch;
9 my $remote = `git config branch.$branch.remote`;         chomp $remote;
10 my $defaultrepo = `git config remote.$remote.url`;       chomp $defaultrepo;
11
12 my $defaultrepo_base;
13 my $checked_out_tree;
14
15 if ($defaultrepo =~ /^...*:/) {
16     # HTTP or SSH
17     # Above regex says "at least two chars before the :", to avoid
18     # catching Win32 drives ("C:\").
19     $defaultrepo_base = $defaultrepo;
20     $defaultrepo_base =~ s#/[^/]+/?$##;
21     $checked_out_tree = 0;
22 }
23 elsif ($defaultrepo =~ /^\/|\.\.\/|.:(\/|\\)/) {
24     # Local filesystem, either absolute or relative path
25     # (assumes a checked-out tree):
26     $defaultrepo_base = $defaultrepo;
27     $checked_out_tree = 1;
28 }
29 else {
30     die "Couldn't work out defaultrepo";
31 }
32
33 my $verbose = 2;
34 my $get_mode;
35
36 # Flags specific to a particular command
37 my $ignore_failure = 0;
38 my $local_repo_unnecessary = 0;
39
40 # Always define the empty tag so that we fetch the /required/ packages
41 my %tags;
42 $tags{""} = 1;
43
44 sub message {
45     if ($verbose >= 2) {
46         print "@_\n";
47     }
48 }
49
50 sub warning {
51     if ($verbose >= 1) {
52         print "warning: @_\n";
53     }
54 }
55
56 sub scm {
57     my $scm = shift;
58     
59     message "== running $scm @_";
60     system ($scm, @_) == 0
61         or $ignore_failure
62         or die "$scm failed: $?";
63 }
64
65 sub repoexists {
66     my ($scm, $localpath) = @_;
67     
68     if ($scm eq "darcs") {
69         -d "$localpath/_darcs";
70     }
71     else {
72         -d "$localpath/.git";
73     }
74 }
75
76 sub scmall {
77     my $command = shift;
78     
79     my $localpath;
80     my $tag;
81     my $remotepath;
82     my $scm;
83
84     my $path;
85     my $wd_before = getcwd;
86
87     my @scm_args;
88
89     open IN, "< packages" or die "Can't open packages file";
90     while (<IN>) {
91         chomp;
92         if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
93             $localpath = $1;
94             $tag = defined($2) ? $2 : "";
95             $remotepath = $3;
96             $scm = $4;
97
98             # Check the SCM is OK as early as possible
99             die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
100
101             # Work out the path for this package in the repo we pulled from
102             if ($checked_out_tree) {
103                 $path = "$defaultrepo_base/$localpath";
104             }
105             else {
106                 $path = "$defaultrepo_base/$remotepath";
107             }
108             
109             # Work out the arguments we should give to the SCM
110             if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
111                 @scm_args = (($scm eq "darcs" and "whatsnew")
112                           or ($scm eq "git" and "status"));
113                 
114                 # Hack around 'darcs whatsnew' failing if there are no changes
115                 $ignore_failure = 1;
116             }
117             elsif ($command =~ /^(?:pus|push)$/) {
118                 @scm_args = "push";
119             }
120             elsif ($command =~ /^(?:pul|pull)$/) {
121                 @scm_args = "pull";
122                 # Q: should we append the -a argument for darcs repos?
123             }
124             elsif ($command =~ /^(?:g|ge|get)$/) {
125                 # Skip any repositories we have not included the tag for
126                 if (not defined($tags{$tag})) {
127                     next;
128                 }
129                 
130                 if (-d $localpath) {
131                     warning("$localpath already present; omitting") if $localpath ne ".";
132                     next;
133                 }
134                 
135                 # The first time round the loop, default the get-mode
136                 if (not defined($get_mode)) {
137                     warning("adding --partial, to override use --complete");
138                     $get_mode = "--partial";
139                 }
140                 
141                 # The only command that doesn't need a repo
142                 $local_repo_unnecessary = 1;
143                 
144                 if ($scm eq "darcs") {
145                     # Note: we can only use the get-mode with darcs for now
146                     @scm_args = ("get", $get_mode, $path, $localpath);
147                 }
148                 else {
149                     @scm_args = ("clone", $path, $localpath);
150                 }
151             }
152             elsif ($command =~ /^(?:s|se|sen|send)$/) {
153                 @scm_args = (($scm eq "darcs" and "send")
154                           or ($scm eq "git" and "send-email"));
155             }
156             else {
157                 die "Unknown command: $command";
158             }
159             
160             # Actually execute the command
161             chdir $wd_before or die "Could not change to $wd_before";
162             if (repoexists ($scm, $localpath)) {
163                 chdir $localpath or die "Could not change to $localpath";
164                 scm ($scm, @scm_args, @_);
165             }
166             elsif ($local_repo_unnecessary) {
167                 # Don't bother to change directory in this case
168                 scm ($scm, @scm_args, @_);
169             }
170             elsif ($tag eq "") {
171                 message "== Required repo $localpath is missing! Skipping";
172             }
173             else {
174                 message "== $localpath repo not present; skipping";
175             }
176         }
177         elsif (! /^(#.*)?$/) {
178             die "Bad line: $_";
179         }
180     }
181     close IN;
182 }
183
184 sub main {
185     if (! -d ".git" || ! -d "compiler") {
186         die "error: sync-all must be run from the top level of the ghc tree."
187     }
188
189     while ($#_ ne -1) {
190         my $arg = shift;
191         # We handle -q here as well as lower down as we need to skip over it
192         # if it comes before the source-control command
193         if ($arg eq "-q") {
194             $verbose = 1;
195         }
196         elsif ($arg eq "-s") {
197             $verbose = 0;
198         }
199         elsif ($arg eq "--ignore-failure") {
200             $ignore_failure = 1;
201         }
202         elsif ($arg eq "--complete" || $arg eq "--partial") {
203             $get_mode = $arg;
204         }
205         # --<tag> says we grab the libs tagged 'tag' with
206         # 'get'. It has no effect on the other commands.
207         elsif ($arg =~ m/^--/) {
208             $arg =~ s/^--//;
209             $tags{$arg} = 1;
210         }
211         else {
212             unshift @_, $arg;
213             if (grep /^-q$/, @_) {
214                 $verbose = 1;
215             }
216             last;
217         }
218     }
219
220     if ($#_ eq -1) {
221         # Get the built in help
222         my $help = <<END;
223 What do you want to do?
224 Supported commands:
225
226  * whatsnew
227  * push
228  * pull
229  * get, with options:
230   * --<package-tag>
231   * --complete
232   * --partial
233  * send
234
235 Available package-tags are:
236 END
237
238         # Collect all the tags in the packages file
239         my %available_tags;
240         open IN, "< packages" or die "Can't open packages file";
241         while (<IN>) {
242             chomp;
243             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
244                 if (defined($2)) {
245                     $available_tags{$2} = 1;
246                 }
247             }
248             elsif (! /^(#.*)?$/) {
249                 die "Bad line: $_";
250             }
251         }
252         close IN;
253         
254         # Show those tags and the help text
255         my @available_tags = keys %available_tags;
256         print "$help@available_tags";
257         exit 1;
258     }
259     else {
260         # Give the command and rest of the arguments to the main loop
261         scmall @_;
262     }
263 }
264
265 main(@ARGV);
266