diff --git a/Stow.pm b/Stow.pm new file mode 100755 index 0000000..b3d97e1 --- /dev/null +++ b/Stow.pm @@ -0,0 +1,464 @@ +#!/usr/bin/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 +# Copyright (C) 2005 Adam Spiers +# +# 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 +# Hacked to ignore anything listed in ~/.cvsignore +# +# Thu Dec 29 2005 Adam Spiers +# Hacked into a Perl module +##################################################################### + +use strict; +use warnings; + +use File::Spec; +use FindBin qw($RealBin $RealScript); +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; + +our %opts; + +sub SetOptions { + %opts = @_; +} + +sub Init { + # Changing dirs helps a lot when soft links are used + my $current_dir = &getcwd; + if ($opts{stow}) { + chdir($opts{stow}) || die "Cannot chdir to target tree $opts{stow} ($!)\n"; + } + + # This prevents problems if $opts{target} was supplied as a relative path + $opts{stow} = &getcwd; + + chdir($current_dir) || die "Your directory does not seem to exist anymore ($!)\n"; + + $opts{target} = Stow::parent($opts{stow}) unless $opts{target}; + + chdir($opts{target}) || die "Cannot chdir to target tree $opts{target} ($!)\n"; + $opts{target} = &getcwd; +} + +sub CheckCollections { + foreach my $package (@_) { + $package =~ s,/+$,,; # delete trailing slashes + if ($package =~ m,/,) { + die "$RealScript: slashes not permitted in package names\n"; + } + } +} + +sub CommonParent { + my($dir1, $dir2) = @_; + my($result, $x); + my(@d1) = split(/\/+/, $dir1); + my(@d2) = split(/\/+/, $dir2); + + while (@d1 && @d2 && (($x = shift(@d1)) eq shift(@d2))) { + $result .= "$x/"; + } + chop($result); + return $result; +} + +# Find the relative patch between +# two paths given as arguments. + +sub RelativePath { + my($a, $b) = @_; + my($c) = &CommonParent($a, $b); + my(@a) = split(/\/+/, $a); + my(@b) = split(/\/+/, $b); + my(@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 { + my(@paths, @parts); + my ($x, $y); + my($result) = ''; + + $result = '/' if ($_[0] =~ /^\//); + foreach $x (@_) { + @parts = split(/\/+/, $x); + foreach $y (@parts) { + push(@paths, $y) if ($y ne ""); + } + } + $result .= join('/', @paths); + return $result; +} + +sub Unstow { + my($targetdir, $stow, $Collections) = @_; + my($pure, $othercollection) = (1, ''); + my($subpure, $subother); + my($empty) = (1); + my(@puresubdirs); + + return (0, '') if (&JoinPaths($opts{target}, $targetdir) eq $opts{stow}); + return (0, '') if (-e &JoinPaths($opts{target}, $targetdir, '.stow')); + warn sprintf("Unstowing in %s\n", &JoinPaths($opts{target}, $targetdir)) + if ($opts{verbose} > 1); + my $dir = &JoinPaths($opts{target}, $targetdir); + if (!opendir(DIR, $dir)) { + warn "Warning: $RealScript: Cannot read directory \"$dir\" ($!). Stow might leave some links. If you think, it does. Rerun Stow with appropriate rights.\n"; + } + my @contents = readdir(DIR); + closedir(DIR); + foreach my $content (@contents) { + next if (($content eq '.') || ($content eq '..')); + $empty = 0; + if (-l &JoinPaths($opts{target}, $targetdir, $content)) { + (my $linktarget = readlink(&JoinPaths($opts{target}, + $targetdir, + $content))) + || die sprintf("%s: Cannot read link %s (%s)\n", + $RealScript, + &JoinPaths($opts{target}, $targetdir, $content), + $!); + if (my $stowmember = &FindStowMember(&JoinPaths($opts{target}, + $targetdir), + $linktarget)) { + my @stowmember = split(/\/+/, $stowmember); + my $collection = shift(@stowmember); + if (grep(($collection eq $_), @$Collections)) { + &DoUnlink(&JoinPaths($opts{target}, $targetdir, $content)); + } elsif ($pure) { + if ($othercollection) { + $pure = 0 if ($collection ne $othercollection); + } else { + $othercollection = $collection; + } + } + } else { + $pure = 0; + } + } elsif (-d &JoinPaths($opts{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 { + my($parent, $stow, @trees) = @_; + + foreach my $x (@trees) { + my ($tree, $collection) = ($x =~ /^(.*)\/(.*)/); + &EmptyTree(&JoinPaths($opts{target}, $parent, $tree)); + &DoRmdir(&JoinPaths($opts{target}, $parent, $tree)); + if ($collection) { + &DoLink(&JoinPaths($stow, $collection, $parent, $tree), + &JoinPaths($opts{target}, $parent, $tree)); + } + } +} + +sub EmptyTree { + my($dir) = @_; + + opendir(DIR, $dir) + || die "$RealScript: Cannot read directory \"$dir\" ($!)\n"; + my @contents = readdir(DIR); + closedir(DIR); + foreach my $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 { + my($dir, $stow) = @_; + + warn "Stowing contents of $dir\n" if ($opts{verbose} > 1); + my $joined = &JoinPaths($opts{stow}, $dir); + opendir(DIR, $joined) + || die "$RealScript: Cannot read directory \"$dir\" ($!)\n"; + my @contents = readdir(DIR); + closedir(DIR); + foreach my $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) { + # FIXME: We assume -r implies the open succeeded but this is not + # true if we're stowing cvs as .cvsignore only gets created + # halfway through. + warn "Ignoring $joined/$content", (-r $ignore_file ? " via $ignore_file" : ""), "\n" + if $opts{verbose} > 2; + next; + } + if (-d &JoinPaths($opts{stow}, $dir, $content)) { + &StowDir(&JoinPaths($dir, $content), $stow); + } else { + &StowNondir(&JoinPaths($dir, $content), $stow); + } + } +} + +sub StowDir { + my($dir, $stow) = @_; + my(@dir) = split(/\/+/, $dir); + my($collection) = shift(@dir); + my($subdir) = join('/', @dir); + my($linktarget, $stowsubdir); + + warn "Stowing directory $dir\n" if ($opts{verbose} > 1); + if (-l &JoinPaths($opts{target}, $subdir)) { + ($linktarget = readlink(&JoinPaths($opts{target}, $subdir))) + || die sprintf("%s: Could not read link %s (%s)\n", + $RealScript, + &JoinPaths($opts{target}, $subdir), + $!); + ($stowsubdir = + &FindStowMember(sprintf('%s/%s', $opts{target}, + join('/', @dir[0..($#dir - 1)])), + $linktarget)) + || (&Conflict($dir, $subdir, 1), return); + if (-e &JoinPaths($opts{stow}, $stowsubdir)) { + if ($stowsubdir eq $dir) { + warn sprintf("%s already points to %s\n", + &JoinPaths($opts{target}, $subdir), + &JoinPaths($opts{stow}, $dir)) + if ($opts{verbose} > 2); + return; + } + if (-d &JoinPaths($opts{stow}, $stowsubdir)) { + &DoUnlink(&JoinPaths($opts{target}, $subdir)); + &DoMkdir(&JoinPaths($opts{target}, $subdir)); + &StowContents($stowsubdir, &JoinPaths('..', $stow)); + &StowContents($dir, &JoinPaths('..', $stow)); + } else { + (&Conflict($dir, $subdir, 2), return); + } + } else { + &DoUnlink(&JoinPaths($opts{target}, $subdir)); + &DoLink(&JoinPaths($stow, $dir), + &JoinPaths($opts{target}, $subdir)); + } + } elsif (-e &JoinPaths($opts{target}, $subdir)) { + if (-d &JoinPaths($opts{target}, $subdir)) { + &StowContents($dir, &JoinPaths('..', $stow)); + } else { + &Conflict($dir, $subdir, 3); + } + } else { + &DoLink(&JoinPaths($stow, $dir), + &JoinPaths($opts{target}, $subdir)); + } +} + +sub StowNondir { + my($file, $stow) = @_; + my(@file) = split(/\/+/, $file); + my($collection) = shift(@file); + my($subfile) = join('/', @file); + my($linktarget, $stowsubfile); + + if (-l &JoinPaths($opts{target}, $subfile)) { + ($linktarget = readlink(&JoinPaths($opts{target}, $subfile))) + || die sprintf("%s: Could not read link %s (%s)\n", + $RealScript, + &JoinPaths($opts{target}, $subfile), + $!); + ($stowsubfile = + &FindStowMember(sprintf('%s/%s', $opts{target}, + join('/', @file[0..($#file - 1)])), + $linktarget)) + || (&Conflict($file, $subfile, 4), return); + if (-e &JoinPaths($opts{stow}, $stowsubfile)) { + (&Conflict($file, $subfile, 5), return) + unless ($stowsubfile eq $file); + warn sprintf("%s already points to %s\n", + &JoinPaths($opts{target}, $subfile), + &JoinPaths($opts{stow}, $file)) + if ($opts{verbose} > 2); + } else { + &DoUnlink(&JoinPaths($opts{target}, $subfile)); + &DoLink(&JoinPaths($stow, $file), + &JoinPaths($opts{target}, $subfile)); + } + } elsif (-e &JoinPaths($opts{target}, $subfile)) { + &Conflict($file, $subfile, 6); + } else { + &DoLink(&JoinPaths($stow, $file), + &JoinPaths($opts{target}, $subfile)); + } +} + +sub DoUnlink { + my($file) = @_; + + warn "UNLINK $file\n" if $opts{verbose}; + (unlink($file) || die "$RealScript: Could not unlink $file ($!)\n") + unless $opts{not_really}; +} + +sub DoRmdir { + my($dir) = @_; + + warn "RMDIR $dir\n" if $opts{verbose}; + (rmdir($dir) || die "$RealScript: Could not rmdir $dir ($!)\n") + unless $opts{not_really}; +} + +sub DoLink { + my($target, $name) = @_; + + warn "LINK $name to $target\n" if $opts{verbose}; + (symlink($target, $name) || + die "$RealScript: Could not symlink $name to $target ($!)\n") + unless $opts{not_really}; +} + +sub DoMkdir { + my($dir) = @_; + + warn "MKDIR $dir\n" if $opts{verbose}; + (mkdir($dir, 0777) + || die "$RealScript: Could not make directory $dir ($!)\n") + unless $opts{not_really}; +} + +sub Conflict { + my($a, $b, $type) = @_; + + my $src = &JoinPaths($opts{stow}, $a); + my $dst = &JoinPaths($opts{target}, $b); + + if ($opts{conflicts}) { + warn "CONFLICT: $src vs. $dst", ($type ? " ($type)" : ''), "\n"; + #system "ls -l $src $dst"; + } else { + die "$RealScript: CONFLICT: $src vs. $dst", ($type ? " ($type)" : ''), "\n"; + } +} + +sub FindStowMember { + my($start, $path) = @_; + my(@x) = split(/\/+/, $start); + my(@path) = split(/\/+/, $path); + my($x); + my(@d) = split(/\/+/, $opts{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; + return join('/', @x); +} + +sub parent { + my($path) = join('/', @_); + my(@elts) = split(/\/+/, $path); + pop(@elts); + return join('/', @elts); +} + +sub get_ignore_re_from_file { + my ($file) = @_; + # 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!\.cfgsave\.|^(CVS)$!; + my @regexps; + while () { + chomp; + push @regexps, glob_to_re($_); + } + close(REGEXPS); + my $re = join '|', @regexps; + warn "#% ignore regexp is $re\n" if $opts{verbose}; + return qr/$re/; +} + +1;