move into Stow.pm
This commit is contained in:
adam
Adam Spiers
parent
17b23979dd
commit
d21d1dd629
1 changed files with 51 additions and 521 deletions
572
stow.in
572
stow.in
|
|
@ -3,6 +3,7 @@
|
||||||
# GNU Stow - manage the installation of multiple software packages
|
# GNU Stow - manage the installation of multiple software packages
|
||||||
# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
|
# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
|
||||||
# Copyright (C) 2000,2001 Guillaume Morin
|
# Copyright (C) 2000,2001 Guillaume Morin
|
||||||
|
# Copyright (C) 2005 Adam Spiers
|
||||||
#
|
#
|
||||||
# This program is free software; you can redistribute it and/or modify
|
# 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
|
# it under the terms of the GNU General Public License as published by
|
||||||
|
|
@ -23,528 +24,77 @@
|
||||||
# $Date$
|
# $Date$
|
||||||
# $Author$
|
# $Author$
|
||||||
|
|
||||||
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
#####################################################################
|
||||||
# Wed Nov 23 2005 Adam Spiers
|
# Thu Dec 29 2005 Adam Spiers <stow@adamspiers.org>
|
||||||
# This version is hacked to ignore anything listed in ~/.cvsignore
|
# Hacked into a Perl module
|
||||||
|
#####################################################################
|
||||||
|
|
||||||
|
my $Version = '1.4.0';
|
||||||
|
require 5.005;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
use File::Spec;
|
use File::Spec;
|
||||||
use FindBin qw($RealBin);
|
use FindBin qw($RealBin $RealScript);
|
||||||
use Getopt::Long;
|
use Getopt::Long;
|
||||||
|
use POSIX;
|
||||||
|
|
||||||
use lib "$RealBin/../lib/perl5";
|
use lib "$RealBin/../lib/perl5";
|
||||||
use Sh 'glob_to_re';
|
use Sh 'glob_to_re';
|
||||||
|
use Stow;
|
||||||
|
|
||||||
my $ignore_file = File::Spec->join($ENV{HOME}, ".cvsignore");
|
my $ignore_file = File::Spec->join($ENV{HOME}, ".cvsignore");
|
||||||
my $ignore_re = get_ignore_re_from_file($ignore_file);
|
my $ignore_re = get_ignore_re_from_file($ignore_file);
|
||||||
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
require 5.005;
|
my %opts = (
|
||||||
use POSIX;
|
conflicts => 0,
|
||||||
|
delete => 0,
|
||||||
|
not_really => 0,
|
||||||
|
verbose => 0,
|
||||||
|
stow => undef,
|
||||||
|
target => undef,
|
||||||
|
restow => 0,
|
||||||
|
);
|
||||||
|
|
||||||
$ProgramName = $0;
|
GetOptions(
|
||||||
$ProgramName =~ s,.*/,,;
|
\%opts,
|
||||||
|
'conflicts|c', 'not_really|n', 'stow|dir|d=s', 'target|t=s',
|
||||||
|
'verbose|v:+', 'delete|D', 'version|V', 'help|h',
|
||||||
|
)
|
||||||
|
or usage();
|
||||||
|
|
||||||
$Version = '@VERSION@';
|
version() if $opts{version};
|
||||||
|
usage() if $opts{help};
|
||||||
|
|
||||||
$Conflicts = 0;
|
usage("No packages named") unless @ARGV;
|
||||||
$Delete = 0;
|
|
||||||
$NotReally = 0;
|
|
||||||
$Verbose = 0;
|
|
||||||
$ReportHelp = 0;
|
|
||||||
$Stow = undef;
|
|
||||||
$Target = undef;
|
|
||||||
$Restow = 0;
|
|
||||||
|
|
||||||
|
Stow::SetOptions(%opts);
|
||||||
|
Stow::Init();
|
||||||
|
|
||||||
# FIXME: use Getopt::Long
|
my @Collections = @ARGV;
|
||||||
while (@ARGV && ($_ = $ARGV[0]) && /^-/) {
|
Stow::CheckCollections(@Collections);
|
||||||
$opt = $';
|
|
||||||
shift;
|
|
||||||
last if /^--$/;
|
|
||||||
|
|
||||||
if ($opt =~ /^-/) {
|
if ($opts{delete} || $opts{restow}) {
|
||||||
$opt = $';
|
Stow::Unstow('', &RelativePath($opts{target}, $opts{stow}), \@Collections);
|
||||||
if ($opt =~ /^no?$/i) {
|
}
|
||||||
$NotReally = 1;
|
|
||||||
} elsif ($opt =~ /^c(o(n(f(l(i(c(ts?)?)?)?)?)?)?)?$/i) {
|
if (!$opts{delete} || $opts{restow}) {
|
||||||
$Conflicts = 1;
|
foreach my $Collection (@ARGV) {
|
||||||
$NotReally = 1;
|
warn "Stowing package $Collection...\n" if $opts{verbose};
|
||||||
} elsif ($opt =~ /^dir?/i) {
|
Stow::StowContents($Collection, &RelativePath($opts{target}, $opts{stow}));
|
||||||
$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);
|
|
||||||
my $dir = &JoinPaths($Target, $targetdir);
|
|
||||||
if (!opendir(DIR, $dir)) {
|
|
||||||
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) {
|
|
||||||
# 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 $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 {
|
sub usage {
|
||||||
local($msg) = shift;
|
my($msg) = shift;
|
||||||
|
|
||||||
if ($msg) {
|
if ($msg) {
|
||||||
print "$ProgramName: $msg\n";
|
print "$RealScript: $msg\n";
|
||||||
}
|
}
|
||||||
print "$ProgramName (GNU Stow) version $Version\n\n";
|
print "$RealScript (GNU Stow) version $Version\n\n";
|
||||||
print "Usage: $ProgramName [OPTION ...] PACKAGE ...\n";
|
print "Usage: $RealScript [OPTION ...] PACKAGE ...\n";
|
||||||
print <<EOT;
|
print <<EOT;
|
||||||
-n, --no Do not actually make changes
|
-n, --no Do not actually make changes
|
||||||
-c, --conflicts Scan for conflicts, implies -n
|
-c, --conflicts Scan for conflicts, implies -n
|
||||||
|
|
@ -561,27 +111,7 @@ EOT
|
||||||
}
|
}
|
||||||
|
|
||||||
sub version {
|
sub version {
|
||||||
print "$ProgramName (GNU Stow) version $Version\n";
|
print "$RealScript (GNU Stow) version $Version\n";
|
||||||
exit(0);
|
exit(0);
|
||||||
}
|
}
|
||||||
|
|
||||||
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 $Verbose;
|
|
||||||
return qr/$re/;
|
|
||||||
}
|
|
||||||
|
|
||||||
# Local variables:
|
|
||||||
# mode: perl
|
|
||||||
# End:
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue