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 my $defaultrepo;
7 my @packages;
8 my $verbose = 2;
9 my $ignore_failure = 0;
10 my $want_remote_repo = 0;
11 my $checked_out_flag = 0;
12 my $get_mode;
13
14 # Flags specific to a particular command
15 my $local_repo_unnecessary = 0;
16
17 my %tags;
18
19 # Figure out where to get the other repositories from.
20 sub getrepo {
21     my $basedir = ".";
22     my $repo;
23
24     if (defined($defaultrepo)) {
25         $repo = $defaultrepo;
26         chomp $repo;
27     } else {
28         # Figure out where to get the other repositories from,
29         # based on where this GHC repo came from.
30         my $branch = `git branch | grep "\* " | sed "s/^\* //"`; chomp $branch;
31         my $remote = `git config branch.$branch.remote`;         chomp $remote;
32         $repo = `git config remote.$remote.url`;       chomp $repo;
33     }
34
35     my $repo_base;
36     my $checked_out_tree;
37
38     if ($repo =~ /^...*:/) {
39         # HTTP or SSH
40         # Above regex says "at least two chars before the :", to avoid
41         # catching Win32 drives ("C:\").
42         $repo_base = $repo;
43
44         # --checked-out is needed if you want to use a checked-out repo
45         # over SSH or HTTP
46         if ($checked_out_flag) {
47             $checked_out_tree = 1;
48         } else {
49             $checked_out_tree = 0;
50         }
51
52         # Don't drop the last part of the path if specified with -r, as
53         # it expects repos of the form:
54         #
55         #   http://darcs.haskell.org
56         #
57         # rather than
58         #   
59         #   http://darcs.haskell.org/ghc
60         #
61         if (!$defaultrepo) {
62             $repo_base =~ s#/[^/]+/?$##;
63         }
64     }
65     elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
66         # Local filesystem, either absolute or relative path
67         # (assumes a checked-out tree):
68         $repo_base = $repo;
69         $checked_out_tree = 1;
70     }
71     else {
72         die "Couldn't work out repo";
73     }
74
75     return $repo_base, $checked_out_tree;
76 }
77
78 sub parsePackages {
79     my @repos;
80     my $lineNum;
81
82     open IN, "< packages" or die "Can't open packages file";
83     @repos = <IN>;
84     close IN;
85
86     @packages = ();
87     $lineNum = 0;
88     foreach (@repos) {
89         chomp;
90         $lineNum++;
91         if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
92             my %line;
93             $line{"localpath"}  = $1;
94             $line{"tag"}        = $2;
95             $line{"remotepath"} = $3;
96             $line{"vcs"}        = $4;
97             $line{"upstream"}   = $5;
98             push @packages, \%line;
99         }
100         elsif (! /^(#.*)?$/) {
101             die "Bad content on line $lineNum of packages file: $_";
102         }
103     }
104 }
105
106 sub message {
107     if ($verbose >= 2) {
108         print "@_\n";
109     }
110 }
111
112 sub warning {
113     if ($verbose >= 1) {
114         print "warning: @_\n";
115     }
116 }
117
118 sub scm {
119     my $dir = shift;
120     my $scm = shift;
121     my $pwd;
122
123     if ($dir eq '.') {
124         message "== running $scm @_";
125     } else {
126         message "== $dir: running $scm @_";
127         $pwd = getcwd();
128         chdir($dir);
129     }
130
131     system ($scm, @_) == 0
132         or $ignore_failure
133         or die "$scm failed: $?";
134
135     if ($dir ne '.') {
136         chdir($pwd);
137     }
138 }
139
140 sub repoexists {
141     my ($scm, $localpath) = @_;
142     
143     if ($scm eq "darcs") {
144         -d "$localpath/_darcs";
145     }
146     else {
147         -d "$localpath/.git";
148     }
149 }
150
151 sub scmall {
152     my $command = shift;
153     
154     my $localpath;
155     my $tag;
156     my $remotepath;
157     my $scm;
158     my $upstream;
159     my $line;
160
161     my $path;
162     my $wd_before = getcwd;
163
164     my @scm_args;
165
166     my $pwd;
167
168     my ($repo_base, $checked_out_tree) = getrepo();
169
170     parsePackages;
171
172     for $line (@packages) {
173
174             $localpath  = $$line{"localpath"};
175             $tag        = $$line{"tag"};
176             $remotepath = $$line{"remotepath"};
177             $scm        = $$line{"vcs"};
178             $upstream   = $$line{"upstream"};
179
180             # Check the SCM is OK as early as possible
181             die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
182
183             # Work out the path for this package in the repo we pulled from
184             if ($checked_out_tree) {
185                 $path = "$repo_base/$localpath";
186             }
187             else {
188                 $path = "$repo_base/$remotepath";
189             }
190
191             # Work out the arguments we should give to the SCM
192             if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
193                 @scm_args = (($scm eq "darcs" and "whatsnew")
194                           or ($scm eq "git" and "status"));
195                 
196                 # Hack around 'darcs whatsnew' failing if there are no changes
197                 $ignore_failure = 1;
198             }
199             elsif ($command =~ /^(?:pus|push)$/) {
200                 @scm_args = "push";
201                 $want_remote_repo = 1;
202             }
203             elsif ($command =~ /^(?:pul|pull)$/) {
204                 @scm_args = "pull";
205                 $want_remote_repo = 1;
206                 # Q: should we append the -a argument for darcs repos?
207             }
208             elsif ($command =~ /^(?:g|ge|get)$/) {
209                 # Skip any repositories we have not included the tag for
210                 if (not defined($tags{$tag})) {
211                     next;
212                 }
213                 
214                 if (-d $localpath) {
215                     warning("$localpath already present; omitting") if $localpath ne ".";
216                     next;
217                 }
218                 
219                 # The first time round the loop, default the get-mode
220                 if (not defined($get_mode)) {
221                     warning("adding --partial, to override use --complete");
222                     $get_mode = "--partial";
223                 }
224                 
225                 # The only command that doesn't need a repo
226                 $local_repo_unnecessary = 1;
227                 
228                 if ($scm eq "darcs") {
229                     # Note: we can only use the get-mode with darcs for now
230                     @scm_args = ("get", $get_mode, $path, $localpath);
231                 }
232                 else {
233                     @scm_args = ("clone", $path, $localpath);
234                 }
235             }
236             elsif ($command =~ /^(?:s|se|sen|send)$/) {
237                 @scm_args = (($scm eq "darcs" and "send")
238                           or ($scm eq "git" and "send-email"));
239                 $want_remote_repo = 1;
240             }
241             elsif ($command =~ /^set-origin$/) {
242                 @scm_args = ("remote", "set-url", "origin", $path);
243             }
244             elsif ($command =~ /^fetch$/) {
245                 @scm_args = ("fetch", "origin");
246             }
247             elsif ($command =~ /^new$/) {
248                 @scm_args = ("log", "origin..");
249             }
250             else {
251                 die "Unknown command: $command";
252             }
253             
254             # Actually execute the command
255             if (repoexists ($scm, $localpath)) {
256                 if ($want_remote_repo) {
257                     if ($scm eq "darcs") {
258                         scm (".", $scm, @scm_args, @_, "--repodir=$localpath", $path);
259                     } else {
260                         # git pull doesn't like to be used with --work-dir
261                         # I couldn't find an alternative to chdir() here
262                         scm ($localpath, $scm, @scm_args, @_, $path, "master");
263                     }
264                 } else {
265                     # git status *must* be used with --work-dir, if we don't chdir() to the dir
266                     scm ($localpath, $scm, @scm_args, @_);
267                 }
268             }
269             elsif ($local_repo_unnecessary) {
270                 # Don't bother to change directory in this case
271                 scm (".", $scm, @scm_args, @_);
272             }
273             elsif ($tag eq "") {
274                 message "== Required repo $localpath is missing! Skipping";
275             }
276             else {
277                 message "== $localpath repo not present; skipping";
278             }
279     }
280 }
281
282 sub main {
283     if (! -d ".git" || ! -d "compiler") {
284         die "error: sync-all must be run from the top level of the ghc tree."
285     }
286
287     $tags{"-"} = 1;
288     $tags{"dph"} = 1;
289
290     while ($#_ ne -1) {
291         my $arg = shift;
292         # We handle -q here as well as lower down as we need to skip over it
293         # if it comes before the source-control command
294         if ($arg eq "-q") {
295             $verbose = 1;
296         }
297         elsif ($arg eq "-s") {
298             $verbose = 0;
299         }
300         elsif ($arg eq "-r") {
301             $defaultrepo = shift;
302         }
303         elsif ($arg eq "--ignore-failure") {
304             $ignore_failure = 1;
305         }
306         elsif ($arg eq "--complete" || $arg eq "--partial") {
307             $get_mode = $arg;
308         }
309         # Use --checked-out if the remote repos are a checked-out tree,
310         # rather than the master trees.
311         elsif ($arg eq "--checked-out") {
312             $checked_out_flag = 1;
313         }
314         # --<tag> says we grab the libs tagged 'tag' with
315         # 'get'. It has no effect on the other commands.
316         elsif ($arg =~ m/^--/) {
317             $arg =~ s/^--//;
318             $tags{$arg} = 1;
319         }
320         else {
321             unshift @_, $arg;
322             if (grep /^-q$/, @_) {
323                 $verbose = 1;
324             }
325             last;
326         }
327     }
328
329     if ($#_ eq -1) {
330         # Get the built in help
331         my $help = <<END;
332 What do you want to do?
333 Supported commands:
334
335  * whatsnew
336  * push
337  * pull
338  * get, with options:
339   * --<package-tag>
340   * --complete
341   * --partial
342  * fetch
343  * send
344  * set-origin
345  * new
346
347 Available package-tags are:
348 END
349
350         # Collect all the tags in the packages file
351         my %available_tags;
352         open IN, "< packages" or die "Can't open packages file";
353         while (<IN>) {
354             chomp;
355             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
356                 if (defined($2) && $2 ne "-") {
357                     $available_tags{$2} = 1;
358                 }
359             }
360             elsif (! /^(#.*)?$/) {
361                 die "Bad line: $_";
362             }
363         }
364         close IN;
365         
366         # Show those tags and the help text
367         my @available_tags = keys %available_tags;
368         print "$help@available_tags\n";
369         exit 1;
370     }
371     else {
372         # Give the command and rest of the arguments to the main loop
373         scmall @_;
374     }
375 }
376
377 main(@ARGV);
378