diff --git a/NEWS b/NEWS index 4979922..17cbf15 100644 --- a/NEWS +++ b/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 diff --git a/bin/stow.in b/bin/stow.in index 2659129..f2093df 100755 --- a/bin/stow.in +++ b/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 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' => diff --git a/doc/stow.texi b/doc/stow.texi index 7bbbe58..155a64a 100644 --- a/doc/stow.texi +++ b/doc/stow.texi @@ -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 diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index 2c393f1..47a863d 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -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; +} + ############################################################################# # diff --git a/lib/Stow/Util.pm b/lib/Stow/Util.pm index 072f880..173f1ec 100644 --- a/lib/Stow/Util.pm +++ b/lib/Stow/Util.pm @@ -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 diff --git a/t/stow_contents.t b/t/stow_contents.t index 24e01dc..d4e66f0 100755 --- a/t/stow_contents.t +++ b/t/stow_contents.t @@ -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" ); + diff --git a/t/testutil.pm b/t/testutil.pm index 67d4f45..97ac422 100755 --- a/t/testutil.pm +++ b/t/testutil.pm @@ -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 '', ; + close(F); + return $contents; +} + 1; # Local variables: