Add --adopt / -a option.

This commit is contained in:
Adam Spiers 2012-01-09 21:25:35 +00:00
parent 5110ea8338
commit 7e44666640
7 changed files with 246 additions and 27 deletions

5
NEWS
View file

@ -2,6 +2,11 @@ News file for Stow.
* Changes in version 2.1.3 * 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. ** ./configure now checks for Perl modules required by the test suite.
* Changes in version 2.1.2 * Changes in version 2.1.2

View file

@ -181,6 +181,23 @@ Restow packages (first unstow, then stow again). This is useful
for pruning obsolete symlinks from the target tree after updating for pruning obsolete symlinks from the target tree after updating
the software in a package. 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 =item --ignore=REGEX
Ignore files ending in this Perl regex. Ignore files ending in this Perl regex.
@ -462,6 +479,7 @@ sub process_options {
\%options, \%options,
'verbose|v:+', 'help|h', 'simulate|n|no', 'verbose|v:+', 'help|h', 'simulate|n|no',
'version|V', 'compat|p', 'dir|d=s', 'target|t=s', 'version|V', 'compat|p', 'dir|d=s', 'target|t=s',
'adopt|a',
# clean and pre-compile any regex's at parse time # clean and pre-compile any regex's at parse time
'ignore=s' => 'ignore=s' =>

View file

@ -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 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. 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 @item -n
@itemx --no @itemx --no
@itemx --simulate @itemx --simulate

View file

@ -36,6 +36,7 @@ use strict;
use warnings; use warnings;
use Carp qw(carp cluck croak confess longmess); use Carp qw(carp cluck croak confess longmess);
use File::Copy qw(move);
use File::Spec; use File::Spec;
use POSIX qw(getcwd); use POSIX qw(getcwd);
@ -59,6 +60,7 @@ our %DEFAULT_OPTIONS = (
paranoid => 0, paranoid => 0,
compat => 0, compat => 0,
test_mode => 0, test_mode => 0,
adopt => 0,
ignore => [], ignore => [],
override => [], override => [],
defer => [], defer => [],
@ -198,10 +200,11 @@ sub init_state {
# $self->{tasks}: list of operations to be performed (in order) # $self->{tasks}: list of operations to be performed (in order)
# each element is a hash ref of the form # each element is a hash ref of the form
# { # {
# action => ... ('create' or 'remove') # action => ... ('create' or 'remove' or 'move')
# type => ... ('link' or 'dir') # type => ... ('link' or 'dir' or 'file')
# path => ... (unique) # path => ... (unique)
# source => ... (only for links) # source => ... (only for links)
# dest => ... (only for moving files)
# } # }
$self->{tasks} = []; $self->{tasks} = [];
@ -489,6 +492,11 @@ sub stow_node {
join_paths('..', $source), join_paths('..', $source),
); );
} }
else {
if ($self->{adopt}) {
$self->do_mv($target, $path);
$self->do_link($source, $target);
}
else { else {
$self->conflict( $self->conflict(
'stow', 'stow',
@ -497,6 +505,7 @@ sub stow_node {
); );
} }
} }
}
else { else {
$self->do_link($source, $target); $self->do_link($source, $target);
} }
@ -1413,6 +1422,7 @@ sub process_task {
if ($task->{type} eq 'dir') { if ($task->{type} eq 'dir') {
mkdir($task->{path}, 0777) mkdir($task->{path}, 0777)
or error(qq(Could not create directory: $task->{path})); or error(qq(Could not create directory: $task->{path}));
return;
} }
elsif ($task->{type} eq 'link') { elsif ($task->{type} eq 'link') {
symlink $task->{source}, $task->{path} symlink $task->{source}, $task->{path}
@ -1421,27 +1431,33 @@ sub process_task {
$task->{path}, $task->{path},
$task->{source} $task->{source}
); );
} return;
else {
internal_error(qq(bad task type: $task->{type}));
} }
} }
elsif ($task->{action} eq 'remove') { elsif ($task->{action} eq 'remove') {
if ($task->{type} eq 'dir') { if ($task->{type} eq 'dir') {
rmdir $task->{path} rmdir $task->{path}
or error(qq(Could not remove directory: $task->{path})); or error(qq(Could not remove directory: $task->{path}));
return;
} }
elsif ($task->{type} eq 'link') { elsif ($task->{type} eq 'link') {
unlink $task->{path} unlink $task->{path}
or error(qq(Could not remove link: $task->{path})); or error(qq(Could not remove link: $task->{path}));
} return;
else {
internal_error(qq(bad task type: $task->{type}));
} }
} }
else { 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})); internal_error(qq(bad task action: $task->{action}));
}
} }
#===== METHOD =============================================================== #===== METHOD ===============================================================
@ -1946,6 +1962,53 @@ sub do_rmdir {
return; 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;
}
############################################################################# #############################################################################
# #

