stow/stow.in

#!@PERL@

# GNU Stow - manage the installation of multiple software packages
# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
# Copyright (C) 2000,2001 Guillaume Morin
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
# 
# $Id$
# $Source$
# $Date$
# $Author$

# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# Wed Nov 23 2005 Adam Spiers
# This version is hacked to ignore anything listed in ~/.cvsignore
use File::Spec;
use FindBin qw($RealBin);
use Getopt::Long;

use lib "$RealBin/../lib/perl5";
use Sh 'glob_to_re';
my $ignore_file = File::Spec->join($ENV{HOME}, ".cvsignore");
my $ignore_re = get_ignore_re_from_file($ignore_file);
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

require 5.005;
use POSIX;

$ProgramName = $0;
$ProgramName =~ s,.*/,,;

$Version = '@VERSION@';

$Conflicts = 0;
$Delete = 0;
$NotReally = 0;
$Verbose = 0;
$ReportHelp = 0;
$Stow = undef;
$Target = undef;
$Restow = 0;


# FIXME: use Getopt::Long
while (@ARGV && ($_ = $ARGV[0]) && /^-/) {
  $opt = $';
  shift;
  last if /^--$/;

  if ($opt =~ /^-/) {
    $opt = $';
    if ($opt =~ /^no?$/i) {
      $NotReally = 1;
    } elsif ($opt =~ /^c(o(n(f(l(i(c(ts?)?)?)?)?)?)?)?$/i) {
      $Conflicts = 1;
      $NotReally = 1;
    } elsif ($opt =~ /^dir?/i) {
      $remainder = $';
      if ($remainder =~ /^=/) {
	$Stow = $';		# the stuff after the =
      } else {
	$Stow = shift;
      }
    } elsif ($opt =~ /^t(a(r(g(et?)?)?)?)?/i) {
      $remainder = $';
      if ($remainder =~ /^=/) {
	$Target = $';		# the stuff after the =
      } else {
	$Target = shift;
      }
    } elsif ($opt =~ /^verb(o(se?)?)?/i) {
      $remainder = $';
      if ($remainder =~ /^=(\d+)/) {
	$Verbose = $1;
      } else {
	++$Verbose;
      }
    } elsif ($opt =~ /^de(l(e(te?)?)?)?$/i) {
      $Delete = 1;
    } elsif ($opt =~ /^r(e(s(t(o(w?)?)?)?)?)?$/i) {
      $Restow = 1;
    } elsif ($opt =~ /^vers(i(on?)?)?$/i) {
      &version();
    } else {
      &usage(($opt =~ /^h(e(lp?)?)?$/) ? undef :
	     "unknown or ambiguous option: $opt");
    }
  } else {
    @opts = split(//, $opt);
    while ($_ = shift(@opts)) {
      if ($_ eq 'n') {
	$NotReally = 1;
      } elsif ($_ eq 'c') {
	$Conflicts = 1;
	$NotReally = 1;
      } elsif ($_ eq 'd') {
	$Stow = (join('', @opts) || shift);
	@opts = ();
      } elsif ($_ eq 't') {
	$Target = (join('', @opts) || shift);
	@opts = ();
      } elsif ($_ eq 'v') {
	++$Verbose;
      } elsif ($_ eq 'D') {
	$Delete = 1;
      } elsif ($_ eq 'R') {
	$Restow = 1;
      } elsif ($_ eq 'V') {
	&version();
      } else {
	&usage(($_ eq 'h') ? undef : "unknown option: $_");
      }
    }
  }
}

&usage("No packages named") unless @ARGV;

# Changing dirs helps a lot when soft links are used
$current_dir = &getcwd;
if ($Stow) {
  chdir($Stow) || die "Cannot chdir to target tree $Stow ($!)\n";
}

# This prevents problems if $Target was supplied as a relative path
$Stow = &getcwd;

chdir($current_dir) || die "Your directory does not seem to exist anymore ($!)\n";

$Target = &parent($Stow) unless $Target;

chdir($Target) || die "Cannot chdir to target tree $Target ($!)\n";
$Target = &getcwd;

foreach $package (@ARGV) {
  $package =~ s,/+$,,;		# delete trailing slashes
  if ($package =~ m,/,) {
    die "$ProgramName: slashes not permitted in package names\n";
  }
}

if ($Delete || $Restow) {
  @Collections = @ARGV;
  &Unstow('', &RelativePath($Target, $Stow));
}

if (!$Delete || $Restow) {
  foreach $Collection (@ARGV) {
    warn "Stowing package $Collection...\n" if $Verbose;
    &StowContents($Collection, &RelativePath($Target, $Stow));
  }
}

sub CommonParent {
  local($dir1, $dir2) = @_;
  local($result, $x);
  local(@d1) = split(/\/+/, $dir1);
  local(@d2) = split(/\/+/, $dir2);

  while (@d1 && @d2 && (($x = shift(@d1)) eq shift(@d2))) {
    $result .= "$x/";
  }
  chop($result);
  $result;
}

# Find the relative patch between
# two paths given as arguments.

sub RelativePath {
  local($a, $b) = @_;
  local($c) = &CommonParent($a, $b);
  local(@a) = split(/\/+/, $a);
  local(@b) = split(/\/+/, $b);
  local(@c) = split(/\/+/, $c);

  # if $c == "/something", scalar(@c) >= 2
  # but if $c == "/", scalar(@c) == 0
  # but we want 1
  my $length = scalar(@c) ? scalar(@c) : 1;
  splice(@a, 0, $length);
  splice(@b, 0, $length);

  unshift(@b, (('..') x (@a + 0)));
  &JoinPaths(@b);
}

# Basically concatenates the paths given
# as arguments

sub JoinPaths {
  local(@paths, @parts);
  local ($x, $y);
  local($result) = '';

  $result = '/' if ($_[0] =~ /^\//);
  foreach $x (@_) {
    @parts = split(/\/+/, $x);
    foreach $y (@parts) {
      push(@paths, $y) if ($y ne "");
    }
  }
  $result .= join('/', @paths);
}

sub Unstow {
  local($targetdir, $stow) = @_;
  local(@contents);
  local($content);
  local($linktarget, $stowmember, $collection);
  local(@stowmember);
  local($pure, $othercollection) = (1, '');
  local($subpure, $subother);
  local($empty) = (1);
  local(@puresubdirs);

  return (0, '') if (&JoinPaths($Target, $targetdir) eq $Stow);
  return (0, '') if (-e &JoinPaths($Target, $targetdir, '.stow'));
  warn sprintf("Unstowing in %s\n", &JoinPaths($Target, $targetdir))
    if ($Verbose > 1);
  if (!opendir(DIR, &JoinPaths($Target, $targetdir))) {
    warn "Warning: $ProgramName: Cannot read directory \"$dir\" ($!). Stow might leave some links. If you think, it does. Rerun Stow with appropriate rights.\n";
  }	
  @contents = readdir(DIR);
  closedir(DIR);
  foreach $content (@contents) {
    next if (($content eq '.') || ($content eq '..'));
    $empty = 0;
    if (-l &JoinPaths($Target, $targetdir, $content)) {
      ($linktarget = readlink(&JoinPaths($Target,
					 $targetdir,
					 $content)))
	|| die sprintf("%s: Cannot read link %s (%s)\n",
		       $ProgramName,
		       &JoinPaths($Target, $targetdir, $content),
		       $!);
      if ($stowmember = &FindStowMember(&JoinPaths($Target,
						   $targetdir),
					$linktarget)) {
	@stowmember = split(/\/+/, $stowmember);
	$collection = shift(@stowmember);
	if (grep(($collection eq $_), @Collections)) {
	  &DoUnlink(&JoinPaths($Target, $targetdir, $content));
	} elsif ($pure) {
	  if ($othercollection) {
	    $pure = 0 if ($collection ne $othercollection);
	  } else {
	    $othercollection = $collection;
	  }
	}
      } else {
	$pure = 0;
      }
    } elsif (-d &JoinPaths($Target, $targetdir, $content)) {
      ($subpure, $subother) = &Unstow(&JoinPaths($targetdir, $content),
				      &JoinPaths('..', $stow));
      if ($subpure) {
	push(@puresubdirs, "$content/$subother");
      }
      if ($pure) {
	if ($subpure) {
	  if ($othercollection) {
	    if ($subother) {
	      if ($othercollection ne $subother) {
		$pure = 0;
	      }
	    }
	  } elsif ($subother) {
	    $othercollection = $subother;
	  }
	} else {
	  $pure = 0;
	}
      }
    } else {
      $pure = 0;
    }
  }
  # This directory was an initially empty directory therefore
  # We do not remove it.
  $pure = 0 if $empty;
  if ((!$pure || !$targetdir) && @puresubdirs) {
    &CoalesceTrees($targetdir, $stow, @puresubdirs);
  }
  ($pure, $othercollection);
}

sub CoalesceTrees {
  local($parent, $stow, @trees) = @_;
  local($tree, $collection, $x);

  foreach $x (@trees) {
    ($tree, $collection) = ($x =~ /^(.*)\/(.*)/);
    &EmptyTree(&JoinPaths($Target, $parent, $tree));
    &DoRmdir(&JoinPaths($Target, $parent, $tree));
    if ($collection) {
      &DoLink(&JoinPaths($stow, $collection, $parent, $tree),
	      &JoinPaths($Target, $parent, $tree));
    }
  }
}

sub EmptyTree {
  local($dir) = @_;
  local(@contents);
  local($content);

  opendir(DIR, $dir)
    || die "$ProgramName: Cannot read directory \"$dir\" ($!)\n";
  @contents = readdir(DIR);
  closedir(DIR);
  foreach $content (@contents) {
    next if (($content eq '.') || ($content eq '..'));
    if (-l &JoinPaths($dir, $content)) {
      &DoUnlink(&JoinPaths($dir, $content));
    } elsif (-d &JoinPaths($dir, $content)) {
      &EmptyTree(&JoinPaths($dir, $content));
      &DoRmdir(&JoinPaths($dir, $content));
    } else {
      &DoUnlink(&JoinPaths($dir, $content));
    }
  }
}

sub StowContents {
  local($dir, $stow) = @_;
  local(@contents);
  local($content);

  warn "Stowing contents of $dir\n" if ($Verbose > 1);
  my $joined = &JoinPaths($Stow, $dir);
  opendir(DIR, $joined)
    || die "$ProgramName: Cannot read directory \"$dir\" ($!)\n";
  @contents = readdir(DIR);
  closedir(DIR);
  foreach $content (@contents) {
    # Wed Nov 23 2005 Adam Spiers
    # hack to ignore stuff in ~/.cvsignore
    next if $content eq '.' or $content eq '..';
    if ($content =~ $ignore_re) {
      warn "Ignoring $joined/$content via $ignore_file\n"
        if $Verbose > 2;
      next;
    }
    if (-d &JoinPaths($Stow, $dir, $content)) {
      &StowDir(&JoinPaths($dir, $content), $stow);
    } else {
      &StowNondir(&JoinPaths($dir, $content), $stow);
    }
  }
}

sub StowDir {
  local($dir, $stow) = @_;
  local(@dir) = split(/\/+/, $dir);
  local($collection) = shift(@dir);
  local($subdir) = join('/', @dir);
  local($linktarget, $stowsubdir);

  warn "Stowing directory $dir\n" if ($Verbose > 1);
  if (-l &JoinPaths($Target, $subdir)) {
    ($linktarget = readlink(&JoinPaths($Target, $subdir)))
      || die sprintf("%s: Could not read link %s (%s)\n",
		     $ProgramName,
		     &JoinPaths($Target, $subdir),
		     $!);
    ($stowsubdir =
     &FindStowMember(sprintf('%s/%s', $Target,
			     join('/', @dir[0..($#dir - 1)])),
		     $linktarget))
      || (&Conflict($dir, $subdir, 1), return);
    if (-e &JoinPaths($Stow, $stowsubdir)) {
      if ($stowsubdir eq $dir) {
	warn sprintf("%s already points to %s\n",
		     &JoinPaths($Target, $subdir),
		     &JoinPaths($Stow, $dir))
	  if ($Verbose > 2);
	return;
      }
      if (-d &JoinPaths($Stow, $stowsubdir)) {
	&DoUnlink(&JoinPaths($Target, $subdir));
	&DoMkdir(&JoinPaths($Target, $subdir));
	&StowContents($stowsubdir, &JoinPaths('..', $stow));
	&StowContents($dir, &JoinPaths('..', $stow));
      } else {
	(&Conflict($dir, $subdir, 2), return);
      }
    } else {
      &DoUnlink(&JoinPaths($Target, $subdir));
      &DoLink(&JoinPaths($stow, $dir),
	      &JoinPaths($Target, $subdir));
    }
  } elsif (-e &JoinPaths($Target, $subdir)) {
    if (-d &JoinPaths($Target, $subdir)) {
      &StowContents($dir, &JoinPaths('..', $stow));
    } else {
      &Conflict($dir, $subdir, 3);
    }
  } else {
    &DoLink(&JoinPaths($stow, $dir),
	    &JoinPaths($Target, $subdir));
  }
}

sub StowNondir {
  local($file, $stow) = @_;
  local(@file) = split(/\/+/, $file);
  local($collection) = shift(@file);
  local($subfile) = join('/', @file);
  local($linktarget, $stowsubfile);

  if (-l &JoinPaths($Target, $subfile)) {
    ($linktarget = readlink(&JoinPaths($Target, $subfile)))
      || die sprintf("%s: Could not read link %s (%s)\n",
		     $ProgramName,
		     &JoinPaths($Target, $subfile),
		     $!);
    ($stowsubfile =
     &FindStowMember(sprintf('%s/%s', $Target,
			     join('/', @file[0..($#file - 1)])),
		     $linktarget))
      || (&Conflict($file, $subfile, 4), return);
    if (-e &JoinPaths($Stow, $stowsubfile)) {
      (&Conflict($file, $subfile, 5), return)
	unless ($stowsubfile eq $file);
      warn sprintf("%s already points to %s\n",
		   &JoinPaths($Target, $subfile),
		   &JoinPaths($Stow, $file))
	if ($Verbose > 2);
    } else {
      &DoUnlink(&JoinPaths($Target, $subfile));
      &DoLink(&JoinPaths($stow, $file),
	      &JoinPaths($Target, $subfile));
    }
  } elsif (-e &JoinPaths($Target, $subfile)) {
    &Conflict($file, $subfile, 6);
  } else {
    &DoLink(&JoinPaths($stow, $file),
	    &JoinPaths($Target, $subfile));
  }
}

sub DoUnlink {
  local($file) = @_;

  warn "UNLINK $file\n" if $Verbose;
  (unlink($file) || die "$ProgramName: Could not unlink $file ($!)\n")
    unless $NotReally;
}

sub DoRmdir {
  local($dir) = @_;

  warn "RMDIR $dir\n" if $Verbose;
  (rmdir($dir) || die "$ProgramName: Could not rmdir $dir ($!)\n")
    unless $NotReally;
}

sub DoLink {
  local($target, $name) = @_;

  warn "LINK $name to $target\n" if $Verbose;
  (symlink($target, $name) ||
   die "$ProgramName: Could not symlink $name to $target ($!)\n")
    unless $NotReally;
}

sub DoMkdir {
  local($dir) = @_;

  warn "MKDIR $dir\n" if $Verbose;
  (mkdir($dir, 0777)
   || die "$ProgramName: Could not make directory $dir ($!)\n")
    unless $NotReally;
}

sub Conflict {
  local($a, $b, $type) = @_;

  my $src = &JoinPaths($Stow, $a);
  my $dst = &JoinPaths($Target, $b);

  if ($Conflicts) {
    warn "CONFLICT: $src vs. $dst", ($type ? " ($type)" : ''), "\n";
    #system "ls -l $src $dst";
  } else {
    die "$ProgramName: CONFLICT: $src vs. $dst", ($type ? " ($type)" : ''), "\n";
  }
}

sub FindStowMember {
  local($start, $path) = @_;
  local(@x) = split(/\/+/, $start);
  local(@path) = split(/\/+/, $path);
  local($x);
  local(@d) = split(/\/+/, $Stow);

  while (@path) {
    $x = shift(@path);
    if ($x eq '..') {
      pop(@x);
      return '' unless @x;
    } elsif ($x) {
      push(@x, $x);
    }
  }
  while (@x && @d) {
    if (($x = shift(@x)) ne shift(@d)) {
      return '';
    }
  }
  return '' if @d;
  join('/', @x);
}

sub parent {
  local($path) = join('/', @_);
  local(@elts) = split(/\/+/, $path);
  pop(@elts);
  join('/', @elts);
}

sub usage {
  local($msg) = shift;

  if ($msg) {
    print "$ProgramName: $msg\n";
  }
  print "$ProgramName (GNU Stow) version $Version\n\n";
  print "Usage: $ProgramName [OPTION ...] PACKAGE ...\n";
  print <<EOT;
  -n, --no              Do not actually make changes
  -c, --conflicts       Scan for conflicts, implies -n
  -d DIR, --dir=DIR     Set stow dir to DIR (default is current dir)
  -t DIR, --target=DIR  Set target to DIR (default is parent of stow dir)
  -v, --verbose[=N]     Increase verboseness (levels are 0,1,2,3;
                          -v or --verbose adds 1; --verbose=N sets level)
  -D, --delete          Unstow instead of stow
  -R, --restow          Restow (like stow -D followed by stow)
  -V, --version         Show Stow version number
  -h, --help            Show this help
EOT
  exit($msg ? 1 : 0);
}

sub version {
  print "$ProgramName (GNU Stow) version $Version\n";
  exit(0);
}

sub get_ignore_re_from_file {
  my ($file) = @_;
  my @regexps;
  # Bootstrap issue - first time we stow, we will be stowing
  # .cvsignore so it won't exist in ~ yet.  At that time, use
  # a sensible default instead.
  open(REGEXPS, $file) or return qr!^(CVS)$!;
  while (<REGEXPS>) {
    chomp;
    push @regexps, glob_to_re($_);
  }
  close(REGEXPS);
  my $re = join '|', @regexps;
  return qr/$re/;
}

# Local variables:
# mode: perl
# End: