*** empty log message ***
This commit is contained in:
adam
Adam Spiers
parent
65196fb9a3
commit
17b23979dd
464
Stow.pm
Executable file
464
Stow.pm
Executable file
|
|
@ -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 <stow@adamspiers.org>
|
||||
# Hacked to ignore anything listed in ~/.cvsignore
|
||||
#
|
||||
# Thu Dec 29 2005 Adam Spiers <stow@adamspiers.org>
|
||||
# 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 (<REGEXPS>) {
|
||||
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;
|
||||
Loading…
Reference in a new issue