stow.in

   1 #!@PERL@
   2
   3 # GNU Stow - manage the installation of multiple software packages
   4 # Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
   5 # Copyright (C) 2000,2001 Guillaume Morin
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 2 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20 #
  21 # $Id$
  22 # $Source$
  23 # $Date$
  24 # $Author$
  25
  26 require 5.005;
  27 use POSIX;
  28
  29 $ProgramName = $0;
  30 $ProgramName =~ s,.*/,,;
  31
  32 $Version = '@VERSION@';
  33
  34 $Conflicts = 0;
  35 $Delete = 0;
  36 $NotReally = 0;
  37 $Verbose = 0;
  38 $ReportHelp = 0;
  39 $Stow = undef;
  40 $Target = undef;
  41 $Restow = 0;
  42
  43
  44 # FIXME: use Getopt::Long
  45 while (@ARGV && ($_ = $ARGV[0]) && /^-/) {
  46   $opt = $';
  47   shift;
  48   last if /^--$/;
  49
  50   if ($opt =~ /^-/) {
  51     $opt = $';
  52     if ($opt =~ /^no?$/i) {
  53       $NotReally = 1;
  54     } elsif ($opt =~ /^c(o(n(f(l(i(c(ts?)?)?)?)?)?)?)?$/i) {
  55       $Conflicts = 1;
  56       $NotReally = 1;
  57     } elsif ($opt =~ /^dir?/i) {
  58       $remainder = $';
  59       if ($remainder =~ /^=/) {
  60         $Stow = $';             # the stuff after the =
  61       } else {
  62         $Stow = shift;
  63       }
  64     } elsif ($opt =~ /^t(a(r(g(et?)?)?)?)?/i) {
  65       $remainder = $';
  66       if ($remainder =~ /^=/) {
  67         $Target = $';           # the stuff after the =
  68       } else {
  69         $Target = shift;
  70       }
  71     } elsif ($opt =~ /^verb(o(se?)?)?/i) {
  72       $remainder = $';
  73       if ($remainder =~ /^=(\d+)/) {
  74         $Verbose = $1;
  75       } else {
  76         ++$Verbose;
  77       }
  78     } elsif ($opt =~ /^de(l(e(te?)?)?)?$/i) {
  79       $Delete = 1;
  80     } elsif ($opt =~ /^r(e(s(t(o(w?)?)?)?)?)?$/i) {
  81       $Restow = 1;
  82     } elsif ($opt =~ /^vers(i(on?)?)?$/i) {
  83       &version();
  84     } else {
  85       &usage(($opt =~ /^h(e(lp?)?)?$/) ? undef :
  86              "unknown or ambiguous option: $opt");
  87     }
  88   } else {
  89     @opts = split(//, $opt);
  90     while ($_ = shift(@opts)) {
  91       if ($_ eq 'n') {
  92         $NotReally = 1;
  93       } elsif ($_ eq 'c') {
  94         $Conflicts = 1;
  95         $NotReally = 1;
  96       } elsif ($_ eq 'd') {
  97         $Stow = (join('', @opts) || shift);
  98         @opts = ();
  99       } elsif ($_ eq 't') {
 100         $Target = (join('', @opts) || shift);
 101         @opts = ();
 102       } elsif ($_ eq 'v') {
 103         ++$Verbose;
 104       } elsif ($_ eq 'D') {
 105         $Delete = 1;
 106       } elsif ($_ eq 'R') {
 107         $Restow = 1;
 108       } elsif ($_ eq 'V') {
 109         &version();
 110       } else {
 111         &usage(($_ eq 'h') ? undef : "unknown option: $_");
 112       }
 113     }
 114   }
 115 }
 116
 117 &usage("No packages named") unless @ARGV;
 118
 119 # Changing dirs helps a lot when soft links are used
 120 $current_dir = &getcwd;
 121 if ($Stow) {
 122   chdir($Stow) || die "Cannot chdir to target tree $Stow ($!)\n";
 123 }
 124
 125 # This prevents problems if $Target was supplied as a relative path
 126 $Stow = &getcwd;
 127
 128 chdir($current_dir) || die "Your directory does not seem to exist anymore ($!)\n";
 129
 130 $Target = &parent($Stow) unless $Target;
 131
 132 chdir($Target) || die "Cannot chdir to target tree $Target ($!)\n";
 133 $Target = &getcwd;
 134
 135 foreach $package (@ARGV) {
 136   $package =~ s,/+$,,;          # delete trailing slashes
 137   if ($package =~ m,/,) {
 138     die "$ProgramName: slashes not permitted in package names\n";
 139   }
 140 }
 141
 142 if ($Delete || $Restow) {
 143   @Collections = @ARGV;
 144   &Unstow('', &RelativePath($Target, $Stow));
 145 }
 146
 147 if (!$Delete || $Restow) {
 148   foreach $Collection (@ARGV) {
 149     warn "Stowing package $Collection...\n" if $Verbose;
 150     &StowContents($Collection, &RelativePath($Target, $Stow));
 151   }
 152 }
 153
 154 sub CommonParent {
 155   local($dir1, $dir2) = @_;
 156   local($result, $x);
 157   local(@d1) = split(/\/+/, $dir1);
 158   local(@d2) = split(/\/+/, $dir2);
 159
 160   while (@d1 && @d2 && (($x = shift(@d1)) eq shift(@d2))) {
 161     $result .= "$x/";
 162   }
 163   chop($result);
 164   $result;
 165 }
 166
 167 # Find the relative patch between
 168 # two paths given as arguments.
 169
 170 sub RelativePath {
 171   local($a, $b) = @_;
 172   local($c) = &CommonParent($a, $b);
 173   local(@a) = split(/\/+/, $a);
 174   local(@b) = split(/\/+/, $b);
 175   local(@c) = split(/\/+/, $c);
 176
 177   # if $c == "/something", scalar(@c) >= 2
 178   # but if $c == "/", scalar(@c) == 0
 179   # but we want 1
 180   my $length = scalar(@c) ? scalar(@c) : 1;
 181   splice(@a, 0, $length);
 182   splice(@b, 0, $length);
 183
 184   unshift(@b, (('..') x (@a + 0)));
 185   &JoinPaths(@b);
 186 }
 187
 188 # Basically concatenates the paths given
 189 # as arguments
 190
 191 sub JoinPaths {
 192   local(@paths, @parts);
 193   local ($x, $y);
 194   local($result) = '';
 195
 196   $result = '/' if ($_[0] =~ /^\//);
 197   foreach $x (@_) {
 198     @parts = split(/\/+/, $x);
 199     foreach $y (@parts) {
 200       push(@paths, $y) if ($y ne "");
 201     }
 202   }
 203   $result .= join('/', @paths);
 204 }
 205
 206 sub Unstow {
 207   local($targetdir, $stow) = @_;
 208   local(@contents);
 209   local($content);
 210   local($linktarget, $stowmember, $collection);
 211   local(@stowmember);
 212   local($pure, $othercollection) = (1, '');
 213   local($subpure, $subother);
 214   local($empty) = (1);
 215   local(@puresubdirs);
 216
 217   return (0, '') if (&JoinPaths($Target, $targetdir) eq $Stow);
 218   return (0, '') if (-e &JoinPaths($Target, $targetdir, '.stow'));
 219   warn sprintf("Unstowing in %s\n", &JoinPaths($Target, $targetdir))
 220     if ($Verbose > 1);
 221   if (!opendir(DIR, &JoinPaths($Target, $targetdir))) {
 222     warn "Warning: $ProgramName: Cannot read directory \"$dir\" ($!). Stow might leave some links. If you think, it does. Rerun Stow with appropriate rights.\n";
 223   }
 224   @contents = readdir(DIR);
 225   closedir(DIR);
 226   foreach $content (@contents) {
 227     next if (($content eq '.') || ($content eq '..'));
 228     $empty = 0;
 229     if (-l &JoinPaths($Target, $targetdir, $content)) {
 230       ($linktarget = readlink(&JoinPaths($Target,
 231                                          $targetdir,
 232                                          $content)))
 233         || die sprintf("%s: Cannot read link %s (%s)\n",
 234                        $ProgramName,
 235                        &JoinPaths($Target, $targetdir, $content),
 236                        $!);
 237       if ($stowmember = &FindStowMember(&JoinPaths($Target,
 238                                                    $targetdir),
 239                                         $linktarget)) {
 240         @stowmember = split(/\/+/, $stowmember);
 241         $collection = shift(@stowmember);
 242         if (grep(($collection eq $_), @Collections)) {
 243           &DoUnlink(&JoinPaths($Target, $targetdir, $content));
 244         } elsif ($pure) {
 245           if ($othercollection) {
 246             $pure = 0 if ($collection ne $othercollection);
 247           } else {
 248             $othercollection = $collection;
 249           }
 250         }
 251       } else {
 252         $pure = 0;
 253       }
 254     } elsif (-d &JoinPaths($Target, $targetdir, $content)) {
 255       ($subpure, $subother) = &Unstow(&JoinPaths($targetdir, $content),
 256                                       &JoinPaths('..', $stow));
 257       if ($subpure) {
 258         push(@puresubdirs, "$content/$subother");
 259       }
 260       if ($pure) {
 261         if ($subpure) {
 262           if ($othercollection) {
 263             if ($subother) {
 264               if ($othercollection ne $subother) {
 265                 $pure = 0;
 266               }
 267             }
 268           } elsif ($subother) {
 269             $othercollection = $subother;
 270           }
 271         } else {
 272           $pure = 0;
 273         }
 274       }
 275     } else {
 276       $pure = 0;
 277     }
 278   }
 279   # This directory was an initially empty directory therefore
 280   # We do not remove it.
 281   $pure = 0 if $empty;
 282   if ((!$pure || !$targetdir) && @puresubdirs) {
 283     &CoalesceTrees($targetdir, $stow, @puresubdirs);
 284   }
 285   ($pure, $othercollection);
 286 }
 287
 288 sub CoalesceTrees {
 289   local($parent, $stow, @trees) = @_;
 290   local($tree, $collection, $x);
 291
 292   foreach $x (@trees) {
 293     ($tree, $collection) = ($x =~ /^(.*)\/(.*)/);
 294     &EmptyTree(&JoinPaths($Target, $parent, $tree));
 295     &DoRmdir(&JoinPaths($Target, $parent, $tree));
 296     if ($collection) {
 297       &DoLink(&JoinPaths($stow, $collection, $parent, $tree),
 298               &JoinPaths($Target, $parent, $tree));
 299     }
 300   }
 301 }
 302
 303 sub EmptyTree {
 304   local($dir) = @_;
 305   local(@contents);
 306   local($content);
 307
 308   opendir(DIR, $dir)
 309     || die "$ProgramName: Cannot read directory \"$dir\" ($!)\n";
 310   @contents = readdir(DIR);
 311   closedir(DIR);
 312   foreach $content (@contents) {
 313     next if (($content eq '.') || ($content eq '..'));
 314     if (-l &JoinPaths($dir, $content)) {
 315       &DoUnlink(&JoinPaths($dir, $content));
 316     } elsif (-d &JoinPaths($dir, $content)) {
 317       &EmptyTree(&JoinPaths($dir, $content));
 318       &DoRmdir(&JoinPaths($dir, $content));
 319     } else {
 320       &DoUnlink(&JoinPaths($dir, $content));
 321     }
 322   }
 323 }
 324
 325 sub StowContents {
 326   local($dir, $stow) = @_;
 327   local(@contents);
 328   local($content);
 329
 330   warn "Stowing contents of $dir\n" if ($Verbose > 1);
 331   opendir(DIR, &JoinPaths($Stow, $dir))
 332     || die "$ProgramName: Cannot read directory \"$dir\" ($!)\n";
 333   @contents = readdir(DIR);
 334   closedir(DIR);
 335   foreach $content (@contents) {
 336     next if (($content eq '.') || ($content eq '..'));
 337     if (-d &JoinPaths($Stow, $dir, $content)) {
 338       &StowDir(&JoinPaths($dir, $content), $stow);
 339     } else {
 340       &StowNondir(&JoinPaths($dir, $content), $stow);
 341     }
 342   }
 343 }
 344
 345 sub StowDir {
 346   local($dir, $stow) = @_;
 347   local(@dir) = split(/\/+/, $dir);
 348   local($collection) = shift(@dir);
 349   local($subdir) = join('/', @dir);
 350   local($linktarget, $stowsubdir);
 351
 352   warn "Stowing directory $dir\n" if ($Verbose > 1);
 353   if (-l &JoinPaths($Target, $subdir)) {
 354     ($linktarget = readlink(&JoinPaths($Target, $subdir)))
 355       || die sprintf("%s: Could not read link %s (%s)\n",
 356                      $ProgramName,
 357                      &JoinPaths($Target, $subdir),
 358                      $!);
 359     ($stowsubdir =
 360      &FindStowMember(sprintf('%s/%s', $Target,
 361                              join('/', @dir[0..($#dir - 1)])),
 362                      $linktarget))
 363       || (&Conflict($dir, $subdir), return);
 364     if (-e &JoinPaths($Stow, $stowsubdir)) {
 365       if ($stowsubdir eq $dir) {
 366         warn sprintf("%s already points to %s\n",
 367                      &JoinPaths($Target, $subdir),
 368                      &JoinPaths($Stow, $dir))
 369           if ($Verbose > 2);
 370         return;
 371       }
 372       if (-d &JoinPaths($Stow, $stowsubdir)) {
 373         &DoUnlink(&JoinPaths($Target, $subdir));
 374         &DoMkdir(&JoinPaths($Target, $subdir));
 375         &StowContents($stowsubdir, &JoinPaths('..', $stow));
 376         &StowContents($dir, &JoinPaths('..', $stow));
 377       } else {
 378         (&Conflict($dir, $subdir), return);
 379       }
 380     } else {
 381       &DoUnlink(&JoinPaths($Target, $subdir));
 382       &DoLink(&JoinPaths($stow, $dir),
 383               &JoinPaths($Target, $subdir));
 384     }
 385   } elsif (-e &JoinPaths($Target, $subdir)) {
 386     if (-d &JoinPaths($Target, $subdir)) {
 387       &StowContents($dir, &JoinPaths('..', $stow));
 388     } else {
 389       &Conflict($dir, $subdir);
 390     }
 391   } else {
 392     &DoLink(&JoinPaths($stow, $dir),
 393             &JoinPaths($Target, $subdir));
 394   }
 395 }
 396
 397 sub StowNondir {
 398   local($file, $stow) = @_;
 399   local(@file) = split(/\/+/, $file);
 400   local($collection) = shift(@file);
 401   local($subfile) = join('/', @file);
 402   local($linktarget, $stowsubfile);
 403
 404   if (-l &JoinPaths($Target, $subfile)) {
 405     ($linktarget = readlink(&JoinPaths($Target, $subfile)))
 406       || die sprintf("%s: Could not read link %s (%s)\n",
 407                      $ProgramName,
 408                      &JoinPaths($Target, $subfile),
 409                      $!);
 410     ($stowsubfile =
 411      &FindStowMember(sprintf('%s/%s', $Target,
 412                              join('/', @file[0..($#file - 1)])),
 413                      $linktarget))
 414       || (&Conflict($file, $subfile), return);
 415     if (-e &JoinPaths($Stow, $stowsubfile)) {
 416       (&Conflict($file, $subfile), return)
 417         unless ($stowsubfile eq $file);
 418       warn sprintf("%s already points to %s\n",
 419                    &JoinPaths($Target, $subfile),
 420                    &JoinPaths($Stow, $file))
 421         if ($Verbose > 2);
 422     } else {
 423       &DoUnlink(&JoinPaths($Target, $subfile));
 424       &DoLink(&JoinPaths($stow, $file),
 425               &JoinPaths($Target, $subfile));
 426     }
 427   } elsif (-e &JoinPaths($Target, $subfile)) {
 428     &Conflict($file, $subfile);
 429   } else {
 430     &DoLink(&JoinPaths($stow, $file),
 431             &JoinPaths($Target, $subfile));
 432   }
 433 }
 434
 435 sub DoUnlink {
 436   local($file) = @_;
 437
 438   warn "UNLINK $file\n" if $Verbose;
 439   (unlink($file) || die "$ProgramName: Could not unlink $file ($!)\n")
 440     unless $NotReally;
 441 }
 442
 443 sub DoRmdir {
 444   local($dir) = @_;
 445
 446   warn "RMDIR $dir\n" if $Verbose;
 447   (rmdir($dir) || die "$ProgramName: Could not rmdir $dir ($!)\n")
 448     unless $NotReally;
 449 }
 450
 451 sub DoLink {
 452   local($target, $name) = @_;
 453
 454   warn "LINK $name to $target\n" if $Verbose;
 455   (symlink($target, $name) ||
 456    die "$ProgramName: Could not symlink $name to $target ($!)\n")
 457     unless $NotReally;
 458 }
 459
 460 sub DoMkdir {
 461   local($dir) = @_;
 462
 463   warn "MKDIR $dir\n" if $Verbose;
 464   (mkdir($dir, 0777)
 465    || die "$ProgramName: Could not make directory $dir ($!)\n")
 466     unless $NotReally;
 467 }
 468
 469 sub Conflict {
 470   local($a, $b) = @_;
 471
 472   if ($Conflicts) {
 473     warn sprintf("CONFLICT: %s vs. %s\n", &JoinPaths($Stow, $a),
 474                  &JoinPaths($Target, $b));
 475   } else {
 476     die sprintf("%s: CONFLICT: %s vs. %s\n",
 477                 $ProgramName,
 478                 &JoinPaths($Stow, $a),
 479                 &JoinPaths($Target, $b));
 480   }
 481 }
 482
 483 sub FindStowMember {
 484   local($start, $path) = @_;
 485   local(@x) = split(/\/+/, $start);
 486   local(@path) = split(/\/+/, $path);
 487   local($x);
 488   local(@d) = split(/\/+/, $Stow);
 489
 490   while (@path) {
 491     $x = shift(@path);
 492     if ($x eq '..') {
 493       pop(@x);
 494       return '' unless @x;
 495     } elsif ($x) {
 496       push(@x, $x);
 497     }
 498   }
 499   while (@x && @d) {
 500     if (($x = shift(@x)) ne shift(@d)) {
 501       return '';
 502     }
 503   }
 504   return '' if @d;
 505   join('/', @x);
 506 }
 507
 508 sub parent {
 509   local($path) = join('/', @_);
 510   local(@elts) = split(/\/+/, $path);
 511   pop(@elts);
 512   join('/', @elts);
 513 }
 514
 515 sub usage {
 516   local($msg) = shift;
 517
 518   if ($msg) {
 519     print "$ProgramName: $msg\n";
 520   }
 521   print "$ProgramName (GNU Stow) version $Version\n\n";
 522   print "Usage: $ProgramName [OPTION ...] PACKAGE ...\n";
 523   print <<EOT;
 524   -n, --no              Do not actually make changes
 525   -c, --conflicts       Scan for conflicts, implies -n
 526   -d DIR, --dir=DIR     Set stow dir to DIR (default is current dir)
 527   -t DIR, --target=DIR  Set target to DIR (default is parent of stow dir)
 528   -v, --verbose[=N]     Increase verboseness (levels are 0,1,2,3;
 529                           -v or --verbose adds 1; --verbose=N sets level)
 530   -D, --delete          Unstow instead of stow
 531   -R, --restow          Restow (like stow -D followed by stow)
 532   -V, --version         Show Stow version number
 533   -h, --help            Show this help
 534 EOT
 535   exit($msg ? 1 : 0);
 536 }
 537
 538 sub version {
 539   print "$ProgramName (GNU Stow) version $Version\n";
 540   exit(0);
 541 }
 542
 543 # Local variables:
 544 # mode: perl
 545 # End: