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