non-threaded RTS: don't assume deadlock if there are signal handlers to run
[ghc.git] / darcs-all
1 #!/usr/bin/perl -w
2
3 use strict;
4
5 my @top_dirs = ("nofib", "testsuite");
6
7 # Figure out where to get the other repositories from,
8 # based on where this GHC repo came from.
9 my $defaultrepo = `cat _darcs/prefs/defaultrepo`;
10 chomp $defaultrepo;
11 my $defaultrepo_base;
12 my $defaultrepo_lib;
13
14 if ($defaultrepo =~ /^...*:/) {
15     # HTTP or SSH
16     # Above regex says "at least two chars before the :", to avoid
17     # catching Win32 drives ("C:\").
18     $defaultrepo_base = $defaultrepo;
19     $defaultrepo_base =~ s#/[^/]+/?$##;
20     $defaultrepo_lib = "$defaultrepo_base/packages";
21 }
22 elsif ($defaultrepo =~ /^\//) {
23     # Local filesystem, absolute path (assumes a checked-out tree):
24     $defaultrepo_base = $defaultrepo;
25     $defaultrepo_lib = "$defaultrepo/libraries";
26 }
27 elsif ($defaultrepo =~ /^..\//) {
28     # Local filesystem, relative path (assumes a checked-out tree):
29     $defaultrepo_base = $defaultrepo;
30     $defaultrepo_lib = "$defaultrepo/libraries";
31 }
32 else {
33     die "Couldn't work out defaultrepo";
34 }
35
36 my $verbose = 2;
37 my $ignore_failure = 0;
38
39 # --extra says we grab the extra libs with 'get'.  It has no effect on
40 # the other commands.
41 my $extra = 0;
42 # --nofib/--testsuite tell get to also grab the respective repos.
43 # They have no effect on the other commands.
44 my $nofib = 0;
45 my $testsuite = 0;
46
47 sub message {
48     if ($verbose >= 2) {
49         print "@_\n";
50     }
51 }
52
53 sub warning {
54     if ($verbose >= 1) {
55         print "warning: @_\n";
56     }
57 }
58
59 sub darcs {
60     message "== running darcs @_";
61     system ("darcs", @_) == 0
62         or $ignore_failure
63         or die "darcs failed: $?";
64 }
65
66 sub darcsall {
67     my @packages;
68     darcs @_;
69     for my $dir (@top_dirs) {
70         if (-d $dir && -d "$dir/_darcs") {
71             darcs (@_, "--repodir", $dir);
72         }
73         else {
74             message "== $dir not present or not a repository; skipping";
75         }
76     }
77     for my $path (<libraries/*/_darcs>) {
78         chomp $path;
79         if ($path =~ m#/(.*)/#) {
80             my $pkg = $1;
81             darcs (@_, "--repodir", "libraries/$pkg");
82         }
83         else {
84             die "that pattern can't fail!";
85         }
86     }
87     @packages = `cat libraries/boot-packages`;
88     # @packages = `cat libraries/boot-packages libraries/extra-packages`;
89     for my $pkg (@packages) {
90         chomp $pkg;
91         if (! -d "libraries/$pkg") {
92             warning("$pkg doesn't exist, use 'darcs-all get' to get it");
93         }
94     }
95 }
96
97 sub darcsgetpackage {
98     my ($get_it, $r_flags, $repo_root, $package) = @_;
99
100     if ($get_it) {
101         if (-d $package) {
102             warning("$package already present; omitting");
103         }
104         else {
105             darcs (@$r_flags, "$repo_root/$package");
106         }
107     }
108 }
109
110 sub darcsget {
111     my $r_flags;
112     if (! grep /(?:--complete|--partial)/, @_) {
113         warning("adding --partial, to override use --complete");
114         $r_flags = [@_, "--partial"];
115     }
116     else {
117         $r_flags = \@_;
118     }
119
120     darcsgetpackage($nofib,     $r_flags, $defaultrepo_base, "nofib");
121     darcsgetpackage($testsuite, $r_flags, $defaultrepo_base, "testsuite");
122
123     chdir "libraries";
124
125     my @packages;
126     if ($extra) {
127         @packages = `cat boot-packages extra-packages`;
128     }
129     else {
130         @packages = `cat boot-packages`;
131     }
132
133     for my $pkg (@packages) {
134         chomp $pkg;
135         darcsgetpackage(1, $r_flags, $defaultrepo_lib, $pkg);
136     }
137 }
138
139 sub main {
140     if (! -d "_darcs" || ! -d "compiler") {
141         die "error: darcs-all must be run from the top level of the ghc tree."
142     }
143
144     while ($#_ ne -1) {
145         my $arg = shift;
146         # We handle -q here as well as lower down as we need to skip over it
147         # if it comes before the darcs command
148         if ($arg eq "-q") {
149             $verbose = 1;
150         }
151         elsif ($arg eq "-s") {
152             $verbose = 0;
153         }
154         elsif ($arg eq "--extra") {
155             $extra = 1;
156         }
157         elsif ($arg eq "--nofib") {
158             $nofib = 1;
159         }
160         elsif ($arg eq "--testsuite") {
161             $testsuite = 1;
162         }
163         else {
164             unshift @_, $arg;
165             if (grep /^-q$/, @_) {
166                 $verbose = 1;
167             }
168             last;
169         }
170     }
171
172     if ($#_ eq -1) {
173         die "What do you want to do?";
174     }
175     my $command = $_[0];
176     if ($command eq "get") {
177         darcsget @_;
178     }
179     else {
180         if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
181             # Hack around whatsnew failing if there are no changes
182             $ignore_failure = 1;
183         }
184         darcsall @_;
185     }
186 }
187
188 main(@ARGV);
189