darcs-all

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 # Usage:
   6 #
   7 # ./darcs-all [-q] [-s] [-i] [-r repo]
   8 #             [--nofib] [--testsuite] [--checked-out] cmd [darcs flags]
   9 #
  10 # Applies the darcs command "cmd" to each repository in the tree.
  11 #
  12 # e.g.
  13 #      ./darcs-all -r http://darcs.haskell.org/ghc get
  14 #          To get any repos which do not exist in the local tree
  15 #
  16 #      ./darcs-all -r ~/ghc-validate push
  17 #          To push all your repos to the ~/ghc-validate tree
  18 #
  19 #      ./darcs-all pull -a
  20 #          To pull everything from the default repos
  21 #
  22 #      ./darc-all push --dry-run
  23 #          To see what local patches you have relative to the main repos
  24 #
  25 #   -q says to be quite, and -s to be silent.
  26 #
  27 #   -i says to ignore darcs errors and move on to the next repository
  28 #
  29 #   -r repo says to use repo as the location of package repositories
  30 #
  31 #   --checked-out says that the remote repo is in checked-out layout, as
  32 #   opposed to the layout used for the main repo.  By default a repo on
  33 #   the local filesystem is assumed to be checked-out, and repos accessed
  34 #   via HTTP or SSH are assumed to be in the main repo layout; use
  35 #   --checked-out to override the latter.
  36 #
  37 #   --nofib, --testsuite also get the nofib and testsuite repos respectively
  38 #
  39 #   The darcs get flag you are most likely to want is --complete. By
  40 #   default we pass darcs the --partial flag.
  41 #
  42
  43 $| = 1; # autoflush stdout after each print, to avoid output after die
  44
  45 my $defaultrepo;
  46
  47 my $verbose = 2;
  48 my $ignore_failure = 0;
  49 my $want_remote_repo = 0;
  50 my $checked_out_flag = 0;
  51
  52 my %tags;
  53
  54 # Figure out where to get the other repositories from.
  55 sub getrepo {
  56     my $basedir = ".";
  57     my $repo = $defaultrepo || `cat $basedir/_darcs/prefs/defaultrepo`;
  58     chomp $repo;
  59
  60     my $repo_base;
  61     my $checked_out_tree;
  62
  63     if ($repo =~ /^...*:/) {
  64         # HTTP or SSH
  65         # Above regex says "at least two chars before the :", to avoid
  66         # catching Win32 drives ("C:\").
  67         $repo_base = $repo;
  68
  69         # --checked-out is needed if you want to use a checked-out repo
  70         # over SSH or HTTP
  71         if ($checked_out_flag) {
  72             $checked_out_tree = 1;
  73         } else {
  74             $checked_out_tree = 0;
  75         }
  76
  77         # Don't drop the last part of the path if specified with -r, as
  78         # it expects repos of the form:
  79         #
  80         #   http://darcs.haskell.org
  81         #
  82         # rather than
  83         #
  84         #   http://darcs.haskell.org/ghc
  85         #
  86         if (!$defaultrepo) {
  87             $repo_base =~ s#/[^/]+/?$##;
  88         }
  89     }
  90     elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
  91         # Local filesystem, either absolute or relative path
  92         # (assumes a checked-out tree):
  93         $repo_base = $repo;
  94         $checked_out_tree = 1;
  95     }
  96     else {
  97         die "Couldn't work out repo";
  98     }
  99
 100     return $repo_base, $checked_out_tree;
 101 }
 102
 103 sub message {
 104     if ($verbose >= 2) {
 105         print "@_\n";
 106     }
 107 }
 108
 109 sub warning {
 110     if ($verbose >= 1) {
 111         print "warning: @_\n";
 112     }
 113 }
 114
 115 sub download {
 116     my ($from, $to) = @_;
 117
 118     my @cmd = ("wget", $from, "-O", $to);
 119     message "== running @cmd";
 120     system @cmd;
 121     if ($? == -1) {
 122         die "Failed to execute wget: $!\n";
 123     }
 124     elsif ($? != 0) {
 125         die "wget failed: $?\n";
 126     }
 127 }
 128
 129 sub darcs {
 130     message "== running darcs @_";
 131     system ("darcs", @_) == 0
 132        or $ignore_failure
 133        or die "darcs failed: $?";
 134 }
 135
 136 sub darcsall {
 137     my $localpath;
 138     my $remotepath;
 139     my $path;
 140     my $tag;
 141     my @repos;
 142
 143     my ($repo_base, $checked_out_tree) = getrepo();
 144
 145     open IN, "< packages" or die "Can't open packages file";
 146     @repos = <IN>;
 147     close IN;
 148
 149     foreach (@repos) {
 150         chomp;
 151         if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
 152             $localpath = $1;
 153             $tag = defined($2) ? $2 : "";
 154             $remotepath = $3;
 155
 156             if ($checked_out_tree) {
 157                 $path = "$repo_base/$localpath";
 158             }
 159             else {
 160                 $path = "$repo_base/$remotepath";
 161             }
 162
 163             if (-d "$localpath/_darcs") {
 164                 if ($want_remote_repo) {
 165                     darcs (@_, "--repodir", $localpath, $path);
 166                 } else {
 167                     darcs (@_, "--repodir", $localpath);
 168                 }
 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
 182     if ($_[0] eq "pull" || $_[0] eq "pul") {
 183         &sync_tarballs();
 184     }
 185 }
 186
 187 sub darcsget {
 188     my $r_flags;
 189     my $localpath;
 190     my $remotepath;
 191     my $path;
 192     my $tag;
 193     my @repos;
 194
 195     my ($repo_base, $checked_out_tree) = getrepo();
 196
 197     if (! grep /(?:--complete|--partial)/, @_) {
 198         warning("adding --partial, to override use --complete");
 199         $r_flags = [@_, "--partial"];
 200     }
 201     else {
 202         $r_flags = \@_;
 203     }
 204
 205     open IN, "< packages" or die "Can't open packages file";
 206     @repos = <IN>;
 207     close IN;
 208
 209     foreach (@repos) {
 210         chomp;
 211         if (/^([^ ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
 212             $localpath = $1;
 213             $tag = defined($2) ? $2 : "";
 214             $remotepath = $3;
 215
 216             if ($checked_out_tree) {
 217                 $path = "$repo_base/$localpath";
 218             }
 219             else {
 220                 $path = "$repo_base/$remotepath";
 221             }
 222
 223             if (($tag eq "") || defined($tags{$tag})) {
 224                 if (-d $localpath) {
 225                     warning("$localpath already present; omitting");
 226                 }
 227                 else {
 228                     darcs (@$r_flags, $path, $localpath);
 229                 }
 230             }
 231         }
 232         elsif (! /^(#.*)?$/) {
 233             die "Bad line: $_";
 234         }
 235     }
 236
 237     &sync_tarballs();
 238 }
 239
 240 sub sync_tarballs {
 241     my $localpath;
 242     my $localdirectory;
 243     my $localfilename;
 244     my $actualpath;
 245     my $actualfilename;
 246     my $remotepath;
 247     my $path;
 248     my @tarballs;
 249     my %localtarballs;
 250     my ($repo_base, $checked_out_tree) = getrepo();
 251
 252     message "== Syncing tarballs";
 253
 254     open IN, "< tarballs" or die "Can't open packages file";
 255     @tarballs = <IN>;
 256     close IN;
 257
 258     foreach (@tarballs) {
 259         chomp;
 260         if (m@^([^# ]+)/([^#/ ]+) +([^ ]+)$@) {
 261             $localdirectory = $1;
 262             $localfilename = $2;
 263             $remotepath = $3;
 264             $localpath = "$localdirectory/$localfilename";
 265
 266             $localtarballs{$localdirectory}{$localfilename} = 1;
 267
 268             if (! -e $localpath) {
 269                 if ($checked_out_tree) {
 270                     $path = "$repo_base/$localpath";
 271                 }
 272                 else {
 273                     $path = "$repo_base/$remotepath";
 274                 }
 275                 &download($path, $localpath);
 276             }
 277         }
 278         elsif (! /^(#.*)?$/) {
 279             die "Bad line: $_";
 280         }
 281     }
 282
 283     foreach $localdirectory (keys %localtarballs) {
 284         FILE: foreach $actualpath (glob "$localdirectory/*.tar.gz $localdirectory/*.tar.bz2") {
 285             $actualfilename = $actualpath;
 286             $actualfilename =~ s#.*/##;
 287             if (! defined($localtarballs{$localdirectory}{$actualfilename})) {
 288                 message "== Deleting $actualpath";
 289                 unlink $actualpath;
 290             }
 291         }
 292     }
 293 }
 294
 295 sub main {
 296     if (! -d "compiler") {
 297         die "error: darcs-all must be run from the top level of the ghc tree."
 298     }
 299
 300     while ($#_ ne -1) {
 301         my $arg = shift;
 302         # We handle -q here as well as lower down as we need to skip over it
 303         # if it comes before the darcs command
 304         if ($arg eq "-q") {
 305             $verbose = 1;
 306         }
 307         elsif ($arg eq "-s") {
 308             $verbose = 0;
 309         }
 310         elsif ($arg eq "-r") {
 311             $defaultrepo = shift;
 312         }
 313         elsif ($arg eq "-i") {
 314             $ignore_failure = 1;
 315         }
 316         # --nofib tells get to also grab the nofib repo.
 317         # It has no effect on the other commands.
 318         elsif ($arg eq "--nofib") {
 319             $tags{"nofib"} = 1;
 320         }
 321         # --testsuite tells get to also grab the testsuite repo.
 322         # It has no effect on the other commands.
 323         elsif ($arg eq "--testsuite") {
 324             $tags{"testsuite"} = 1;
 325         }
 326         elsif ($arg eq "--checked-out") {
 327             $checked_out_flag = 1;
 328         }
 329         else {
 330             unshift @_, $arg;
 331             if (grep /^-q$/, @_) {
 332                 $verbose = 1;
 333             }
 334             last;
 335         }
 336     }
 337
 338     if ($#_ eq -1) {
 339         die "What do you want to do?";
 340     }
 341     my $command = $_[0];
 342     if ($command eq "get") {
 343         darcsget @_;
 344     }
 345     else {
 346         if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
 347             # Hack around whatsnew failing if there are no changes
 348             $ignore_failure = 1;
 349         }
 350         if ($command =~ /^(pul|pus|sen|put)/) {
 351             $want_remote_repo = 1;
 352         }
 353         darcsall @_;
 354     }
 355 }
 356
 357 END {
 358     message "== Checking for old bytestring repo";
 359     if (-d "libraries/bytestring/_darcs") {
 360         if ((system "darcs annotate --repodir libraries/bytestring --match 'hash 20080118173113-3fd76-d5b74c04372a297b585ebea4e16d524551ce5035' > /dev/null 2> /dev/null") == 0) {
 361             print <<EOF;
 362 ============================
 363 ATTENTION!
 364
 365 You have an old bytestring repository in your GHC tree!
 366
 367 Please remove it (e.g. "rm -r libraries/bytestring"), and the new
 368 version of bytestring will be used from a tarball instead.
 369 ============================
 370 EOF
 371         }
 372     }
 373 }
 374
 375 main(@ARGV);
 376