t/unstow.t

   1 #!/usr/bin/perl
   2 #
   3 # This file is part of GNU Stow.
   4 #
   5 # GNU Stow is free software: you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # GNU Stow is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program. If not, see https://www.gnu.org/licenses/.
  17
  18 #
  19 # Test unstowing packages
  20 #
  21
  22 use strict;
  23 use warnings;
  24
  25 use File::Spec qw(make_path);
  26 use POSIX qw(getcwd);
  27 use Test::More tests => 35;
  28 use Test::Output;
  29 use English qw(-no_match_vars);
  30
  31 use testutil;
  32 use Stow::Util qw(canon_path);
  33
  34 my $repo = getcwd();
  35
  36 init_test_dirs($TEST_DIR);
  37
  38 our $COMPAT_TEST_DIR = "${TEST_DIR}-compat";
  39 our $COMPAT_ABS_TEST_DIR = init_test_dirs($COMPAT_TEST_DIR);
  40
  41 sub init_stow2 {
  42     make_path('stow2'); # make our alternate stow dir a subdir of target
  43     make_file('stow2/.stow');
  44 }
  45
  46 sub create_unowned_files {
  47     # Make things harder for Stow to figure out, by adding
  48     # a bunch of alien files unrelated to Stow.
  49     my @UNOWNED_DIRS = ('unowned-dir', '.unowned-dir', 'dot-unowned-dir');
  50     for my $dir ('.', @UNOWNED_DIRS) {
  51         for my $subdir ('.', @UNOWNED_DIRS) {
  52             make_path("$dir/$subdir");
  53             make_file("$dir/$subdir/unowned");
  54             make_file("$dir/$subdir/.unowned");
  55             make_file("$dir/$subdir/dot-unowned");
  56         }
  57     }
  58 }
  59
  60 # Run a subtest twice, with compat off then on, in parallel test trees.
  61 #
  62 # Params: $name[, $setup], $test_code
  63 #
  64 # $setup is an optional ref to an options hash to pass into the new
  65 # Stow() constructor, or a ref to a sub which performs setup before
  66 # the constructor gets called and then returns that options hash.
  67 sub subtests {
  68     my $name = shift;
  69     my $setup = @_ == 2 ? shift : {};
  70     my $code = shift;
  71
  72     $ENV{HOME} = $ABS_TEST_DIR;
  73     cd($repo);
  74     cd("$TEST_DIR/target");
  75     create_unowned_files();
  76     # cd first to allow setup to cd somewhere else.
  77     my $opts = ref($setup) eq 'HASH' ? $setup : $setup->($TEST_DIR);
  78     subtest($name, sub {
  79         make_path($opts->{dir}) if $opts->{dir};
  80         my $stow = new_Stow(%$opts);
  81         $code->($stow, $TEST_DIR);
  82     });
  83
  84     $ENV{HOME} = $COMPAT_ABS_TEST_DIR;
  85     cd($repo);
  86     cd("$COMPAT_TEST_DIR/target");
  87     create_unowned_files();
  88     # cd first to allow setup to cd somewhere else.
  89     $opts = ref $setup eq 'HASH' ? $setup : $setup->($COMPAT_TEST_DIR);
  90     subtest("$name (compat mode)", sub {
  91         make_path($opts->{dir}) if $opts->{dir};
  92         my $stow = new_compat_Stow(%$opts);
  93         $code->($stow, $COMPAT_TEST_DIR);
  94     });
  95 }
  96
  97 sub plan_tests {
  98     my ($stow, $count) = @_;
  99     plan tests => $stow->{compat} ? $count + 2 : $count;
 100 }
 101
 102 subtests("unstow a simple tree minimally", sub {
 103     my ($stow) = @_;
 104     plan tests => 3;
 105
 106     make_path('../stow/pkg1/bin1');
 107     make_file('../stow/pkg1/bin1/file1');
 108     make_link('bin1', '../stow/pkg1/bin1');
 109
 110     $stow->plan_unstow('pkg1');
 111     $stow->process_tasks();
 112     is($stow->get_conflict_count, 0, 'conflict count');
 113     ok(-f '../stow/pkg1/bin1/file1');
 114     ok(! -e 'bin1' => 'unstow a simple tree');
 115 });
 116
 117 subtests("unstow a simple tree from an existing directory", sub {
 118     my ($stow) = @_;
 119     plan tests => 3;
 120
 121     make_path('lib2');
 122     make_path('../stow/pkg2/lib2');
 123     make_file('../stow/pkg2/lib2/file2');
 124     make_link('lib2/file2', '../../stow/pkg2/lib2/file2');
 125     $stow->plan_unstow('pkg2');
 126     $stow->process_tasks();
 127     is($stow->get_conflict_count, 0, 'conflict count');
 128     ok(-f '../stow/pkg2/lib2/file2');
 129     ok(-d 'lib2'
 130         => 'unstow simple tree from a pre-existing directory'
 131     );
 132 });
 133
 134 subtests("fold tree after unstowing", sub {
 135     my ($stow) = @_;
 136     plan tests => 3;
 137
 138     make_path('bin3');
 139
 140     make_path('../stow/pkg3a/bin3');
 141     make_file('../stow/pkg3a/bin3/file3a');
 142     make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow
 143
 144     make_path('../stow/pkg3b/bin3');
 145     make_file('../stow/pkg3b/bin3/file3b');
 146     make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow
 147     $stow->plan_unstow('pkg3b');
 148     $stow->process_tasks();
 149     is($stow->get_conflict_count, 0, 'conflict count');
 150     ok(-l 'bin3');
 151     is(readlink('bin3'), '../stow/pkg3a/bin3'
 152         => 'fold tree after unstowing'
 153     );
 154 });
 155
 156 subtests("existing link is owned by stow but is invalid so it gets removed anyway", sub {
 157     my ($stow) = @_;
 158     plan tests => 2;
 159
 160     make_path('bin4');
 161     make_path('../stow/pkg4/bin4');
 162     make_file('../stow/pkg4/bin4/file4');
 163     make_invalid_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist');
 164
 165     $stow->plan_unstow('pkg4');
 166     $stow->process_tasks();
 167     is($stow->get_conflict_count, 0, 'conflict count');
 168     ok(! -e 'bin4/file4'
 169         => q(remove invalid link owned by stow)
 170     );
 171 });
 172
 173 subtests("Existing invalid link is not owned by stow", sub {
 174     my ($stow) = @_;
 175     plan tests => 3;
 176
 177     make_path('../stow/pkg5/bin5');
 178     make_invalid_link('bin5', '../not-stow');
 179
 180     $stow->plan_unstow('pkg5');
 181     is($stow->get_conflict_count, 0, 'conflict count');
 182     ok(-l 'bin5', 'invalid link not removed');
 183     is(readlink('bin5'), '../not-stow' => "invalid link not changed");
 184 });
 185
 186 subtests("Target already exists, is owned by stow, but points to a different package", sub {
 187     my ($stow) = @_;
 188     plan tests => 3;
 189
 190     make_path('bin6');
 191     make_path('../stow/pkg6a/bin6');
 192     make_file('../stow/pkg6a/bin6/file6');
 193     make_link('bin6/file6', '../../stow/pkg6a/bin6/file6');
 194
 195     make_path('../stow/pkg6b/bin6');
 196     make_file('../stow/pkg6b/bin6/file6');
 197
 198     $stow->plan_unstow('pkg6b');
 199     is($stow->get_conflict_count, 0, 'conflict count');
 200     ok(-l 'bin6/file6');
 201     is(
 202         readlink('bin6/file6'),
 203         '../../stow/pkg6a/bin6/file6'
 204         => q(ignore existing link that points to a different package)
 205     );
 206 });
 207
 208 subtests("Don't unlink anything under the stow directory",
 209          sub {
 210              make_path('stow');
 211              return { dir => 'stow' };
 212              # target dir defaults to parent of stow, which is target directory
 213          },
 214          sub {
 215     plan tests => 5;
 216     my ($stow) = @_;
 217
 218     # Emulate stowing into ourself (bizarre corner case or accident):
 219     make_path('stow/pkg7a/stow/pkg7b');
 220     make_file('stow/pkg7a/stow/pkg7b/file7b');
 221     # Make a package be a link to a package of the same name inside another package.
 222     make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b');
 223
 224     stderr_like(
 225         sub { $stow->plan_unstow('pkg7b'); },
 226         $stow->{compat} ? qr/WARNING: skipping target which was current stow directory stow/ : qr//
 227         => "warn when unstowing from ourself"
 228     );
 229     is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg7b');
 230     is($stow->get_conflict_count, 0, 'conflict count');
 231     ok(-l 'stow/pkg7b');
 232     is(
 233         readlink('stow/pkg7b'),
 234         '../stow/pkg7a/stow/pkg7b'
 235         => q(don't unlink any nodes under the stow directory)
 236     );
 237 });
 238
 239 subtests("Don't unlink any nodes under another stow directory",
 240          sub {
 241              make_path('stow');
 242              return { dir => 'stow' };
 243          },
 244          sub {
 245     my ($stow) = @_;
 246     plan tests => 5;
 247
 248     init_stow2();
 249     # emulate stowing into ourself (bizarre corner case or accident)
 250     make_path('stow/pkg8a/stow2/pkg8b');
 251     make_file('stow/pkg8a/stow2/pkg8b/file8b');
 252     make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b');
 253
 254     stderr_like(
 255         sub { $stow->plan_unstow('pkg8a'); },
 256         qr/WARNING: skipping marked Stow directory stow2/
 257         => "warn when skipping unstowing"
 258     );
 259     is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg8a');
 260     is($stow->get_conflict_count, 0, 'conflict count');
 261     ok(-l 'stow2/pkg8b');
 262     is(
 263         readlink('stow2/pkg8b'),
 264         '../stow/pkg8a/stow2/pkg8b'
 265         => q(don't unlink any nodes under another stow directory)
 266     );
 267 });
 268
 269 # This will be used by subsequent tests
 270 sub check_protected_dirs_skipped {
 271     my ($stderr) = @_;
 272     for my $dir (qw{stow stow2}) {
 273         like($stderr,
 274              qr/WARNING: skipping marked Stow directory $dir/
 275              => "warn when skipping marked directory $dir");
 276     }
 277 }
 278
 279 subtests("overriding already stowed documentation",
 280          {override => ['man9', 'info9']},
 281          sub {
 282     my ($stow) = @_;
 283     plan_tests($stow, 2);
 284
 285     make_file('stow/.stow');
 286     init_stow2();
 287     make_path('../stow/pkg9a/man9/man1');
 288     make_file('../stow/pkg9a/man9/man1/file9.1');
 289     make_path('man9/man1');
 290     make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow
 291
 292     make_path('../stow/pkg9b/man9/man1');
 293     make_file('../stow/pkg9b/man9/man1/file9.1');
 294     my $stderr = stderr_from { $stow->plan_unstow('pkg9b') };
 295     check_protected_dirs_skipped($stderr) if $stow->{compat};
 296     $stow->process_tasks();
 297     is($stow->get_conflict_count, 0, 'conflict count');
 298     ok(!-l 'man9/man1/file9.1'
 299         => 'overriding existing documentation files'
 300     );
 301 });
 302
 303 subtests("deferring to already stowed documentation",
 304          {defer => ['man10', 'info10']},
 305          sub {
 306     my ($stow) = @_;
 307     plan_tests($stow, 3);
 308
 309     init_stow2();
 310     make_path('../stow/pkg10a/man10/man1');
 311     make_file('../stow/pkg10a/man10/man1/file10a.1');
 312     make_path('man10/man1');
 313     make_link('man10/man1/file10a.1'  => '../../../stow/pkg10a/man10/man1/file10a.1');
 314
 315     # need this to block folding
 316     make_path('../stow/pkg10b/man10/man1');
 317     make_file('../stow/pkg10b/man10/man1/file10b.1');
 318     make_link('man10/man1/file10b.1'  => '../../../stow/pkg10b/man10/man1/file10b.1');
 319
 320     make_path('../stow/pkg10c/man10/man1');
 321     make_file('../stow/pkg10c/man10/man1/file10a.1');
 322     my $stderr = stderr_from { $stow->plan_unstow('pkg10c') };
 323     check_protected_dirs_skipped($stderr) if $stow->{compat};
 324     is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg10c');
 325     is($stow->get_conflict_count, 0, 'conflict count');
 326     is(
 327         readlink('man10/man1/file10a.1'),
 328         '../../../stow/pkg10a/man10/man1/file10a.1'
 329         => 'defer to existing documentation files'
 330     );
 331 });
 332
 333 subtests("Ignore temp files",
 334          {ignore => ['~', '\.#.*']},
 335          sub {
 336     my ($stow) = @_;
 337     plan_tests($stow, 2);
 338
 339     init_stow2();
 340     make_path('../stow/pkg12/man12/man1');
 341     make_file('../stow/pkg12/man12/man1/file12.1');
 342     make_file('../stow/pkg12/man12/man1/file12.1~');
 343     make_file('../stow/pkg12/man12/man1/.#file12.1');
 344     make_path('man12/man1');
 345     make_link('man12/man1/file12.1'  => '../../../stow/pkg12/man12/man1/file12.1');
 346
 347     my $stderr = stderr_from { $stow->plan_unstow('pkg12') };
 348     check_protected_dirs_skipped($stderr) if $stow->{compat};
 349     $stow->process_tasks();
 350     is($stow->get_conflict_count, 0, 'conflict count');
 351     ok(! -e 'man12/man1/file12.1' => 'man12/man1/file12.1 was unstowed');
 352 });
 353
 354 subtests("Unstow an already unstowed package", sub {
 355     my ($stow) = @_;
 356     plan_tests($stow, 2);
 357
 358     my $stderr = stderr_from { $stow->plan_unstow('pkg12') };
 359     check_protected_dirs_skipped($stderr) if $stow->{compat};
 360     is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12');
 361     is($stow->get_conflict_count, 0, 'conflict count');
 362 });
 363
 364 subtests("Unstow a never stowed package", sub {
 365     my ($stow) = @_;
 366     plan tests => 2;
 367
 368     eval { remove_dir($stow->{target}); };
 369     mkdir($stow->{target});
 370
 371     $stow->plan_unstow('pkg12');
 372     is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 which was never stowed');
 373     is($stow->get_conflict_count, 0, 'conflict count');
 374 });
 375
 376 subtests("Unstowing when target contains real files shouldn't be an issue", sub {
 377     my ($stow) = @_;
 378     plan tests => 4;
 379
 380     # Test both a file which do / don't overlap with the package
 381     make_path('man12/man1');
 382     make_file('man12/man1/alien');
 383     make_file('man12/man1/file12.1');
 384
 385     $stow->plan_unstow('pkg12');
 386     is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 for third time');
 387     is($stow->get_conflict_count, 0, 'conflict count');
 388     ok(-f 'man12/man1/alien', 'alien untouched');
 389     ok(-f 'man12/man1/file12.1', 'file overlapping with pkg untouched');
 390 });
 391
 392 subtests("unstow a simple tree minimally when cwd isn't target",
 393          sub {
 394              my $test_dir = shift;
 395              cd($repo);
 396              return {
 397                  dir => "$test_dir/stow",
 398                  target => "$test_dir/target"
 399              }
 400          },
 401          sub {
 402     my ($stow, $test_dir) = @_;
 403     plan tests => 3;
 404
 405     make_path("$test_dir/stow/pkg13/bin13");
 406     make_file("$test_dir/stow/pkg13/bin13/file13");
 407     make_link("$test_dir/target/bin13", '../stow/pkg13/bin13');
 408
 409     $stow->plan_unstow('pkg13');
 410     $stow->process_tasks();
 411     is($stow->get_conflict_count, 0, 'conflict count');
 412     ok(-f "$test_dir/stow/pkg13/bin13/file13", 'package file untouched');
 413     ok(! -e "$test_dir/target/bin13" => 'bin13/ unstowed');
 414 });
 415
 416 subtests("unstow a simple tree minimally with absolute stow dir when cwd isn't target",
 417          sub {
 418              my $test_dir = shift;
 419              cd($repo);
 420              return {
 421                  dir => canon_path("$test_dir/stow"),
 422                  target => "$test_dir/target"
 423              };
 424          },
 425          sub {
 426     plan tests => 3;
 427     my ($stow, $test_dir) = @_;
 428
 429     make_path("$test_dir/stow/pkg14/bin14");
 430     make_file("$test_dir/stow/pkg14/bin14/file14");
 431     make_link("$test_dir/target/bin14", '../stow/pkg14/bin14');
 432
 433     $stow->plan_unstow('pkg14');
 434     $stow->process_tasks();
 435     is($stow->get_conflict_count, 0, 'conflict count');
 436     ok(-f "$test_dir/stow/pkg14/bin14/file14");
 437     ok(! -e "$test_dir/target/bin14"
 438         => 'unstow a simple tree with absolute stow dir'
 439     );
 440 });
 441
 442 subtests("unstow a simple tree minimally with absolute stow AND target dirs when cwd isn't target",
 443          sub {
 444              my $test_dir = shift;
 445              cd($repo);
 446              return {
 447                  dir => canon_path("$test_dir/stow"),
 448                  target => canon_path("$test_dir/target")
 449              };
 450          },
 451          sub {
 452     my ($stow, $test_dir) = @_;
 453     plan tests => 3;
 454
 455     make_path("$test_dir/stow/pkg15/bin15");
 456     make_file("$test_dir/stow/pkg15/bin15/file15");
 457     make_link("$test_dir/target/bin15", '../stow/pkg15/bin15');
 458
 459     $stow->plan_unstow('pkg15');
 460     $stow->process_tasks();
 461     is($stow->get_conflict_count, 0, 'conflict count');
 462     ok(-f "$test_dir/stow/pkg15/bin15/file15");
 463     ok(! -e "$test_dir/target/bin15"
 464         => 'unstow a simple tree with absolute stow and target dirs'
 465     );
 466 });
 467
 468 sub create_and_stow_pkg {
 469     my ($id, $pkg) = @_;
 470
 471     my $stow_pkg = "../stow/$id-$pkg";
 472     make_path($stow_pkg);
 473     make_file("$stow_pkg/$id-file-$pkg");
 474
 475     # create a shallow hierarchy specific to this package and stow
 476     # via folding
 477     make_path("$stow_pkg/$id-$pkg-only-folded");
 478     make_file("$stow_pkg/$id-$pkg-only-folded/file-$pkg");
 479     make_link("$id-$pkg-only-folded", "$stow_pkg/$id-$pkg-only-folded");
 480
 481     # create a deeper hierarchy specific to this package and stow
 482     # via folding
 483     make_path("$stow_pkg/$id-$pkg-only-folded2/subdir");
 484     make_file("$stow_pkg/$id-$pkg-only-folded2/subdir/file-$pkg");
 485     make_link("$id-$pkg-only-folded2",
 486               "$stow_pkg/$id-$pkg-only-folded2");
 487
 488     # create a shallow hierarchy specific to this package and stow
 489     # without folding
 490     make_path("$stow_pkg/$id-$pkg-only-unfolded");
 491     make_file("$stow_pkg/$id-$pkg-only-unfolded/file-$pkg");
 492     make_path("$id-$pkg-only-unfolded");
 493     make_link("$id-$pkg-only-unfolded/file-$pkg",
 494               "../$stow_pkg/$id-$pkg-only-unfolded/file-$pkg");
 495
 496     # create a deeper hierarchy specific to this package and stow
 497     # without folding
 498     make_path("$stow_pkg/$id-$pkg-only-unfolded2/subdir");
 499     make_file("$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg");
 500     make_path("$id-$pkg-only-unfolded2/subdir");
 501     make_link("$id-$pkg-only-unfolded2/subdir/file-$pkg",
 502               "../../$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg");
 503
 504     # create a shallow shared hierarchy which this package uses, and stow
 505     # its contents without folding
 506     make_path("$stow_pkg/$id-shared");
 507     make_file("$stow_pkg/$id-shared/file-$pkg");
 508     make_path("$id-shared");
 509     make_link("$id-shared/file-$pkg",
 510               "../$stow_pkg/$id-shared/file-$pkg");
 511
 512     # create a deeper shared hierarchy which this package uses, and stow
 513     # its contents without folding
 514     make_path("$stow_pkg/$id-shared2/subdir");
 515     make_file("$stow_pkg/$id-shared2/file-$pkg");
 516     make_file("$stow_pkg/$id-shared2/subdir/file-$pkg");
 517     make_path("$id-shared2/subdir");
 518     make_link("$id-shared2/file-$pkg",
 519               "../$stow_pkg/$id-shared2/file-$pkg");
 520     make_link("$id-shared2/subdir/file-$pkg",
 521               "../../$stow_pkg/$id-shared2/subdir/file-$pkg");
 522 }
 523
 524 subtest("unstow a tree with no-folding enabled - no refolding should take place", sub {
 525     cd("$TEST_DIR/target");
 526     plan tests => 15;
 527
 528     foreach my $pkg (qw{a b}) {
 529         create_and_stow_pkg('no-folding', $pkg);
 530     }
 531
 532     my $stow = new_Stow('no-folding' => 1);
 533     $stow->plan_unstow('no-folding-b');
 534     is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding');
 535
 536     $stow->process_tasks();
 537
 538     is_nonexistent_path('no-folding-b-only-folded');
 539     is_nonexistent_path('no-folding-b-only-folded2');
 540     is_nonexistent_path('no-folding-b-only-unfolded/file-b');
 541     is_nonexistent_path('no-folding-b-only-unfolded2/subdir/file-b');
 542     is_dir_not_symlink('no-folding-shared');
 543     is_dir_not_symlink('no-folding-shared2');
 544     is_dir_not_symlink('no-folding-shared2/subdir');
 545 });
 546
 547 # subtests("Test cleaning up subdirs with --paranoid option", sub {
 548 # TODO
 549 # });