Add --adopt / -a option.

7 files changed, 246 insertions, 27 deletions

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<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' =>
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,22 +78,104 @@ 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
 #
 $stow = new_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 '', <F>;
+    close(F);
+    return $contents;
+}
+
 1;
 
 # Local variables: