darcs-all

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 # Usage:
   6 #
   7 # ./darcs-all [-q] [-s] [-i] [-r repo] [--nofib] [--testsuite] get [darcs get flags]
   8 #   This gets the GHC core repos, if they do not already exist.
   9 #   -q says to be quite, and -s to be silent.
  10 #   -i says to ignore darcs errors and move on to the next repository
  11 #   -r repo says to use repo as the location of package repositories
  12 #   --nofib, --testsuite also get the nofib and testsuite repos respectively
  13 #   The darcs get flag you are most likely to want is --complete. By
  14 #   default we pass darcs the --partial flag.
  15 #
  16 # ./darcs-all [-q] [-s] [-i] [-r repo] cmd [darcs cmd flags]
  17 #   This runs the darcs "cmd" command, with any flags you give, in all
  18 #   of the repos you have checked out. e.g.
  19 #       ./darcs-all pull
  20 #       ./darcs-all -q send --dry-run
  21 #   -q says to be quite, and -s to be silent.
  22
  23 $| = 1; # autoflush stdout after each print, to avoid output after die
  24
  25 my $defaultrepo;
  26
  27 my $verbose = 2;
  28 my $ignore_failure = 0;
  29 my $want_remote_repo = 0;
  30
  31 my %tags;
  32
  33 # Figure out where to get the other repositories from.
  34 sub getrepo {
  35     my $basedir = ".";
  36     my $repo = $defaultrepo || `cat $basedir/_darcs/prefs/defaultrepo`;
  37     chomp $repo;
  38
  39     my $repo_base;
  40     my $checked_out_tree;
  41
  42     if ($repo =~ /^...*:/) {
  43         # HTTP or SSH
  44         # Above regex says "at least two chars before the :", to avoid
  45         # catching Win32 drives ("C:\").
  46         $repo_base = $repo;
  47         $checked_out_tree = 0;
  48
  49         # Don't drop the last part of the path if specified with -r, as
  50         # it expects repos of the form:
  51         #
  52         #   http://darcs.haskell.org
  53         #
  54         # rather than
  55         #
  56         #   http://darcs.haskell.org/ghc
  57         #
  58         if (!$defaultrepo) {
  59             $repo_base =~ s#/[^/]+/?$##;
  60         }
  61     }
  62     elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
  63         # Local filesystem, either absolute or relative path
  64         # (assumes a checked-out tree):
  65         $repo_base = $repo;
  66         $checked_out_tree = 1;
  67     }
  68     else {
  69         die "Couldn't work out repo";
  70     }
  71
  72     return $repo_base, $checked_out_tree;
  73 }
  74
  75 sub message {
  76     if ($verbose >= 2) {
  77         print "@_\n";
  78     }
  79 }
  80
  81 sub warning {
  82     if ($verbose >= 1) {
  83         print "warning: @_\n";
  84     }
  85 }
  86
  87 sub darcs {
  88     message "== running darcs @_";
  89     system ("darcs", @_) == 0
  90        or $ignore_failure
  91        or die "darcs failed: $?";
  92 }
  93
  94 sub darcsall {
  95     my $localpath;
  96     my $remotepath;
  97     my $path;
  98     my $tag;
  99     my @repos;
 100
 101     my ($repo_base, $checked_out_tree) = getrepo();
 102
 103     open IN, "< packages" or die "Can't open packages file";
 104     @repos = <IN>;
 105     close IN;
 106
 107     REPO: foreach (@repos) {
 108         chomp;
 109         if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
 110             $localpath = $1;
 111             $tag = defined($2) ? $2 : "";
 112             $remotepath = $3;
 113
 114             if ($checked_out_tree) {
 115                 $path = "$repo_base/$localpath";
 116             }
 117             else {
 118                 $path = "$repo_base/$remotepath";
 119             }
 120
 121             if (-d "$localpath/_darcs") {
 122                 if ($want_remote_repo) {
 123                     darcs (@_, "--repodir", $localpath, $path);
 124                 } else {
 125                     darcs (@_, "--repodir", $localpath);
 126                 }
 127             }
 128             elsif ($tag eq "") {
 129                 message "== Required repo $localpath is missing! Skipping";
 130             }
 131             else {
 132                 message "== $localpath repo not present; skipping";
 133             }
 134         }
 135         elsif (! /^(#.*)?$/) {
 136             die "Bad line: $_";
 137         }
 138     }
 139 }
 140
 141 sub darcsget {
 142     my $r_flags;
 143     my $localpath;
 144     my $remotepath;
 145     my $path;
 146     my $tag;
 147     my @repos;
 148
 149     my ($repo_base, $checked_out_tree) = getrepo();
 150
 151     if (! grep /(?:--complete|--partial)/, @_) {
 152         warning("adding --partial, to override use --complete");
 153         $r_flags = [@_, "--partial"];
 154     }
 155     else {
 156         $r_flags = \@_;
 157     }
 158
 159     open IN, "< packages" or die "Can't open packages file";
 160     @repos = <IN>;
 161     close IN;
 162
 163     foreach (@repos) {
 164         chomp;
 165         if (/^([^ ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)$/) {
 166             $localpath = $1;
 167             $tag = defined($2) ? $2 : "";
 168             $remotepath = $3;
 169
 170             if ($checked_out_tree) {
 171                 $path = "$repo_base/$localpath";
 172             }
 173             else {
 174                 $path = "$repo_base/$remotepath";
 175             }
 176
 177             if (($tag eq "") || defined($tags{$tag})) {
 178                 if (-d $localpath) {
 179                     warning("$localpath already present; omitting");
 180                 }
 181                 else {
 182                     darcs (@$r_flags, $path, $localpath);
 183                 }
 184             }
 185         }
 186         elsif (! /^(#.*)?$/) {
 187             die "Bad line: $_";
 188         }
 189     }
 190 }
 191
 192 sub main {
 193     if (! -d "compiler") {
 194         die "error: darcs-all must be run from the top level of the ghc tree."
 195     }
 196
 197     while ($#_ ne -1) {
 198         my $arg = shift;
 199         # We handle -q here as well as lower down as we need to skip over it
 200         # if it comes before the darcs command
 201         if ($arg eq "-q") {
 202             $verbose = 1;
 203         }
 204         elsif ($arg eq "-s") {
 205             $verbose = 0;
 206         }
 207         elsif ($arg eq "-r") {
 208             $defaultrepo = shift;
 209         }
 210         elsif ($arg eq "-i") {
 211             $ignore_failure = 1;
 212         }
 213         # --nofib tells get to also grab the nofib repo.
 214         # It has no effect on the other commands.
 215         elsif ($arg eq "--nofib") {
 216             $tags{"nofib"} = 1;
 217         }
 218         # --testsuite tells get to also grab the testsuite repo.
 219         # It has no effect on the other commands.
 220         elsif ($arg eq "--testsuite") {
 221             $tags{"testsuite"} = 1;
 222         }
 223         else {
 224             unshift @_, $arg;
 225             if (grep /^-q$/, @_) {
 226                 $verbose = 1;
 227             }
 228             last;
 229         }
 230     }
 231
 232     if ($#_ eq -1) {
 233         die "What do you want to do?";
 234     }
 235     my $command = $_[0];
 236     if ($command eq "get") {
 237         darcsget @_;
 238     }
 239     else {
 240         if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
 241             # Hack around whatsnew failing if there are no changes
 242             $ignore_failure = 1;
 243         }
 244         if ($command =~ /^(pul|pus|sen|put)/) {
 245             $want_remote_repo = 1;
 246         }
 247         darcsall @_;
 248     }
 249 }
 250
 251 main(@ARGV);
 252