View file

@ -91,7 +91,7 @@ Verbosity rules:
=item 0: errors only =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 =item >= 2: print operation exceptions

View file

@ -7,7 +7,7 @@
use strict; use strict;
use warnings; use warnings;
use Test::More tests => 23; use Test::More tests => 35;
use Test::Output; use Test::Output;
use English qw(-no_match_vars); use English qw(-no_match_vars);
@ -47,6 +47,7 @@ $stow = new_Stow();
make_dir('../stow/pkg2/lib2'); make_dir('../stow/pkg2/lib2');
make_file('../stow/pkg2/lib2/file2'); make_file('../stow/pkg2/lib2/file2');
make_dir('lib2'); make_dir('lib2');
$stow->plan_stow('pkg2'); $stow->plan_stow('pkg2');
$stow->process_tasks(); $stow->process_tasks();
is( is(
@ -66,6 +67,7 @@ make_link('bin3' => '../stow/pkg3a/bin3'); # emulate stow
make_dir('../stow/pkg3b/bin3'); make_dir('../stow/pkg3b/bin3');
make_file('../stow/pkg3b/bin3/file3b'); make_file('../stow/pkg3b/bin3/file3b');
$stow->plan_stow('pkg3b'); $stow->plan_stow('pkg3b');
$stow->process_tasks(); $stow->process_tasks();
ok( 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(); $stow = new_Stow();
make_file('bin4'); # this is a file but named like a directory make_file('bin4'); # this is a file but named like a directory
make_dir('../stow/pkg4/bin4'); make_dir('../stow/pkg4/bin4');
make_file('../stow/pkg4/bin4/file4'); make_file('../stow/pkg4/bin4/file4');
$stow->plan_stow('pkg4'); $stow->plan_stow('pkg4');
%conflicts = $stow->get_conflicts(); %conflicts = $stow->get_conflicts();
like( ok(
$conflicts{stow}{pkg4}[-1], $stow->get_conflict_count == 1 &&
qr(existing target is neither a link nor a directory) $conflicts{stow}{pkg4}[0] =~
=> 'link to new dir conflicts with existing non-directory' 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 # Target already exists but is not owned by stow
# #
@ -99,11 +183,12 @@ $stow = new_Stow();
make_dir('bin5'); make_dir('bin5');
make_link('bin5/file5','../../empty'); make_link('bin5/file5','../../empty');
make_dir('../stow/pkg5/bin5/file5'); make_dir('../stow/pkg5/bin5/file5');
$stow->plan_stow('pkg5'); $stow->plan_stow('pkg5');
%conflicts = $stow->get_conflicts(); %conflicts = $stow->get_conflicts();
like( like(
$conflicts{stow}{pkg5}[-1], $conflicts{stow}{pkg5}[-1],
qr(not owned by stow) qr/not owned by stow/
=> 'target already exists but is 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_link('file6','../stow/path-does-not-exist');
make_dir('../stow/pkg6'); make_dir('../stow/pkg6');
make_file('../stow/pkg6/file6'); make_file('../stow/pkg6/file6');
$stow->plan_stow('pkg6'); $stow->plan_stow('pkg6');
$stow->process_tasks(); $stow->process_tasks();
is( is(
@ -135,11 +221,12 @@ make_file('../stow/pkg7a/bin7/node7');
make_link('bin7/node7','../../stow/pkg7a/bin7/node7'); make_link('bin7/node7','../../stow/pkg7a/bin7/node7');
make_dir('../stow/pkg7b/bin7/node7'); make_dir('../stow/pkg7b/bin7/node7');
make_file('../stow/pkg7b/bin7/node7/file7'); make_file('../stow/pkg7b/bin7/node7/file7');
$stow->plan_stow('pkg7b'); $stow->plan_stow('pkg7b');
%conflicts = $stow->get_conflicts(); %conflicts = $stow->get_conflicts();
like( like(
$conflicts{stow}{pkg7b}[-1], $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' => '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_dir('../stow/pkg8b/0');
make_file('../stow/pkg8b/0/file8b'); make_file('../stow/pkg8b/0/file8b');
$stow->plan_stow('pkg8b'); $stow->plan_stow('pkg8b');
$stow->process_tasks(); $stow->process_tasks();
ok( 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_dir('../stow/pkg9b/man9/man1');
make_file('../stow/pkg9b/man9/man1/file9.1'); make_file('../stow/pkg9b/man9/man1/file9.1');
$stow->plan_stow('pkg9b'); $stow->plan_stow('pkg9b');
$stow->process_tasks(); $stow->process_tasks();
ok( ok(
@ -196,8 +285,8 @@ make_link('man10/man1/file10.1' => '../../../stow/pkg10a/man10/man1/file10.1');
make_dir('../stow/pkg10b/man10/man1'); make_dir('../stow/pkg10b/man10/man1');
make_file('../stow/pkg10b/man10/man1/file10.1'); make_file('../stow/pkg10b/man10/man1/file10.1');
$stow->plan_stow('pkg10b');
$stow->plan_stow('pkg10b');
stderr_like( stderr_like(
sub { $stow->process_tasks(); }, sub { $stow->process_tasks(); },
qr/There are no outstanding operations to perform/, 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_link('../stow/pkg12/lib12/lib.so.1','lib.so');
make_dir('lib12/'); make_dir('lib12/');
$stow->plan_stow('pkg12'); $stow->plan_stow('pkg12');
$stow->process_tasks(); $stow->process_tasks();
ok( ok(
@ -347,3 +437,4 @@ is(
'../stow/pkg18/bin18', '../stow/pkg18/bin18',
=> "minimal stow of a simple tree with absolute stow and target dirs" => "minimal stow of a simple tree with absolute stow and target dirs"
); );

View file

@ -9,6 +9,8 @@ package testutil;
use strict; use strict;
use warnings; use warnings;
use File::Path qw(remove_tree);
use Stow; use Stow;
use Stow::Util qw(parent canon_path); use Stow::Util qw(parent canon_path);
@ -20,13 +22,14 @@ our @EXPORT = qw(
new_Stow new_compat_Stow new_Stow new_compat_Stow
make_dir make_link make_file make_dir make_link make_file
remove_dir remove_link remove_dir remove_link
cat_file
); );
our $OUT_DIR = 'tmp-testing-trees'; our $OUT_DIR = 'tmp-testing-trees';
sub init_test_dirs { sub init_test_dirs {
for my $dir ("$OUT_DIR/target", "$OUT_DIR/stow") { for my $dir ("$OUT_DIR/target", "$OUT_DIR/stow") {
-d $dir and remove_dir($dir); -d $dir and remove_tree($dir);
make_dir($dir); make_dir($dir);
} }
@ -110,7 +113,7 @@ sub make_dir {
# Comments : detects clash with an existing non-file # Comments : detects clash with an existing non-file
#============================================================================ #============================================================================
sub make_file { sub make_file {
my ($path, $contents) =@_; my ($path, $contents) = @_;
if (-e $path and ! -f $path) { if (-e $path and ! -f $path) {
die "a non-file already exists at $path\n"; die "a non-file already exists at $path\n";
@ -210,6 +213,22 @@ sub cd {
chdir $dir or die "Failed to chdir($dir): $!\n"; 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; 1;
# Local variables: # Local variables: