#!@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 <