add the -r flag from darcs-all
[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 my @packages;
16
17 my $verbose = 2;
18 my $ignore_failure = 0;
19 my $want_remote_repo = 0;
20 my $checked_out_flag = 0;
21
22 my $get_mode;
23
24 # Flags specific to a particular command
25 my $local_repo_unnecessary = 0;
26
27 my %tags;
28
29 # Figure out where to get the other repositories from.
30 sub getrepo {
31     my $basedir = ".";
32     my $repo = $defaultrepo || `cat $basedir/_darcs/prefs/defaultrepo`;
33     chomp $repo;
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.git" 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 $scm = shift;
120     
121     message "== running $scm @_";
122     system ($scm, @_) == 0
123         or $ignore_failure
124         or die "$scm failed: $?";
125 }
126
127 sub repoexists {
128     my ($scm, $localpath) = @_;
129     
130     if ($scm eq "darcs") {
131         -d "$localpath/_darcs";
132     }
133     else {
134         -d "$localpath/.git";
135     }
136 }
137
138 sub scmall {
139     my $command = shift;
140     
141     my $localpath;
142     my $tag;
143     my $remotepath;
144     my $scm;
145     my $upstream;
146     my $line;
147
148     my $path;
149     my $wd_before = getcwd;
150
151     my @scm_args;
152
153     my ($repo_base, $checked_out_tree) = getrepo();
154
155     parsePackages;
156
157     for $line (@packages) {
158
159             $localpath  = $$line{"localpath"};
160             $tag        = $$line{"tag"};
161             $remotepath = $$line{"remotepath"};
162             $scm        = $$line{"vcs"};
163             $upstream   = $$line{"upstream"};
164
165             # Check the SCM is OK as early as possible
166             die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
167
168             # Work out the path for this package in the repo we pulled from
169             if ($checked_out_tree) {
170                 $path = "$repo_base/$localpath";
171             }
172             else {
173                 $path = "$repo_base/$remotepath";
174             }
175
176             # Work out the arguments we should give to the SCM
177             if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
178                 @scm_args = (($scm eq "darcs" and "whatsnew")
179                           or ($scm eq "git" and "status"));
180                 
181                 # Hack around 'darcs whatsnew' failing if there are no changes
182                 $ignore_failure = 1;
183             }
184             elsif ($command =~ /^(?:pus|push)$/) {
185                 @scm_args = "push";
186                 $want_remote_repo = 1;
187             }
188             elsif ($command =~ /^(?:pul|pull)$/) {
189                 @scm_args = "pull";
190                 $want_remote_repo = 1;
191                 # Q: should we append the -a argument for darcs repos?
192             }
193             elsif ($command =~ /^(?:g|ge|get)$/) {
194                 # Skip any repositories we have not included the tag for
195                 if (not defined($tags{$tag})) {
196                     next;
197                 }
198                 
199                 if (-d $localpath) {
200                     warning("$localpath already present; omitting") if $localpath ne ".";
201                     next;
202                 }
203                 
204                 # The first time round the loop, default the get-mode
205                 if (not defined($get_mode)) {
206                     warning("adding --partial, to override use --complete");
207                     $get_mode = "--partial";
208                 }
209                 
210                 # The only command that doesn't need a repo
211                 $local_repo_unnecessary = 1;
212                 
213                 if ($scm eq "darcs") {
214                     # Note: we can only use the get-mode with darcs for now
215                     @scm_args = ("get", $get_mode, $path, $localpath);
216                 }
217                 else {
218                     @scm_args = ("clone", $path, $localpath);
219                 }
220             }
221             elsif ($command =~ /^(?:s|se|sen|send)$/) {
222                 @scm_args = (($scm eq "darcs" and "send")
223                           or ($scm eq "git" and "send-email"));
224                 $want_remote_repo = 1;
225             }
226             else {
227                 die "Unknown command: $command";
228             }
229             
230             # Actually execute the command
231             if (repoexists ($scm, $localpath)) {
232                 if ($want_remote_repo) {
233                     if ($scm eq "darcs") {
234                         scm ($scm, @scm_args, @_, "--repodir=$localpath", $path);
235                     } else {
236                         # git pull doesn't like to be used with --work-dir
237                         scm ($scm, "--git-dir=$localpath/.git", @scm_args, @_, $path, "master");
238                     }
239                 } else {
240                     # git status *must* be used with --work-dir, if we don't chdir() to the dir
241                     scm ($scm, "--git-dir=$localpath/.git", "--work-tree=$localpath", @scm_args, @_);
242                 }
243             }
244             elsif ($local_repo_unnecessary) {
245                 # Don't bother to change directory in this case
246                 scm ($scm, @scm_args, @_);
247             }
248             elsif ($tag eq "") {
249                 message "== Required repo $localpath is missing! Skipping";
250             }
251             else {
252                 message "== $localpath repo not present; skipping";
253             }
254     }
255 }
256
257 sub main {
258     if (! -d ".git" || ! -d "compiler") {
259         die "error: sync-all must be run from the top level of the ghc tree."
260     }
261
262     $tags{"-"} = 1;
263     $tags{"dph"} = 1;
264
265     while ($#_ ne -1) {
266         my $arg = shift;
267         # We handle -q here as well as lower down as we need to skip over it
268         # if it comes before the source-control command
269         if ($arg eq "-q") {
270             $verbose = 1;
271         }
272         elsif ($arg eq "-s") {
273             $verbose = 0;
274         }
275         elsif ($arg eq "-r") {
276             $defaultrepo = shift;
277         }
278         elsif ($arg eq "--ignore-failure") {
279             $ignore_failure = 1;
280         }
281         elsif ($arg eq "--complete" || $arg eq "--partial") {
282             $get_mode = $arg;
283         }
284         # Use --checked-out if the remote repos are a checked-out tree,
285         # rather than the master trees.
286         elsif ($arg eq "--checked-out") {
287             $checked_out_flag = 1;
288         }
289         # --<tag> says we grab the libs tagged 'tag' with
290         # 'get'. It has no effect on the other commands.
291         elsif ($arg =~ m/^--/) {
292             $arg =~ s/^--//;
293             $tags{$arg} = 1;
294         }
295         else {
296             unshift @_, $arg;
297             if (grep /^-q$/, @_) {
298                 $verbose = 1;
299             }
300             last;
301         }
302     }
303
304     if ($#_ eq -1) {
305         # Get the built in help
306         my $help = <<END;
307 What do you want to do?
308 Supported commands:
309
310  * whatsnew
311  * push
312  * pull
313  * get, with options:
314   * --<package-tag>
315   * --complete
316   * --partial
317  * send
318
319 Available package-tags are:
320 END
321
322         # Collect all the tags in the packages file
323         my %available_tags;
324         open IN, "< packages" or die "Can't open packages file";
325         while (<IN>) {
326             chomp;
327             if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
328                 if (defined($2) && $2 ne "-") {
329                     $available_tags{$2} = 1;
330                 }
331             }
332             elsif (! /^(#.*)?$/) {
333                 die "Bad line: $_";
334             }
335         }
336         close IN;
337         
338         # Show those tags and the help text
339         my @available_tags = keys %available_tags;
340         print "$help@available_tags\n";
341         exit 1;
342     }
343     else {
344         # Give the command and rest of the arguments to the main loop
345         scmall @_;
346     }
347 }
348
349 main(@ARGV);
350