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 }
 122
 123 sub darcs {
 124     message "== running darcs @_";
 125     system ("darcs", @_) == 0
 126        or $ignore_failure
 127        or die "darcs failed: $?";
 128 }
 129
 130 sub darcsall {
 131     my $localpath;
 132     my $remotepath;
 133     my $path;
 134     my $tag;
 135     my @repos;
 136
 137     my ($repo_base, $checked_out_tree) = getrepo();
 138
 139     open IN, "< packages" or die "Can't open packages file";
 140     @repos = <IN>;
 141     close IN;
 142
 143     foreach (@repos) {
 144         chomp;
 145         if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
 146             $localpath = $1;
 147             $tag = defined($2) ? $2 : "";
 148             $remotepath = $3;
 149
 150             if ($checked_out_tree) {
 151                 $path = "$repo_base/$localpath";
 152             }
 153             else {
 154                 $path = "$repo_base/$remotepath";
 155             }
 156
 157             if (-d "$localpath/_darcs") {
 158                 if ($want_remote_repo) {
 159                     darcs (@_, "--repodir", $localpath, $path);
 160                 } else {
 161                     darcs (@_, "--repodir", $localpath);
 162                 }
 163             }
 164             elsif ($tag eq "") {
 165                 message "== Required repo $localpath is missing! Skipping";
 166             }
 167             else {
 168                 message "== $localpath repo not present; skipping";
 169             }
 170         }
 171         elsif (! /^(#.*)?$/) {
 172             die "Bad line: $_";
 173         }
 174     }
 175
 176     if ($_[0] eq "pull" || $_[0] eq "pul") {
 177         &sync_tarballs();
 178     }
 179 }
 180
 181 sub darcsget {
 182     my $r_flags;
 183     my $localpath;
 184     my $remotepath;
 185     my $path;
 186     my $tag;
 187     my @repos;
 188
 189     my ($repo_base, $checked_out_tree) = getrepo();
 190
 191     if (! grep /(?:--complete|--partial)/, @_) {
 192         warning("adding --partial, to override use --complete");
 193         $r_flags = [@_, "--partial"];
 194     }
 195     else {
 196         $r_flags = \@_;
 197     }
 198
 199     open IN, "< packages" or die "Can't open packages file";
 200     @repos = <IN>;
 201     close IN;
 202
 203     foreach (@repos) {
 204         chomp;
 205         if (/^([^ ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
 206             $localpath = $1;
 207             $tag = defined($2) ? $2 : "";
 208             $remotepath = $3;
 209
 210             if ($checked_out_tree) {
 211                 $path = "$repo_base/$localpath";
 212             }
 213             else {
 214                 $path = "$repo_base/$remotepath";
 215             }
 216
 217             if (($tag eq "") || defined($tags{$tag})) {
 218                 if (-d $localpath) {
 219                     warning("$localpath already present; omitting");
 220                 }
 221                 else {
 222                     darcs (@$r_flags, $path, $localpath);
 223                 }
 224             }
 225         }
 226         elsif (! /^(#.*)?$/) {
 227             die "Bad line: $_";
 228         }
 229     }
 230
 231     &sync_tarballs();
 232 }
 233
 234 sub sync_tarballs {
 235     my $localpath;
 236     my $localdirectory;
 237     my $localfilename;
 238     my $actualpath;
 239     my $actualfilename;
 240     my $remotepath;
 241     my $path;
 242     my @tarballs;
 243     my %localtarballs;
 244     my ($repo_base, $checked_out_tree) = getrepo();
 245
 246     message "== Syncing tarballs";
 247
 248     open IN, "< tarballs" or die "Can't open packages file";
 249     @tarballs = <IN>;
 250     close IN;
 251
 252     foreach (@tarballs) {
 253         chomp;
 254         if (m@^([^# ]+)/([^#/ ]+) +([^ ]+)$@) {
 255             $localdirectory = $1;
 256             $localfilename = $2;
 257             $remotepath = $3;
 258             $localpath = "$localdirectory/$localfilename";
 259
 260             $localtarballs{$localdirectory}{$localfilename} = 1;
 261
 262             if (! -e $localpath) {
 263                 if ($checked_out_tree) {
 264                     $path = "$repo_base/$localpath";
 265                 }
 266                 else {
 267                     $path = "$repo_base/$remotepath";
 268                 }
 269                 &download($path, $localpath);
 270             }
 271         }
 272         elsif (! /^(#.*)?$/) {
 273             die "Bad line: $_";
 274         }
 275     }
 276
 277     foreach $localdirectory (keys %localtarballs) {
 278         FILE: foreach $actualpath (glob "$localdirectory/*.tar.gz $localdirectory/*.tar.bz2") {
 279             $actualfilename = $actualpath;
 280             $actualfilename =~ s#.*/##;
 281             if (! defined($localtarballs{$localdirectory}{$actualfilename})) {
 282                 message "== Deleting $actualpath";
 283                 unlink $actualpath;
 284             }
 285         }
 286     }
 287 }
 288
 289 sub main {
 290     if (! -d "compiler") {
 291         die "error: darcs-all must be run from the top level of the ghc tree."
 292     }
 293
 294     while ($#_ ne -1) {
 295         my $arg = shift;
 296         # We handle -q here as well as lower down as we need to skip over it
 297         # if it comes before the darcs command
 298         if ($arg eq "-q") {
 299             $verbose = 1;
 300         }
 301         elsif ($arg eq "-s") {
 302             $verbose = 0;
 303         }
 304         elsif ($arg eq "-r") {
 305             $defaultrepo = shift;
 306         }
 307         elsif ($arg eq "-i") {
 308             $ignore_failure = 1;
 309         }
 310         # --nofib tells get to also grab the nofib repo.
 311         # It has no effect on the other commands.
 312         elsif ($arg eq "--nofib") {
 313             $tags{"nofib"} = 1;
 314         }
 315         # --testsuite tells get to also grab the testsuite repo.
 316         # It has no effect on the other commands.
 317         elsif ($arg eq "--testsuite") {
 318             $tags{"testsuite"} = 1;
 319         }
 320         elsif ($arg eq "--checked-out") {
 321             $checked_out_flag = 1;
 322         }
 323         else {
 324             unshift @_, $arg;
 325             if (grep /^-q$/, @_) {
 326                 $verbose = 1;
 327             }
 328             last;
 329         }
 330     }
 331
 332     if ($#_ eq -1) {
 333         die "What do you want to do?";
 334     }
 335     my $command = $_[0];
 336     if ($command eq "get") {
 337         darcsget @_;
 338     }
 339     else {
 340         if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
 341             # Hack around whatsnew failing if there are no changes
 342             $ignore_failure = 1;
 343         }
 344         if ($command =~ /^(pul|pus|sen|put)/) {
 345             $want_remote_repo = 1;
 346         }
 347         darcsall @_;
 348     }
 349 }
 350
 351 END {
 352     message "== Checking for old bytestring repo";
 353     if (-d "libraries/bytestring/_darcs") {
 354         if ((system "darcs annotate --repodir libraries/bytestring --match 'hash 20080118173113-3fd76-d5b74c04372a297b585ebea4e16d524551ce5035' > /dev/null 2> /dev/null") == 0) {
 355             print <<EOF;
 356 ============================
 357 ATTENTION!
 358
 359 You have an old bytestring repository in your GHC tree!
 360
 361 Please remove it (e.g. "rm -r libraries/bytestring"), and the new
 362 version of bytestring will be used from a tarball instead.
 363 ============================
 364 EOF
 365         }
 366     }
 367 }
 368
 369 main(@ARGV);
 370