Add --adopt / -a option.
This commit is contained in:
Adam Spiers
parent
5110ea8338
commit
7e44666640
7 changed files with 246 additions and 27 deletions
5
NEWS
5
NEWS
|
|
@ -2,6 +2,11 @@ News file for Stow.
|
|||
|
||||
* Changes in version 2.1.3
|
||||
|
||||
** New --adopt / -a option
|
||||
|
||||
This allows plain files in the target to be "adopted" into the
|
||||
package being stowed. See the manual has more details.
|
||||
|
||||
** ./configure now checks for Perl modules required by the test suite.
|
||||
|
||||
* Changes in version 2.1.2
|
||||
|
|
|
|||
18
bin/stow.in
18
bin/stow.in
|
|
@ -181,6 +181,23 @@ Restow packages (first unstow, then stow again). This is useful
|
|||
for pruning obsolete symlinks from the target tree after updating
|
||||
the software in a package.
|
||||
|
||||
=item -a
|
||||
|
||||
=item --adopt
|
||||
|
||||
B<Warning!> This behaviour is specifically intended to alter the
|
||||
contents of your stow directory. If you do not want that, this option
|
||||
is not for you.
|
||||
|
||||
When stowing, if a target is encountered which already exists but is a
|
||||
plain file (and hence not owned by any existing stow package), then
|
||||
normally Stow will register this as a conflict and refuse to proceed.
|
||||
This option changes that behaviour so that the file is moved to the
|
||||
same relative place within the package's installation image within the
|
||||
stow directory, and then stowing proceeds as before. So effectively,
|
||||
the file becomes adopted by the stow package, without its contents
|
||||
changing.
|
||||
|
||||
=item --ignore=REGEX
|
||||
|
||||
Ignore files ending in this Perl regex.
|
||||
|
|
@ -462,6 +479,7 @@ sub process_options {
|
|||
\%options,
|
||||
'verbose|v:+', 'help|h', 'simulate|n|no',
|
||||
'version|V', 'compat|p', 'dir|d=s', 'target|t=s',
|
||||
'adopt|a',
|
||||
|
||||
# clean and pre-compile any regex's at parse time
|
||||
'ignore=s' =>
|
||||
|
|
|
|||
|
|
@ -340,6 +340,29 @@ pages that are owned by stow and would otherwise cause a conflict.
|
|||
The regular expression is anchored to the beginning of the path relative to
|
||||
the target directory, because this is what you will want to do most of the time.
|
||||
|
||||
@item -a
|
||||
@itemx --adopt
|
||||
@strong{Warning!} This behaviour is specifically intended to alter the
|
||||
contents of your stow directory. If you do not want that, this option
|
||||
is not for you.
|
||||
|
||||
When stowing, if a target is encountered which already exists but is a
|
||||
plain file (and hence not owned by any existing stow package), then
|
||||
normally Stow will register this as a conflict and refuse to proceed.
|
||||
This option changes that behaviour so that the file is moved to the
|
||||
same relative place within the package's installation image within the
|
||||
stow directory, and then stowing proceeds as before. So effectively,
|
||||
the file becomes adopted by the stow package, without its contents
|
||||
changing.
|
||||
|
||||
This is particularly useful when the stow package is under the control
|
||||
of a version control system, because it allows files in the target
|
||||
tree, with potentially different contents to the equivalent versions
|
||||
in the stow package's installation image, to be adopted into the
|
||||
package, then compared by running something like @samp{git diff ...}
|
||||
inside the stow package, and finally either kept (e.g. via @samp{git
|
||||
commit ...}) or discarded (@samp{git checkout HEAD ...}).
|
||||
|
||||
@item -n
|
||||
@itemx --no
|
||||
@itemx --simulate
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ use strict;
|
|||
use warnings;
|
||||
|
||||
use Carp qw(carp cluck croak confess longmess);
|
||||
use File::Copy qw(move);
|
||||
use File::Spec;
|
||||
use POSIX qw(getcwd);
|
||||
|
||||
|
|
@ -59,6 +60,7 @@ our %DEFAULT_OPTIONS = (
|
|||
paranoid => 0,
|
||||
compat => 0,
|
||||
test_mode => 0,
|
||||
adopt => 0,
|
||||
ignore => [],
|
||||
override => [],
|
||||
defer => [],
|
||||
|
|
@ -198,10 +200,11 @@ sub init_state {
|
|||
# $self->{tasks}: list of operations to be performed (in order)
|
||||
# each element is a hash ref of the form
|
||||
# {
|
||||
# action => ... ('create' or 'remove')
|
||||
# type => ... ('link' or 'dir')
|
||||
# action => ... ('create' or 'remove' or 'move')
|
||||
# type => ... ('link' or 'dir' or 'file')
|
||||
# path => ... (unique)
|
||||
# source => ... (only for links)
|
||||
# dest => ... (only for moving files)
|
||||
# }
|
||||
$self->{tasks} = [];
|
||||
|
||||
|
|
@ -490,11 +493,17 @@ sub stow_node {
|
|||
);
|
||||
}
|
||||
else {
|
||||
$self->conflict(
|
||||
'stow',
|
||||
$package,
|
||||
"existing target is neither a link nor a directory: $target"
|
||||
);
|
||||
if ($self->{adopt}) {
|
||||
$self->do_mv($target, $path);
|
||||
$self->do_link($source, $target);
|
||||
}
|
||||
else {
|
||||
$self->conflict(
|
||||
'stow',
|
||||
$package,
|
||||
"existing target is neither a link nor a directory: $target"
|
||||
);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
|
|
@ -1413,6 +1422,7 @@ sub process_task {
|
|||
if ($task->{type} eq 'dir') {
|
||||
mkdir($task->{path}, 0777)
|
||||
or error(qq(Could not create directory: $task->{path}));
|
||||
return;
|
||||
}
|
||||
elsif ($task->{type} eq 'link') {
|
||||
symlink $task->{source}, $task->{path}
|
||||
|
|
@ -1421,27 +1431,33 @@ sub process_task {
|
|||
$task->{path},
|
||||
$task->{source}
|
||||
);
|
||||
}
|
||||
else {
|
||||
internal_error(qq(bad task type: $task->{type}));
|
||||
return;
|
||||
}
|
||||
}
|
||||
elsif ($task->{action} eq 'remove') {
|
||||
if ($task->{type} eq 'dir') {
|
||||
rmdir $task->{path}
|
||||
or error(qq(Could not remove directory: $task->{path}));
|
||||
return;
|
||||
}
|
||||
elsif ($task->{type} eq 'link') {
|
||||
unlink $task->{path}
|
||||
or error(qq(Could not remove link: $task->{path}));
|
||||
}
|
||||
else {
|
||||
internal_error(qq(bad task type: $task->{type}));
|
||||
return;
|
||||
}
|
||||
}
|
||||
else {
|
||||
internal_error(qq(bad task action: $task->{action}));
|
||||
elsif ($task->{action} eq 'move') {
|
||||
if ($task->{type} eq 'file') {
|
||||
# rename() not good enough, since the stow directory
|
||||
# might be on a different filesystem to the target.
|
||||
move $task->{path}, $task->{dest}
|
||||
or error(qq(Could not move $task->{path} -> $task->{dest}));
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Should never happen.
|
||||
internal_error(qq(bad task action: $task->{action}));
|
||||
}
|
||||
|
||||
#===== METHOD ===============================================================
|
||||
|
|
@ -1946,6 +1962,53 @@ sub do_rmdir {
|
|||
return;
|
||||
}
|
||||
|
||||
#===== METHOD ===============================================================
|
||||
# Name : do_mv()
|
||||
# Purpose : wrap 'move' operation for later processing
|
||||
# Parameters: $src => the file to move
|
||||
# : $dst => the path to move it to
|
||||
# Returns : n/a
|
||||
# Throws : error if this clashes with an existing planned operation
|
||||
# Comments : alters contents of package installation image in stow dir
|
||||
#============================================================================
|
||||
sub do_mv {
|
||||
my $self = shift;
|
||||
my ($src, $dst) = @_;
|
||||
|
||||
if (exists $self->{link_task_for}{$src}) {
|
||||
# I don't *think* this should ever happen, but I'm not
|
||||
# 100% sure.
|
||||
my $task_ref = $self->{link_task_for}{$src};
|
||||
internal_error(
|
||||
"do_mv: pre-existing link task for $src; action: %s, source: %s",
|
||||
$task_ref->{action}, $task_ref->{source}
|
||||
);
|
||||
}
|
||||
elsif (exists $self->{dir_task_for}{$src}) {
|
||||
my $task_ref = $self->{dir_task_for}{$src};
|
||||
internal_error(
|
||||
"do_mv: pre-existing dir task for %s?! action: %s",
|
||||
$src, $task_ref->{action}
|
||||
);
|
||||
}
|
||||
|
||||
# Remove the link
|
||||
debug(1, "MV: $src -> $dst");
|
||||
|
||||
my $task = {
|
||||
action => 'move',
|
||||
type => 'file',
|
||||
path => $src,
|
||||
dest => $dst,
|
||||
};
|
||||
push @{ $self->{tasks} }, $task;
|
||||
|
||||
# FIXME: do we need this for anything?
|
||||
#$self->{mv_task_for}{$file} = $task;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
#############################################################################
|
||||
#
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ Verbosity rules:
|
|||
|
||||
=item 0: errors only
|
||||
|
||||
=item >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR
|
||||
=item >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR/MV
|
||||
|
||||
=item >= 2: print operation exceptions
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 23;
|
||||
use Test::More tests => 35;
|
||||
use Test::Output;
|
||||
use English qw(-no_match_vars);
|
||||
|
||||
|
|
@ -47,6 +47,7 @@ $stow = new_Stow();
|
|||
make_dir('../stow/pkg2/lib2');
|
||||
make_file('../stow/pkg2/lib2/file2');
|
||||
make_dir('lib2');
|
||||
|
||||
$stow->plan_stow('pkg2');
|
||||
$stow->process_tasks();
|
||||
is(
|
||||
|
|
@ -66,6 +67,7 @@ make_link('bin3' => '../stow/pkg3a/bin3'); # emulate stow
|
|||
|
||||
make_dir('../stow/pkg3b/bin3');
|
||||
make_file('../stow/pkg3b/bin3/file3b');
|
||||
|
||||
$stow->plan_stow('pkg3b');
|
||||
$stow->process_tasks();
|
||||
ok(
|
||||
|
|
@ -76,21 +78,103 @@ ok(
|
|||
);
|
||||
|
||||
#
|
||||
# Link to a new dir conflicts with existing non-dir (can't unfold)
|
||||
# Link to a new dir 'bin4' conflicts with existing non-dir so can't
|
||||
# unfold
|
||||
#
|
||||
$stow = new_Stow();
|
||||
|
||||
make_file('bin4'); # this is a file but named like a directory
|
||||
make_dir('../stow/pkg4/bin4');
|
||||
make_file('../stow/pkg4/bin4/file4');
|
||||
|
||||
$stow->plan_stow('pkg4');
|
||||
%conflicts = $stow->get_conflicts();
|
||||
like(
|
||||
$conflicts{stow}{pkg4}[-1],
|
||||
qr(existing target is neither a link nor a directory)
|
||||
=> 'link to new dir conflicts with existing non-directory'
|
||||
ok(
|
||||
$stow->get_conflict_count == 1 &&
|
||||
$conflicts{stow}{pkg4}[0] =~
|
||||
qr/existing target is neither a link nor a directory/
|
||||
=> 'link to new dir bin4 conflicts with existing non-directory'
|
||||
);
|
||||
|
||||
#
|
||||
# Link to a new dir 'bin4a' conflicts with existing non-dir so can't
|
||||
# unfold even with --adopt
|
||||
#
|
||||
#$stow = new_Stow(adopt => 1);
|
||||
$stow = new_Stow();
|
||||
|
||||
make_file('bin4a'); # this is a file but named like a directory
|
||||
make_dir('../stow/pkg4a/bin4a');
|
||||
make_file('../stow/pkg4a/bin4a/file4a');
|
||||
|
||||
$stow->plan_stow('pkg4a');
|
||||
%conflicts = $stow->get_conflicts();
|
||||
ok(
|
||||
$stow->get_conflict_count == 1 &&
|
||||
$conflicts{stow}{pkg4a}[0] =~
|
||||
qr/existing target is neither a link nor a directory/
|
||||
=> 'link to new dir bin4a conflicts with existing non-directory'
|
||||
);
|
||||
|
||||
#
|
||||
# Link to files 'file4b' and 'bin4b' conflict with existing files
|
||||
# without --adopt
|
||||
#
|
||||
$stow = new_Stow();
|
||||
|
||||
# Populate target
|
||||
make_file('file4b', 'file4b - version originally in target');
|
||||
make_dir ('bin4b');
|
||||
make_file('bin4b/file4b', 'bin4b/file4b - version originally in target');
|
||||
|
||||
# Populate
|
||||
make_dir ('../stow/pkg4b/bin4b');
|
||||
make_file('../stow/pkg4b/file4b', 'file4b - version originally in stow package');
|
||||
make_file('../stow/pkg4b/bin4b/file4b', 'bin4b/file4b - version originally in stow package');
|
||||
|
||||
$stow->plan_stow('pkg4b');
|
||||
%conflicts = $stow->get_conflicts();
|
||||
is($stow->get_conflict_count, 2 => 'conflict per file');
|
||||
for my $i (0, 1) {
|
||||
like(
|
||||
$conflicts{stow}{pkg4b}[$i],
|
||||
qr/existing target is neither a link nor a directory/
|
||||
=> 'link to file4b conflicts with existing non-directory'
|
||||
);
|
||||
}
|
||||
|
||||
#
|
||||
# Link to files 'file4b' and 'bin4b' do not conflict with existing
|
||||
# files when --adopt is given
|
||||
#
|
||||
$stow = new_Stow(adopt => 1);
|
||||
|
||||
# Populate target
|
||||
make_file('file4c', "file4c - version originally in target\n");
|
||||
make_dir ('bin4c');
|
||||
make_file('bin4c/file4c', "bin4c/file4c - version originally in target\n");
|
||||
|
||||
# Populate
|
||||
make_dir ('../stow/pkg4c/bin4c');
|
||||
make_file('../stow/pkg4c/file4c', "file4c - version originally in stow package\n");
|
||||
make_file('../stow/pkg4c/bin4c/file4c', "bin4c/file4c - version originally in stow package\n");
|
||||
|
||||
$stow->plan_stow('pkg4c');
|
||||
is($stow->get_conflict_count, 0 => 'no conflicts with --adopt');
|
||||
my @tasks = $stow->get_tasks;
|
||||
is(@tasks, 4 => 'two tasks per file');
|
||||
$stow->process_tasks();
|
||||
for my $file ('file4c', 'bin4c/file4c') {
|
||||
ok(-l $file, "$file turned into a symlink");
|
||||
is(
|
||||
readlink $file,
|
||||
(index($file, '/') == -1 ? '' : '../' )
|
||||
. "../stow/pkg4c/$file" => "$file points to right place"
|
||||
);
|
||||
is(cat_file($file), "$file - version originally in target\n" => "$file has right contents");
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Target already exists but is not owned by stow
|
||||
#
|
||||
|
|
@ -99,11 +183,12 @@ $stow = new_Stow();
|
|||
make_dir('bin5');
|
||||
make_link('bin5/file5','../../empty');
|
||||
make_dir('../stow/pkg5/bin5/file5');
|
||||
|
||||
$stow->plan_stow('pkg5');
|
||||
%conflicts = $stow->get_conflicts();
|
||||
like(
|
||||
$conflicts{stow}{pkg5}[-1],
|
||||
qr(not owned by stow)
|
||||
qr/not owned by stow/
|
||||
=> 'target already exists but is not owned by stow'
|
||||
);
|
||||
|
||||
|
|
@ -115,6 +200,7 @@ $stow = new_Stow();
|
|||
make_link('file6','../stow/path-does-not-exist');
|
||||
make_dir('../stow/pkg6');
|
||||
make_file('../stow/pkg6/file6');
|
||||
|
||||
$stow->plan_stow('pkg6');
|
||||
$stow->process_tasks();
|
||||
is(
|
||||
|
|
@ -135,11 +221,12 @@ make_file('../stow/pkg7a/bin7/node7');
|
|||
make_link('bin7/node7','../../stow/pkg7a/bin7/node7');
|
||||
make_dir('../stow/pkg7b/bin7/node7');
|
||||
make_file('../stow/pkg7b/bin7/node7/file7');
|
||||
|
||||
$stow->plan_stow('pkg7b');
|
||||
%conflicts = $stow->get_conflicts();
|
||||
like(
|
||||
$conflicts{stow}{pkg7b}[-1],
|
||||
qr(existing target is stowed to a different package)
|
||||
qr/existing target is stowed to a different package/
|
||||
=> 'link to new dir conflicts with existing stowed non-directory'
|
||||
);
|
||||
|
||||
|
|
@ -154,6 +241,7 @@ make_link('0' => '../stow/pkg8a/0'); # emulate stow
|
|||
|
||||
make_dir('../stow/pkg8b/0');
|
||||
make_file('../stow/pkg8b/0/file8b');
|
||||
|
||||
$stow->plan_stow('pkg8b');
|
||||
$stow->process_tasks();
|
||||
ok(
|
||||
|
|
@ -176,6 +264,7 @@ make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emu
|
|||
|
||||
make_dir('../stow/pkg9b/man9/man1');
|
||||
make_file('../stow/pkg9b/man9/man1/file9.1');
|
||||
|
||||
$stow->plan_stow('pkg9b');
|
||||
$stow->process_tasks();
|
||||
ok(
|
||||
|
|
@ -196,8 +285,8 @@ make_link('man10/man1/file10.1' => '../../../stow/pkg10a/man10/man1/file10.1');
|
|||
|
||||
make_dir('../stow/pkg10b/man10/man1');
|
||||
make_file('../stow/pkg10b/man10/man1/file10.1');
|
||||
$stow->plan_stow('pkg10b');
|
||||
|
||||
$stow->plan_stow('pkg10b');
|
||||
stderr_like(
|
||||
sub { $stow->process_tasks(); },
|
||||
qr/There are no outstanding operations to perform/,
|
||||
|
|
@ -240,6 +329,7 @@ make_file('../stow/pkg12/lib12/lib.so');
|
|||
make_link('../stow/pkg12/lib12/lib.so.1','lib.so');
|
||||
|
||||
make_dir('lib12/');
|
||||
|
||||
$stow->plan_stow('pkg12');
|
||||
$stow->process_tasks();
|
||||
ok(
|
||||
|
|
@ -347,3 +437,4 @@ is(
|
|||
'../stow/pkg18/bin18',
|
||||
=> "minimal stow of a simple tree with absolute stow and target dirs"
|
||||
);
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@ package testutil;
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
use File::Path qw(remove_tree);
|
||||
|
||||
use Stow;
|
||||
use Stow::Util qw(parent canon_path);
|
||||
|
||||
|
|
@ -20,13 +22,14 @@ our @EXPORT = qw(
|
|||
new_Stow new_compat_Stow
|
||||
make_dir make_link make_file
|
||||
remove_dir remove_link
|
||||
cat_file
|
||||
);
|
||||
|
||||
our $OUT_DIR = 'tmp-testing-trees';
|
||||
|
||||
sub init_test_dirs {
|
||||
for my $dir ("$OUT_DIR/target", "$OUT_DIR/stow") {
|
||||
-d $dir and remove_dir($dir);
|
||||
-d $dir and remove_tree($dir);
|
||||
make_dir($dir);
|
||||
}
|
||||
|
||||
|
|
@ -110,7 +113,7 @@ sub make_dir {
|
|||
# Comments : detects clash with an existing non-file
|
||||
#============================================================================
|
||||
sub make_file {
|
||||
my ($path, $contents) =@_;
|
||||
my ($path, $contents) = @_;
|
||||
|
||||
if (-e $path and ! -f $path) {
|
||||
die "a non-file already exists at $path\n";
|
||||
|
|
@ -210,6 +213,22 @@ sub cd {
|
|||
chdir $dir or die "Failed to chdir($dir): $!\n";
|
||||
}
|
||||
|
||||
#===== SUBROUTINE ===========================================================
|
||||
# Name : cat_file()
|
||||
# Purpose : return file contents
|
||||
# Parameters: $file => file to read
|
||||
# Returns : n/a
|
||||
# Throws : fatal error if the open fails
|
||||
# Comments : none
|
||||
#============================================================================
|
||||
sub cat_file {
|
||||
my ($file) = @_;
|
||||
open F, $file or die "Failed to open($file): $!\n";
|
||||
my $contents = join '', <F>;
|
||||
close(F);
|
||||
return $contents;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# Local variables:
|
||||
|
|
|
|||
Loading…
Reference in a new issue