509 lines
14 KiB
Text
509 lines
14 KiB
Text
#!@PERL@
|
|
|
|
# GNU Stow - manage the installation of multiple software packages
|
|
# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
|
|
# Copyright (C) 2000,2001, 2002 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$
|
|
|
|
require 5.005;
|
|
use POSIX;
|
|
|
|
$ProgramName = $0;
|
|
$ProgramName =~ s,.*/,,;
|
|
|
|
$Version = '@VERSION@';
|
|
|
|
$Conflicts = 0;
|
|
$Delete = 0;
|
|
$NotReally = 0;
|
|
$Verbose = 0;
|
|
$ReportHelp = 0;
|
|
$Stow = defined $ENV{'STOW_DIR'} ? $ENV{'STOW_DIR'} : undef;
|
|
$Target = undef;
|
|
$Restow = 0;
|
|
$Force = 0;
|
|
@Subdirs = ();
|
|
|
|
use Getopt::Long;
|
|
Getopt::Long::Configure ("gnu_getopt");
|
|
|
|
GetOptions(
|
|
'n|no' => \$NotReally,
|
|
'c|conflicts' => sub { $Conflicts = 1; $NotReally = 1; },
|
|
'i|ignore' => \$Conflicts,
|
|
'f|force' => sub { $Force = 1; $Conflicts = 1; },
|
|
'd|dir=s' => \$Stow,
|
|
't|target=s' => \$Target,
|
|
's|subdirs=s' => sub { my($arg, $val) = @_; @Subdirs = split( /:/, $val ); },
|
|
'v|verbose:i' => sub { my($arg, $val) = @_; $Verbose = $val ? $val : $Verbose + 1; },
|
|
'D|delete' => \$Delete,
|
|
'R|restow' => \$Restow,
|
|
'V|version' => sub { my($arg, $val) = @_; &version() if ( $val ); },
|
|
'h|help' => sub { my($arg, $val) = @_; &usage(undef) if ($val); },
|
|
) or usage(undef);
|
|
|
|
&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), @Subdirs);
|
|
}
|
|
}
|
|
|
|
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, @subdirs) = @_;
|
|
local(@contents);
|
|
local($content);
|
|
|
|
local $text_subdirs = scalar(@subdirs) ? "/{".join(',',@subdirs)."} " : " ";
|
|
|
|
warn "Stowing contents of $dir in $stow".$text_subdirs."\n" if ($Verbose > 1);
|
|
opendir(DIR, &JoinPaths($Stow, $dir))
|
|
|| die "$ProgramName: Cannot read directory \"$dir\" ($!)\n";
|
|
@contents = readdir(DIR);
|
|
closedir(DIR);
|
|
foreach $content (@contents) {
|
|
next if (($content eq '.') || ($content eq '..'));
|
|
|
|
if (scalar(@subdirs)) {
|
|
warn "Checking $content against (".join(",",@subdirs).")\n" if ($Verbose > 2);
|
|
next if (!grep($_ eq $content, @subdirs));
|
|
}
|
|
|
|
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), 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), 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);
|
|
}
|
|
} 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), return);
|
|
if (-e &JoinPaths($Stow, $stowsubfile)) {
|
|
if ($stowsubfile eq $file) {
|
|
warn sprintf("%s already points to %s\n",
|
|
&JoinPaths($Target, $subfile),
|
|
&JoinPaths($Stow, $file))
|
|
if ($Verbose > 2);
|
|
return;
|
|
} else {
|
|
&Conflict($file, $subfile);
|
|
return unless $Force;
|
|
warn "OVERRIDING link to ". &JoinPaths($Stow, $stowsubfile) . "\n"
|
|
if $Verbose;
|
|
}
|
|
}
|
|
&DoUnlink(&JoinPaths($Target, $subfile));
|
|
} elsif (-e &JoinPaths($Target, $subfile)) {
|
|
&Conflict($file, $subfile);
|
|
return;
|
|
}
|
|
|
|
&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) = @_;
|
|
|
|
if ($Conflicts) {
|
|
warn sprintf("CONFLICT: %s vs. %s\n", &JoinPaths($Stow, $a),
|
|
&JoinPaths($Target, $b));
|
|
} else {
|
|
die sprintf("%s: CONFLICT: %s vs. %s\n",
|
|
$ProgramName,
|
|
&JoinPaths($Stow, $a),
|
|
&JoinPaths($Target, $b));
|
|
}
|
|
}
|
|
|
|
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 '..') {
|
|
# ignore if /, since /.. is /
|
|
pop(@x) if scalar(@x) > 1;
|
|
} elsif ($x ne '.') {
|
|
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);
|
|
# if @_ = ('/foo')
|
|
# join('/',@elts) would be ''
|
|
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
|
|
-i, --ignore Ignore conflicts.
|
|
-f, --force Try to override conflicts.
|
|
-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)
|
|
-s DIR:DIR,
|
|
--subdirs=DIR:DIR Set subdirs to recurse to DIR:DIR (default is all subdirs)
|
|
-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);
|
|
}
|
|
|
|
# Local variables:
|
|
# mode: perl
|
|
# End:
|