lib/Stow.pm.in

   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 package Stow;
  19
  20 =head1 NAME
  21
  22 Stow - manage farms of symbolic links
  23
  24 =head1 SYNOPSIS
  25
  26     my $stow = new Stow(%$options);
  27
  28     $stow->plan_unstow(@pkgs_to_unstow);
  29     $stow->plan_stow  (@pkgs_to_stow);
  30
  31     my %conflicts = $stow->get_conflicts;
  32     $stow->process_tasks() unless %conflicts;
  33
  34 =head1 DESCRIPTION
  35
  36 This is the backend Perl module for GNU Stow, a program for managing
  37 the installation of software packages, keeping them separate
  38 (C</usr/local/stow/emacs> vs. C</usr/local/stow/perl>, for example)
  39 while making them appear to be installed in the same place
  40 (C</usr/local>).
  41
  42 Stow doesn't store an extra state between runs, so there's no danger
  43 of mangling directories when file hierarchies don't match the
  44 database. Also, stow will never delete any files, directories, or
  45 links that appear in a stow directory, so it is always possible to
  46 rebuild the target tree.
  47
  48 =cut
  49
  50 use strict;
  51 use warnings;
  52
  53 use Carp qw(carp cluck croak confess longmess);
  54 use File::Copy qw(move);
  55 use File::Spec;
  56 use POSIX qw(getcwd);
  57
  58 use Stow::Util qw(set_debug_level debug error set_test_mode
  59                   join_paths restore_cwd canon_path parent adjust_dotfile);
  60
  61 our $ProgramName = 'stow';
  62 our $VERSION = '@VERSION@';
  63
  64 our $LOCAL_IGNORE_FILE  = '.stow-local-ignore';
  65 our $GLOBAL_IGNORE_FILE = '.stow-global-ignore';
  66
  67 our @default_global_ignore_regexps =
  68     __PACKAGE__->get_default_global_ignore_regexps();
  69
  70 # These are the default options for each Stow instance.
  71 our %DEFAULT_OPTIONS = (
  72     conflicts    => 0,
  73     simulate     => 0,
  74     verbose      => 0,
  75     paranoid     => 0,
  76     compat       => 0,
  77     test_mode    => 0,
  78     dotfiles     => 0,
  79     adopt        => 0,
  80     'no-folding' => 0,
  81     ignore       => [],
  82     override     => [],
  83     defer        => [],
  84 );
  85
  86 =head1 CONSTRUCTORS
  87
  88 =head2 new(%options)
  89
  90 =head3 Required options
  91
  92 =over 4
  93
  94 =item * dir - the stow directory
  95
  96 =item * target - the target directory
  97
  98 =back
  99
 100 =head3 Non-mandatory options
 101
 102 See the documentation for the F<stow> CLI front-end for information on these.
 103
 104 =over 4
 105
 106 =item * conflicts
 107
 108 =item * simulate
 109
 110 =item * verbose
 111
 112 =item * paranoid
 113
 114 =item * compat
 115
 116 =item * test_mode
 117
 118 =item * adopt
 119
 120 =item * no-folding
 121
 122 =item * ignore
 123
 124 =item * override
 125
 126 =item * defer
 127
 128 =back
 129
 130 N.B. This sets the current working directory to the target directory.
 131
 132 =cut
 133
 134 sub new {
 135     my $self = shift;
 136     my $class = ref($self) || $self;
 137     my %opts = @_;
 138
 139     my $new = bless { }, $class;
 140
 141     $new->{action_count} = 0;
 142
 143     for my $required_arg (qw(dir target)) {
 144         croak "$class->new() called without '$required_arg' parameter\n"
 145             unless exists $opts{$required_arg};
 146         $new->{$required_arg} = delete $opts{$required_arg};
 147     }
 148
 149     for my $opt (keys %DEFAULT_OPTIONS) {
 150         $new->{$opt} = exists $opts{$opt} ? delete $opts{$opt}
 151                                           : $DEFAULT_OPTIONS{$opt};
 152     }
 153
 154     if (%opts) {
 155         croak "$class->new() called with unrecognised parameter(s): ",
 156             join(", ", keys %opts), "\n";
 157     }
 158
 159     set_debug_level($new->get_verbosity());
 160     set_test_mode($new->{test_mode});
 161     $new->set_stow_dir();
 162     $new->init_state();
 163
 164     return $new;
 165 }
 166
 167 sub get_verbosity {
 168     my $self = shift;
 169
 170     return $self->{verbose} unless $self->{test_mode};
 171
 172     return 0 unless exists $ENV{TEST_VERBOSE};
 173     return 0 unless length $ENV{TEST_VERBOSE};
 174
 175     # Convert TEST_VERBOSE=y into numeric value
 176     $ENV{TEST_VERBOSE} = 3 if $ENV{TEST_VERBOSE} !~ /^\d+$/;
 177
 178     return $ENV{TEST_VERBOSE};
 179 }
 180
 181 =head2 set_stow_dir([$dir])
 182
 183 Sets a new stow directory.  This allows the use of multiple stow
 184 directories within one Stow instance, e.g.
 185
 186     $stow->plan_stow('foo');
 187     $stow->set_stow_dir('/different/stow/dir');
 188     $stow->plan_stow('bar');
 189     $stow->process_tasks;
 190
 191 If C<$dir> is omitted, uses the value of the C<dir> parameter passed
 192 to the L<new()> constructor.
 193
 194 =cut
 195
 196 sub set_stow_dir {
 197     my $self = shift;
 198     my ($dir) = @_;
 199     if (defined $dir) {
 200         $self->{dir} = $dir;
 201     }
 202
 203     my $stow_dir = canon_path($self->{dir});
 204     my $target = canon_path($self->{target});
 205
 206     # Calculate relative path from target directory to stow directory.
 207     # This will be commonly used as a prefix for constructing and
 208     # recognising symlinks "installed" in the target directory which
 209     # point to package files under the stow directory.
 210     $self->{stow_path} = File::Spec->abs2rel($stow_dir, $target);
 211
 212     debug(2, 0, "stow dir is $stow_dir");
 213     debug(2, 0, "stow dir path relative to target $target is $self->{stow_path}");
 214 }
 215
 216 sub init_state {
 217     my $self = shift;
 218
 219     # Store conflicts during pre-processing
 220     $self->{conflicts}      = {};
 221     $self->{conflict_count} = 0;
 222
 223     # Store command line packages to stow (-S and -R)
 224     $self->{pkgs_to_stow}   = [];
 225
 226     # Store command line packages to unstow (-D and -R)
 227     $self->{pkgs_to_delete} = [];
 228
 229     # The following structures are used by the abstractions that allow us to
 230     # defer operating on the filesystem until after all potential conflicts have
 231     # been assessed.
 232
 233     # $self->{tasks}:  list of operations to be performed (in order)
 234     # each element is a hash ref of the form
 235     #   {
 236     #       action => ...  ('create' or 'remove' or 'move')
 237     #       type   => ...  ('link' or 'dir' or 'file')
 238     #       path   => ...  (unique)
 239     #       source => ...  (only for links)
 240     #       dest   => ...  (only for moving files)
 241     #   }
 242     $self->{tasks} = [];
 243
 244     # $self->{dir_task_for}: map a path to the corresponding directory task reference
 245     # This structure allows us to quickly determine if a path has an existing
 246     # directory task associated with it.
 247     $self->{dir_task_for} = {};
 248
 249     # $self->{link_task_for}: map a path to the corresponding directory task reference
 250     # This structure allows us to quickly determine if a path has an existing
 251     # directory task associated with it.
 252     $self->{link_task_for} = {};
 253
 254     # N.B.: directory tasks and link tasks are NOT mutually exclusive due
 255     # to tree splitting (which involves a remove link task followed by
 256     # a create directory task).
 257 }
 258
 259 =head1 METHODS
 260
 261 =head2 plan_unstow(@packages)
 262
 263 Plan which symlink/directory creation/removal tasks need to be executed
 264 in order to unstow the given packages.  Any potential conflicts are then
 265 accessible via L<get_conflicts()>.
 266
 267 =cut
 268
 269 sub plan_unstow {
 270     my $self = shift;
 271     my @packages = @_;
 272
 273     return unless @packages;
 274
 275     debug(2, 0, "Planning unstow of: @packages ...");
 276
 277     $self->within_target_do(sub {
 278         for my $package (@packages) {
 279             my $pkg_path = join_paths($self->{stow_path}, $package);
 280             if (not -d $pkg_path) {
 281                 error("The stow directory $self->{stow_path} does not contain package $package");
 282             }
 283             debug(2, 0, "Planning unstow of package $package...");
 284             $self->unstow_contents(
 285                 $package,
 286                 '.',
 287                 $pkg_path,
 288             );
 289             debug(2, 0, "Planning unstow of package $package... done");
 290             $self->{action_count}++;
 291         }
 292     });
 293 }
 294
 295 =head2 plan_stow(@packages)
 296
 297 Plan which symlink/directory creation/removal tasks need to be executed
 298 in order to stow the given packages.  Any potential conflicts are then
 299 accessible via L<get_conflicts()>.
 300
 301 =cut
 302
 303 sub plan_stow {
 304     my $self = shift;
 305     my @packages = @_;
 306
 307     return unless @packages;
 308
 309     debug(2, 0, "Planning stow of: @packages ...");
 310
 311     $self->within_target_do(sub {
 312         for my $package (@packages) {
 313             my $pkg_path = join_paths($self->{stow_path}, $package);
 314             if (not -d $pkg_path) {
 315                 error("The stow directory $self->{stow_path} does not contain package $package");
 316             }
 317             debug(2, 0, "Planning stow of package $package...");
 318             $self->stow_contents(
 319                 $self->{stow_path},
 320                 $package,
 321                 '.',
 322                 $pkg_path, # source from target
 323                 0,
 324             );
 325             debug(2, 0, "Planning stow of package $package... done");
 326             $self->{action_count}++;
 327         }
 328     });
 329 }
 330
 331 =head2 within_target_do($code)
 332
 333 Execute code within target directory, preserving cwd.
 334
 335 =over 4
 336
 337 =item $code
 338
 339 Anonymous subroutine to execute within target dir.
 340
 341 =back
 342
 343 This is done to ensure that the consumer of the Stow interface doesn't
 344 have to worry about (a) what their cwd is, and (b) that their cwd
 345 might change.
 346
 347 =cut
 348
 349 sub within_target_do {
 350     my $self = shift;
 351     my ($code) = @_;
 352
 353     my $cwd = getcwd();
 354     chdir($self->{target})
 355         or error("Cannot chdir to target tree: $self->{target} ($!)");
 356     debug(3, 0, "cwd now $self->{target}");
 357
 358     $self->$code();
 359
 360     restore_cwd($cwd);
 361     debug(3, 0, "cwd restored to $cwd");
 362 }
 363
 364 =head2 stow_contents($stow_path, $package, $target_subdir, $source)
 365
 366 Stow the contents of the given directory.
 367
 368 =over 4
 369
 370 =item $stow_path
 371
 372 Relative path from current (i.e. target) directory to the stow dir
 373 containing the package to be stowed.  This can differ from
 374 C<$self->{stow_path}> when unfolding a (sub)tree which is already
 375 stowed from a package in a different stow directory (see the "Multiple
 376 Stow Directories" section of the manual).
 377
 378 =item $package
 379
 380 The package whose contents are being stowed.
 381
 382 =item $target_subdir
 383
 384 Subpath relative to package directory which needs stowing as a symlink
 385 at subpath relative to target directory.
 386
 387 =item $source
 388
 389 Relative path from the (sub)dir of target to symlink source.
 390
 391 =back
 392
 393 C<stow_node()> and C<stow_contents()> are mutually recursive.
 394 C<$source> and C<$target_subdir> are used for creating the symlink.
 395
 396 =cut
 397
 398 sub stow_contents {
 399     my $self = shift;
 400     my ($stow_path, $package, $target_subdir, $source, $level) = @_;
 401
 402     # Calculate the path to the package directory or sub-directory
 403     # whose contents need to be stowed, relative to the current
 404     # (target directory).  This is needed so that we can check it's a
 405     # valid directory, and can read its contents to iterate over them.
 406     #
 407     # Note that $source refers to the same package (sub-)directory,
 408     # but instead it's relative to the target directory or
 409     # sub-directory where the symlink will be installed when the plans
 410     # are executed.
 411
 412     # Remove leading $level times .. from $source
 413     my $n = 0;
 414     my $path = join '/', map { (++$n <= $level) ? ( ) : $_ } (split m{/+}, $source);
 415
 416     return if $self->should_skip_target($target_subdir);
 417
 418     my $cwd = getcwd();
 419     my $msg = "Stowing contents of $path (cwd=$cwd)";
 420     $msg =~ s!$ENV{HOME}(/|$)!~$1!g;
 421     debug(3, 0, $msg);
 422     debug(4, 1, "=> $source");
 423
 424     error("stow_contents() called with non-directory package path: $path")
 425         unless -d $path;
 426     error("stow_contents() called with non-directory target: $target_subdir")
 427         unless $self->is_a_node($target_subdir);
 428
 429     opendir my $DIR, $path
 430         or error("cannot read directory: $path ($!)");
 431     my @listing = readdir $DIR;
 432     closedir $DIR;
 433
 434     NODE:
 435     for my $node (@listing) {
 436         next NODE if $node eq '.';
 437         next NODE if $node eq '..';
 438         my $node_target = join_paths($target_subdir, $node);
 439         next NODE if $self->ignore($stow_path, $package, $node_target);
 440
 441         if ($self->{dotfiles}) {
 442             my $adj_node_target = adjust_dotfile($node_target);
 443             debug(4, 1, "Adjusting: $node_target => $adj_node_target");
 444             $node_target = $adj_node_target;
 445         }
 446
 447         $self->stow_node(
 448             $stow_path,
 449             $package,
 450             $node_target,  # target, potentially adjusted for dot- prefix
 451             join_paths($source, $node),   # source
 452             $level
 453         );
 454     }
 455 }
 456
 457 =head2 stow_node($stow_path, $package, $target_subpath, $source)
 458
 459 Stow the given node
 460
 461 =over 4
 462
 463 =item $stow_path
 464
 465 Relative path from current (i.e. target) directory to the stow dir
 466 containing the node to be stowed.  This can differ from
 467 C<$self->{stow_path}> when unfolding a (sub)tree which is already
 468 stowed from a package in a different stow directory (see the "Multiple
 469 Stow Directories" section of the manual).
 470
 471 =item $package
 472
 473 The package containing the node being stowed
 474
 475 =item $target_subpath
 476
 477 Subpath relative to package directory of node which needs stowing as a
 478 symlink at subpath relative to target directory.
 479
 480 =item $source
 481
 482 Relative path to symlink source from the dir of target.
 483
 484 =back
 485
 486 C<stow_node()> and C<stow_contents()> are mutually recursive.
 487
 488 =cut
 489
 490 sub stow_node {
 491     my $self = shift;
 492     my ($stow_path, $package, $target_subpath, $source, $level) = @_;
 493
 494     my $path = join_paths($stow_path, $package, $target_subpath);
 495
 496     debug(3, 0, "Stowing entry $stow_path / $package / $target_subpath");
 497     debug(4, 1, "=> $source");
 498
 499     # Don't try to stow absolute symlinks (they can't be unstowed)
 500     if (-l $source) {
 501         my $link_dest = $self->read_a_link($source);
 502         if ($link_dest =~ m{\A/}) {
 503             $self->conflict(
 504                 'stow',
 505                 $package,
 506                 "source is an absolute symlink $source => $link_dest"
 507             );
 508             debug(3, 0, "Absolute symlinks cannot be unstowed");
 509             return;
 510         }
 511     }
 512
 513     # Does the target already exist?
 514     if ($self->is_a_link($target_subpath)) {
 515         # Where is the link pointing?
 516         my $existing_link_dest = $self->read_a_link($target_subpath);
 517         if (not $existing_link_dest) {
 518             error("Could not read link: $target_subpath");
 519         }
 520         debug(4, 1, "Evaluate existing link: $target_subpath => $existing_link_dest");
 521
 522         # Does it point to a node under any stow directory?
 523         my ($existing_pkg_path_from_cwd, $existing_stow_path, $existing_package) =
 524             $self->find_stowed_path($target_subpath, $existing_link_dest);
 525         if (not $existing_pkg_path_from_cwd) {
 526             $self->conflict(
 527                 'stow',
 528                 $package,
 529                 "existing target is not owned by stow: $target_subpath"
 530             );
 531             return;
 532         }
 533
 534         # Does the existing $target_subpath actually point to anything?
 535         if ($self->is_a_node($existing_pkg_path_from_cwd)) {
 536             if ($existing_link_dest eq $source) {
 537                 debug(2, 0, "--- Skipping $target_subpath as it already points to $source");
 538             }
 539             elsif ($self->defer($target_subpath)) {
 540                 debug(2, 0, "--- Deferring installation of: $target_subpath");
 541             }
 542             elsif ($self->override($target_subpath)) {
 543                 debug(2, 0, "--- Overriding installation of: $target_subpath");
 544                 $self->do_unlink($target_subpath);
 545                 $self->do_link($source, $target_subpath);
 546             }
 547             elsif ($self->is_a_dir(join_paths(parent($target_subpath), $existing_link_dest)) &&
 548                    $self->is_a_dir(join_paths(parent($target_subpath), $source)))
 549             {
 550
 551                 # If the existing link points to a directory,
 552                 # and the proposed new link points to a directory,
 553                 # then we can unfold (split open) the tree at that point
 554
 555                 debug(2, 0, "--- Unfolding $target_subpath which was already owned by $existing_package");
 556                 $self->do_unlink($target_subpath);
 557                 $self->do_mkdir($target_subpath);
 558                 $self->stow_contents(
 559                     $existing_stow_path,
 560                     $existing_package,
 561                     $target_subpath,
 562                     join_paths('..', $existing_link_dest),
 563                     $level + 1,
 564                 );
 565                 $self->stow_contents(
 566                     $self->{stow_path},
 567                     $package,
 568                     $target_subpath,
 569                     join_paths('..', $source),
 570                     $level + 1,
 571                 );
 572             }
 573             else {
 574                 $self->conflict(
 575                     'stow',
 576                     $package,
 577                     "existing target is stowed to a different package: "
 578                     . "$target_subpath => $existing_link_dest"
 579                 );
 580             }
 581         }
 582         else {
 583             # The existing link is invalid, so replace it with a good link
 584             debug(2, 0, "--- replacing invalid link: $path");
 585             $self->do_unlink($target_subpath);
 586             $self->do_link($source, $target_subpath);
 587         }
 588     }
 589     elsif ($self->is_a_node($target_subpath)) {
 590         debug(4, 1, "Evaluate existing node: $target_subpath");
 591         if ($self->is_a_dir($target_subpath)) {
 592             $self->stow_contents(
 593                 $self->{stow_path},
 594                 $package,
 595                 $target_subpath,
 596                 join_paths('..', $source),
 597                 $level + 1,
 598             );
 599         }
 600         else {
 601             if ($self->{adopt}) {
 602                 $self->do_mv($target_subpath, $path);
 603                 $self->do_link($source, $target_subpath);
 604             }
 605             else {
 606                 $self->conflict(
 607                     'stow',
 608                     $package,
 609                     "existing target is neither a link nor a directory: $target_subpath"
 610                 );
 611             }
 612         }
 613     }
 614     elsif ($self->{'no-folding'} && -d $path && ! -l $path) {
 615         $self->do_mkdir($target_subpath);
 616         $self->stow_contents(
 617             $self->{stow_path},
 618             $package,
 619             $target_subpath,
 620             join_paths('..', $source),
 621             $level + 1,
 622         );
 623     }
 624     else {
 625         $self->do_link($source, $target_subpath);
 626     }
 627     return;
 628 }
 629
 630 =head2 should_skip_target($target_subdir)
 631
 632 Determine whether C<$target_subdir> is a stow directory which should
 633 not be stowed to or unstowed from.  This mechanism protects stow
 634 directories from being altered by stow, and is a necessary safety
 635 check because the stow directory could live beneath the target
 636 directory.
 637
 638 =over 4
 639
 640 =item $target_subdir => relative path to symlink target from the current directory
 641
 642 =back
 643
 644 Returns true iff target is a stow directory
 645
 646 cwd must be the top-level target directory, otherwise
 647 C<marked_stow_dir()> won't work.
 648
 649 =cut
 650
 651 sub should_skip_target {
 652     my $self = shift;
 653     my ($target) = @_;
 654
 655     # Don't try to remove anything under a stow directory
 656     if ($target eq $self->{stow_path}) {
 657         warn "WARNING: skipping target which was current stow directory $target\n";
 658         return 1;
 659     }
 660
 661     if ($self->marked_stow_dir($target)) {
 662         warn "WARNING: skipping marked Stow directory $target\n";
 663         return 1;
 664     }
 665
 666     if (-e join_paths($target, ".nonstow")) {
 667         warn "WARNING: skipping protected directory $target\n";
 668         return 1;
 669     }
 670
 671     debug(4, 1, "$target not protected; shouldn't skip");
 672     return 0;
 673 }
 674
 675 # cwd must be the top-level target directory, otherwise
 676 # marked_stow_dir() won't work.
 677 sub marked_stow_dir {
 678     my $self = shift;
 679     my ($dir) = @_;
 680     if (-e join_paths($dir, ".stow")) {
 681         debug(5, 5, "> $dir contained .stow");
 682         return 1;
 683     }
 684     return 0;
 685 }
 686
 687 =head2 unstow_contents($package, $target)
 688
 689 Unstow the contents of the given directory
 690
 691 =over 4
 692
 693 =item $package
 694
 695 The package whose contents are being unstowed.
 696
 697 =item $target
 698
 699 Relative path to symlink target from the current directory.
 700
 701 =back
 702
 703 C<unstow_node()> and C<unstow_contents()> are mutually recursive.
 704 Here we traverse the package tree, rather than the target tree.
 705
 706 =cut
 707
 708 sub unstow_contents {
 709     my $self = shift;
 710     my ($package, $target_subdir, $path) = @_;
 711
 712     return if $self->should_skip_target($target_subdir);
 713
 714     my $cwd = getcwd();
 715     my $msg = "Unstowing from $target_subdir (cwd=$cwd, stow dir=$self->{stow_path})";
 716     $msg =~ s!$ENV{HOME}/!~/!g;
 717     debug(3, 0, $msg);
 718     debug(4, 1, "source path is $path");
 719
 720     if ($self->{compat}) {
 721         # In compat mode we traverse the target tree not the source tree,
 722         # so we're unstowing the contents of /target/foo, there's no
 723         # guarantee that the corresponding /stow/mypkg/foo exists.
 724         error("unstow_contents() in compat mode called with non-directory target: $target_subdir")
 725             unless -d $target_subdir;
 726     }
 727     else {
 728         # We traverse the source tree not the target tree, so $path must exist.
 729         error("unstow_contents() called with non-directory path: $path")
 730             unless -d $path;
 731
 732         # When called at the top level, $target_subdir should exist.  And
 733         # unstow_node() should only call this via mutual recursion if
 734         # $target_subdir exists.
 735         error("unstow_contents() called with invalid target: $target_subdir")
 736             unless $self->is_a_node($target_subdir);
 737     }
 738
 739     my $dir = $self->{compat} ? $target_subdir : $path;
 740     opendir my $DIR, $dir
 741         or error("cannot read directory: $dir ($!)");
 742     my @listing = readdir $DIR;
 743     closedir $DIR;
 744
 745     NODE:
 746     for my $node (@listing) {
 747         next NODE if $node eq '.';
 748         next NODE if $node eq '..';
 749         my $node_target = join_paths($target_subdir, $node);
 750         next NODE if $self->ignore($self->{stow_path}, $package, $node_target);
 751
 752         if ($self->{dotfiles}) {
 753             my $adj_node_target = adjust_dotfile($node_target);
 754             debug(4, 1, "Adjusting: $node_target => $adj_node_target");
 755             $node_target = $adj_node_target;
 756         }
 757
 758         $self->unstow_node($package, $node_target, join_paths($path, $node));
 759     }
 760
 761     if (! $self->{compat} && -d $target_subdir) {
 762         $self->cleanup_invalid_links($target_subdir);
 763     }
 764 }
 765
 766 =head2 unstow_node($package, $target_subpath)
 767
 768 Unstow the given node.
 769
 770 =over 4
 771
 772 =item $package
 773
 774 The package containing the node being unstowed.
 775
 776 =item $target_subpath
 777
 778 Relative path to symlink target from the current directory.
 779
 780 =back
 781
 782 C<unstow_node()> and C<unstow_contents()> are mutually recursive.
 783
 784 =cut
 785
 786 sub unstow_node {
 787     my $self = shift;
 788     my ($package, $target_subpath, $source) = @_;
 789
 790     my $pkg_path_from_cwd = join_paths($self->{stow_path}, $package, $target_subpath);
 791
 792     debug(3, 1, "Unstowing $pkg_path_from_cwd");
 793     debug(4, 2, "target is $target_subpath");
 794
 795     # Does the target exist?
 796     if ($self->is_a_link($target_subpath)) {
 797         $self->unstow_link_node($package, $target_subpath, $pkg_path_from_cwd);
 798     }
 799     elsif ($self->{compat} && -d $target_subpath) {
 800         $self->unstow_contents($package, $target_subpath, $pkg_path_from_cwd);
 801
 802         # This action may have made the parent directory foldable
 803         if (my $parent_in_pkg = $self->foldable($target_subpath)) {
 804             $self->fold_tree($target_subpath, $parent_in_pkg);
 805         }
 806     }
 807     elsif (-e $target_subpath) {
 808         if ($self->{compat}) {
 809             $self->conflict(
 810                 'unstow',
 811                 $package,
 812                 "existing target is neither a link nor a directory: $target_subpath",
 813             );
 814         }
 815         else {
 816             $self->unstow_existing_node($package, $target_subpath, $source);
 817         }
 818     }
 819     else {
 820         debug(2, 1, "$target_subpath did not exist to be unstowed");
 821     }
 822 }
 823
 824 sub unstow_link_node {
 825     my $self = shift;
 826     my ($package, $target_subpath, $pkg_path_from_cwd) = @_;
 827     debug(4, 2, "Evaluate existing link: $target_subpath");
 828
 829     # Where is the link pointing?
 830     my $link_dest = $self->read_a_link($target_subpath);
 831     if (not $link_dest) {
 832         error("Could not read link: $target_subpath");
 833     }
 834
 835     if ($link_dest =~ m{\A/}) {
 836         warn "Ignoring an absolute symlink: $target_subpath => $link_dest\n";
 837         return;
 838     }
 839
 840     # Does it point to a node under any stow directory?
 841     my ($existing_pkg_path_from_cwd, $existing_stow_path, $existing_package) =
 842         $self->find_stowed_path($target_subpath, $link_dest);
 843     if (not $existing_pkg_path_from_cwd) {
 844         if ($self->{compat}) {
 845             # We're traversing the target tree not the package tree,
 846             # so we definitely expect to find stuff not owned by stow.
 847             # Therefore we can't flag a conflict.
 848             return;
 849         }
 850         else {
 851             $self->conflict(
 852                 'unstow',
 853                 $package,
 854                 "existing target is not owned by stow: $target_subpath => $link_dest"
 855             );
 856         }
 857         return;
 858     }
 859
 860     # Does the existing $target_subpath actually point to anything?
 861     if (-e $existing_pkg_path_from_cwd) {
 862         $self->unstow_valid_link($pkg_path_from_cwd, $target_subpath, $existing_pkg_path_from_cwd);
 863     }
 864     else {
 865         debug(2, 0, "--- removing invalid link into a stow directory: $pkg_path_from_cwd");
 866         $self->do_unlink($target_subpath);
 867     }
 868 }
 869
 870 sub unstow_valid_link {
 871     my $self = shift;
 872     my ($pkg_path_from_cwd, $target_subpath, $existing_pkg_path_from_cwd) = @_;
 873     # Does link points to the right place?
 874
 875     # Adjust for dotfile if necessary.
 876     if ($self->{dotfiles}) {
 877         $existing_pkg_path_from_cwd = adjust_dotfile($existing_pkg_path_from_cwd);
 878     }
 879
 880     if ($existing_pkg_path_from_cwd eq $pkg_path_from_cwd) {
 881         $self->do_unlink($target_subpath);
 882     }
 883
 884     # FIXME: we quietly ignore links that are stowed to a different
 885     # package.
 886
 887     #elsif (defer($target_subpath)) {
 888     #    debug(2, 0, "--- deferring to installation of: $target_subpath");
 889     #}
 890     #elsif ($self->override($target_subpath)) {
 891     #    debug(2, 0, "--- overriding installation of: $target_subpath");
 892     #    $self->do_unlink($target_subpath);
 893     #}
 894     #else {
 895     #    $self->conflict(
 896     #        'unstow',
 897     #        $package,
 898     #        "existing target is stowed to a different package: "
 899     #        . "$target_subpath => $existing_source"
 900     #    );
 901     #}
 902 }
 903
 904 sub unstow_existing_node {
 905     my $self = shift;
 906     my ($package, $target_subpath, $source) = @_;
 907     debug(4, 2, "Evaluate existing node: $target_subpath");
 908     if (-d $target_subpath) {
 909         $self->unstow_contents($package, $target_subpath, $source);
 910
 911         # This action may have made the parent directory foldable
 912         if (my $parent_in_pkg = $self->foldable($target_subpath)) {
 913             $self->fold_tree($target_subpath, $parent_in_pkg);
 914         }
 915     }
 916     else {
 917         $self->conflict(
 918             'unstow',
 919             $package,
 920             "existing target is neither a link nor a directory: $target_subpath",
 921           );
 922     }
 923 }
 924
 925 =head2 link_owned_by_package($target_subpath, $link_dest)
 926
 927 Determine whether the given link points to a member of a stowed
 928 package.
 929
 930 =over 4
 931
 932 =item $target_subpath
 933
 934 Path to a symbolic link under current directory.
 935
 936 =item $link_dest
 937
 938 Where that link points to.
 939
 940 =back
 941
 942 Lossy wrapper around find_stowed_path().
 943
 944 Returns the package iff link is owned by stow, otherwise ''.
 945
 946 =cut
 947
 948 sub link_owned_by_package {
 949     my $self = shift;
 950     my ($target_subpath, $link_dest) = @_;
 951
 952     my ($pkg_path_from_cwd, $stow_path, $package) =
 953         $self->find_stowed_path($target_subpath, $link_dest);
 954     return $package;
 955 }
 956
 957 =head2 find_stowed_path($target_subpath, $link_dest)
 958
 959 Determine whether the given symlink within the target directory is a
 960 stowed path pointing to a member of a package under the stow dir, and
 961 if so, obtain a breakdown of information about this stowed path.
 962
 963 =over 4
 964
 965 =item $target_subpath
 966
 967 Path to a symbolic link somewhere under the target directory, relative
 968 to the top-level target directory (which is also expected to be the
 969 current directory).
 970
 971 =item $link_dest
 972
 973 Where that link points to (needed because link might not exist yet due
 974 to two-phase approach, so we can't just call C<readlink()>).  If this
 975 is owned by Stow, it will be expressed relative to (the directory
 976 containing) C<$target_subpath>.  However if it's not, it could of course be
 977 relative or absolute, point absolutely anywhere, and could even be
 978 dangling.
 979
 980 =back
 981
 982 Returns C<($pkg_path_from_cwd, $stow_path, $package)> where
 983 C<$pkg_path_from_cwd> and C<$stow_path> are relative from the
 984 top-level target directory.  C<$pkg_path_from_cwd> is the full
 985 relative path to the member of the package pointed to by
 986 C<$link_dest>; C<$stow_path> is the relative path to the stow
 987 directory; and C<$package> is the name of the package; or C<('', '',
 988 '')> if link is not owned by stow.
 989
 990 cwd must be the top-level target directory, otherwise
 991 C<find_containing_marked_stow_dir()> won't work.  Allow for stow dir
 992 not being under target dir.
 993
 994 =cut
 995
 996 sub find_stowed_path {
 997     my $self = shift;
 998     my ($target_subpath, $link_dest) = @_;
 999
1000     if (substr($link_dest, 0, 1) eq '/') {
1001         # Symlink points to an absolute path, therefore it cannot be
1002         # owned by Stow.
1003         return ('', '', '');
1004     }
1005
1006     # Evaluate softlink relative to its target, without relying on
1007     # what's actually on the filesystem, since the link might not
1008     # exist yet.
1009     debug(4, 2, "find_stowed_path(target=$target_subpath; source=$link_dest)");
1010     my $pkg_path_from_cwd = join_paths(parent($target_subpath), $link_dest);
1011     debug(4, 3, "is symlink destination $pkg_path_from_cwd owned by stow?");
1012
1013     # First check whether the link is owned by the current stow
1014     # directory, in which case $pkg_path_from_cwd will be a prefix of
1015     # $self->{stow_path}.
1016     my ($package, $pkg_subpath) = $self->link_dest_within_stow_dir($pkg_path_from_cwd);
1017     if (length $package) {
1018         debug(4, 3, "yes - package $package in $self->{stow_path} may contain $pkg_subpath");
1019         return ($pkg_path_from_cwd, $self->{stow_path}, $package);
1020     }
1021
1022     # If no .stow file was found, we need to find out whether it's
1023     # owned by the current stow directory, in which case
1024     # $pkg_path_from_cwd will be a prefix of $self->{stow_path}.
1025     my ($stow_path, $ext_package) = $self->find_containing_marked_stow_dir($pkg_path_from_cwd);
1026     if (length $stow_path) {
1027         debug(5, 5, "yes - $stow_path in $pkg_path_from_cwd was marked as a stow dir; package=$ext_package");
1028         return ($pkg_path_from_cwd, $stow_path, $ext_package);
1029     }
1030
1031     return ('', '', '');
1032 }
1033
1034 =head2 link_dest_within_stow_dir($link_dest)
1035
1036 Detect whether symlink destination is within current stow dir
1037
1038 =over 4
1039
1040 =item $link_dest - destination of the symlink relative
1041
1042 =back
1043
1044 Returns C<($package, $pkg_subpath)> - package within the current stow
1045 dir and subpath within that package which the symlink points to.
1046
1047 =cut
1048
1049 sub link_dest_within_stow_dir {
1050     my $self = shift;
1051     my ($link_dest) = @_;
1052
1053     debug(4, 4, "common prefix? link_dest=$link_dest; stow_path=$self->{stow_path}");
1054
1055     my $removed = $link_dest =~ s,^\Q$self->{stow_path}/,,;
1056     if (! $removed) {
1057         debug(4, 3, "no - $link_dest not under $self->{stow_path}");
1058         return ('', '');
1059     }
1060
1061     debug(4, 4, "remaining after removing $self->{stow_path}: $link_dest");
1062     my @dirs = File::Spec->splitdir($link_dest);
1063     my $package = shift @dirs;
1064     my $pkg_subpath = File::Spec->catdir(@dirs);
1065     return ($package, $pkg_subpath);
1066 }
1067
1068 =head2 find_containing_marked_stow_dir($pkg_path_from_cwd)
1069
1070 Detect whether path is within a marked stow directory
1071
1072 =over 4
1073
1074 =item $pkg_path_from_cwd => path to directory to check
1075
1076 =back
1077
1078 Returns C<($stow_path, $package)> where C<$stow_path> is the highest
1079 directory (relative from the top-level target directory) which is
1080 marked as a Stow directory, and C<$package> is the containing package;
1081 or C<('', '')> if no containing directory is marked as a stow
1082 directory.
1083
1084 cwd must be the top-level target directory, otherwise
1085 C<marked_stow_dir()> won't work.
1086
1087 =cut
1088
1089 sub find_containing_marked_stow_dir {
1090     my $self = shift;
1091     my ($pkg_path_from_cwd) = @_;
1092
1093     # Search for .stow files - this allows us to detect links
1094     # owned by stow directories other than the current one.
1095     my @segments = File::Spec->splitdir($pkg_path_from_cwd);
1096     for my $last_segment (0 .. $#segments) {
1097         my $pkg_path_from_cwd = join_paths(@segments[0 .. $last_segment]);
1098         debug(5, 5, "is $pkg_path_from_cwd marked stow dir?");
1099         if ($self->marked_stow_dir($pkg_path_from_cwd)) {
1100             if ($last_segment == $#segments) {
1101                 # This should probably never happen.  Even if it did,
1102                 # there would be no way of calculating $package.
1103                 internal_error("find_stowed_path() called directly on stow dir");
1104             }
1105
1106             my $package = $segments[$last_segment + 1];
1107             return ($pkg_path_from_cwd, $package);
1108         }
1109     }
1110     return ('', '');
1111 }
1112
1113 =head2 cleanup_invalid_links($dir)
1114
1115 Clean up orphaned links that may block folding
1116
1117 =over 4
1118
1119 =item $dir
1120
1121 Path to directory to check
1122
1123 =back
1124
1125 This is invoked by C<unstow_contents()>.  We only clean up links which
1126 are both orphaned and owned by Stow, i.e. they point to a non-existent
1127 location within a Stow package.  These can block tree folding, and
1128 they can easily occur when a file in Stow package is renamed or
1129 removed, so the benefit should outweigh the low risk of actually
1130 someone wanting to keep an orphaned link to within a Stow package.
1131
1132 =cut
1133
1134 sub cleanup_invalid_links {
1135     my $self = shift;
1136     my ($dir) = @_;
1137
1138     my $cwd = getcwd();
1139     debug(2, 0, "Cleaning up any invalid links in $dir (pwd=$cwd)");
1140
1141     if (not -d $dir) {
1142         internal_error("cleanup_invalid_links() called with a non-directory: $dir");
1143     }
1144
1145     opendir my $DIR, $dir
1146         or error("cannot read directory: $dir ($!)");
1147     my @listing = readdir $DIR;
1148     closedir $DIR;
1149
1150     NODE:
1151     for my $node (@listing) {
1152         next NODE if $node eq '.';
1153         next NODE if $node eq '..';
1154
1155         my $node_path = join_paths($dir, $node);
1156
1157         next unless -l $node_path;
1158
1159         debug(4, 1, "Checking validity of link $node_path");
1160
1161         if (exists $self->{link_task_for}{$node_path}) {
1162             my $action = $self->{link_task_for}{$node_path}{action};
1163             if ($action ne 'remove') {
1164                 warn "Unexpected action $action scheduled for $node_path; skipping clean-up\n";
1165             }
1166             else {
1167                 debug(4, 2, "$node_path scheduled for removal; skipping clean-up");
1168             }
1169             next;
1170         }
1171
1172         # Where is the link pointing?
1173         # (don't use read_a_link() here)
1174         my $link_dest = readlink($node_path);
1175         if (not $link_dest) {
1176             error("Could not read link $node_path");
1177         }
1178
1179         my $target_subpath = join_paths($dir, $link_dest);
1180         debug(4, 2, "join $dir $link_dest");
1181         if (-e $target_subpath) {
1182             debug(4, 2, "Link target $link_dest exists at $target_subpath; skipping clean up");
1183             next;
1184         }
1185         else {
1186             debug(4, 2, "Link target $link_dest doesn't exist at $target_subpath");
1187         }
1188
1189         debug(3, 1,
1190               "Checking whether valid link $node_path -> $link_dest is " .
1191               "owned by stow");
1192
1193         my $owner = $self->link_owned_by_package($node_path, $link_dest);
1194         if ($owner) {
1195             # owned by stow
1196             debug(2, 0, "--- removing link owned by $owner: $node_path => " .
1197                   join_paths($dir, $link_dest));
1198             $self->do_unlink($node_path);
1199         }
1200     }
1201     return;
1202 }
1203
1204
1205 =head2 foldable($target_subdir)
1206
1207 Determine whether a tree can be folded
1208
1209 =over 4
1210
1211 =item $target_subdir
1212
1213 Path to the target sub-directory to check for foldability, relative to
1214 the current directory (the top-level target directory).
1215
1216 =back
1217
1218 Returns path to the parent dir iff the tree can be safely folded.  The
1219 path returned is relative to the parent of C<$target_subdir>, i.e. it
1220 can be used as the source for a replacement symlink.
1221
1222 =cut
1223
1224 sub foldable {
1225     my $self = shift;
1226     my ($target_subdir) = @_;
1227
1228     debug(3, 2, "Is $target_subdir foldable?");
1229     if ($self->{'no-folding'}) {
1230         debug(3, 3, "Not foldable because --no-folding enabled");
1231         return '';
1232     }
1233
1234     opendir my $DIR, $target_subdir
1235         or error(qq{Cannot read directory "$target_subdir" ($!)\n});
1236     my @listing = readdir $DIR;
1237     closedir $DIR;
1238
1239     # We want to see if all the symlinks in $target_subdir point to
1240     # files under the same parent subdirectory in the package
1241     # (e.g. ../../stow/pkg1/common_dir/file1).  So remember which
1242     # parent subdirectory we've already seen, and if we come across a
1243     # second one which is different,
1244     # (e.g. ../../stow/pkg2/common_dir/file2), then $target_subdir
1245     # common_dir which contains file{1,2} cannot be folded to be
1246     # a symlink to (say) ../../stow/pkg1/common_dir.
1247     my $parent_in_pkg = '';
1248
1249     NODE:
1250     for my $node (@listing) {
1251         next NODE if $node eq '.';
1252         next NODE if $node eq '..';
1253
1254         my $target_node_path = join_paths($target_subdir, $node);
1255
1256         # Skip nodes scheduled for removal
1257         next NODE if not $self->is_a_node($target_node_path);
1258
1259         # If it's not a link then we can't fold its parent
1260         if (not $self->is_a_link($target_node_path)) {
1261             debug(3, 3, "Not foldable because $target_node_path not a link");
1262             return '';
1263         }
1264
1265         # Where is the link pointing?
1266         my $link_dest = $self->read_a_link($target_node_path);
1267         if (not $link_dest) {
1268             error("Could not read link $target_node_path");
1269         }
1270         my $new_parent = parent($link_dest);
1271         if ($parent_in_pkg eq '') {
1272             $parent_in_pkg = $new_parent;
1273         }
1274         elsif ($parent_in_pkg ne $new_parent) {
1275             debug(3, 3, "Not foldable because $target_subdir contains links to entries in both $parent_in_pkg and $new_parent");
1276             return '';
1277         }
1278     }
1279     if (not $parent_in_pkg) {
1280         debug(3, 3, "Not foldable because $target_subdir contains no links");
1281         return '';
1282     }
1283
1284     # If we get here then all nodes inside $target_subdir are links,
1285     # and those links point to nodes inside the same directory.
1286
1287     # chop of leading '..' to get the path to the common parent directory
1288     # relative to the parent of our $target_subdir
1289     $parent_in_pkg =~ s{\A\.\./}{};
1290
1291     # If the resulting path is owned by stow, we can fold it
1292     if ($self->link_owned_by_package($target_subdir, $parent_in_pkg)) {
1293         debug(3, 3, "$target_subdir is foldable");
1294         return $parent_in_pkg;
1295     }
1296     else {
1297         debug(3, 3, "$target_subdir is not foldable");
1298         return '';
1299     }
1300 }
1301
1302 =head2 fold_tree($target_subdir, $pkg_subpath)
1303
1304 Fold the given tree
1305
1306 =over 4
1307
1308 =item $target_subdir
1309
1310 Directory that we will replace with a link to $pkg_subpath.
1311
1312 =item $pkg_subpath
1313
1314 link to the folded tree source
1315
1316 =back
1317
1318 Only called iff foldable() is true so we can remove some checks.
1319
1320 =cut
1321
1322 sub fold_tree {
1323     my $self = shift;
1324     my ($target_subdir, $pkg_subpath) = @_;
1325
1326     debug(3, 0, "--- Folding tree: $target_subdir => $pkg_subpath");
1327
1328     opendir my $DIR, $target_subdir
1329         or error(qq{Cannot read directory "$target_subdir" ($!)\n});
1330     my @listing = readdir $DIR;
1331     closedir $DIR;
1332
1333     NODE:
1334     for my $node (@listing) {
1335         next NODE if $node eq '.';
1336         next NODE if $node eq '..';
1337         next NODE if not $self->is_a_node(join_paths($target_subdir, $node));
1338         $self->do_unlink(join_paths($target_subdir, $node));
1339     }
1340     $self->do_rmdir($target_subdir);
1341     $self->do_link($pkg_subpath, $target_subdir);
1342     return;
1343 }
1344
1345
1346 =head2 conflict($package, $message)
1347
1348 Handle conflicts in stow operations
1349
1350 =over 4
1351
1352 =item $package
1353
1354 the package involved with the conflicting operation
1355
1356 =item $message
1357
1358 a description of the conflict
1359
1360 =back
1361
1362 =cut
1363
1364 sub conflict {
1365     my $self = shift;
1366     my ($action, $package, $message) = @_;
1367
1368     debug(2, 0, "CONFLICT when ${action}ing $package: $message");
1369     $self->{conflicts}{$action}{$package} ||= [];
1370     push @{ $self->{conflicts}{$action}{$package} }, $message;
1371     $self->{conflict_count}++;
1372
1373     return;
1374 }
1375
1376 =head2 get_conflicts()
1377
1378 Returns a nested hash of all potential conflicts discovered: the keys
1379 are actions ('stow' or 'unstow'), and the values are hashrefs whose
1380 keys are stow package names and whose values are conflict
1381 descriptions, e.g.:
1382
1383     (
1384         stow => {
1385             perl => [
1386                 "existing target is not owned by stow: bin/a2p"
1387                 "existing target is neither a link nor a directory: bin/perl"
1388             ]
1389         }
1390     )
1391
1392 =cut
1393
1394 sub get_conflicts {
1395     my $self = shift;
1396     return %{ $self->{conflicts} };
1397 }
1398
1399 =head2 get_conflict_count()
1400
1401 Returns the number of conflicts found.
1402
1403 =cut
1404
1405 sub get_conflict_count {
1406     my $self = shift;
1407     return $self->{conflict_count};
1408 }
1409
1410 =head2 get_tasks()
1411
1412 Returns a list of all symlink/directory creation/removal tasks.
1413
1414 =cut
1415
1416 sub get_tasks {
1417     my $self = shift;
1418     return @{ $self->{tasks} };
1419 }
1420
1421 =head2 get_action_count()
1422
1423 Returns the number of actions planned for this Stow instance.
1424
1425 =cut
1426
1427 sub get_action_count {
1428     my $self = shift;
1429     return $self->{action_count};
1430 }
1431
1432 =head2 ignore($stow_path, $package, $target)
1433
1434 Determine if the given path matches a regex in our ignore list.
1435
1436 =over 4
1437
1438 =item $stow_path
1439
1440 the stow directory containing the package
1441
1442 =item $package
1443
1444 the package containing the path
1445
1446 =item $target
1447
1448 the path to check against the ignore list relative to its package
1449 directory
1450
1451 =back
1452
1453 Returns true iff the path should be ignored.
1454
1455 =cut
1456
1457 sub ignore {
1458     my $self = shift;
1459     my ($stow_path, $package, $target) = @_;
1460
1461     internal_error(__PACKAGE__ . "::ignore() called with empty target")
1462         unless length $target;
1463
1464     for my $suffix (@{ $self->{ignore} }) {
1465         if ($target =~ m/$suffix/) {
1466             debug(4, 1, "Ignoring path $target due to --ignore=$suffix");
1467             return 1;
1468         }
1469     }
1470
1471     my $package_dir = join_paths($stow_path, $package);
1472     my ($path_regexp, $segment_regexp) =
1473         $self->get_ignore_regexps($package_dir);
1474     debug(5, 2, "Ignore list regexp for paths:    " .
1475              (defined $path_regexp ? "/$path_regexp/" : "none"));
1476     debug(5, 2, "Ignore list regexp for segments: " .
1477              (defined $segment_regexp ? "/$segment_regexp/" : "none"));
1478
1479     if (defined $path_regexp and "/$target" =~ $path_regexp) {
1480         debug(4, 1, "Ignoring path /$target");
1481         return 1;
1482     }
1483
1484     (my $basename = $target) =~ s!.+/!!;
1485     if (defined $segment_regexp and $basename =~ $segment_regexp) {
1486         debug(4, 1, "Ignoring path segment $basename");
1487         return 1;
1488     }
1489
1490     debug(5, 1, "Not ignoring $target");
1491     return 0;
1492 }
1493
1494 sub get_ignore_regexps {
1495     my $self = shift;
1496     my ($dir) = @_;
1497
1498     # N.B. the local and global stow ignore files have to have different
1499     # names so that:
1500     #   1. the global one can be a symlink to within a stow
1501     #      package, managed by stow itself, and
1502     #   2. the local ones can be ignored via hardcoded logic in
1503     #      GlobsToRegexp(), so that they always stay within their stow packages.
1504
1505     my $local_stow_ignore  = join_paths($dir,       $LOCAL_IGNORE_FILE);
1506     my $global_stow_ignore = join_paths($ENV{HOME}, $GLOBAL_IGNORE_FILE);
1507
1508     for my $file ($local_stow_ignore, $global_stow_ignore) {
1509         if (-e $file) {
1510             debug(5, 1, "Using ignore file: $file");
1511             return $self->get_ignore_regexps_from_file($file);
1512         }
1513         else {
1514             debug(5, 1, "$file didn't exist");
1515         }
1516     }
1517
1518     debug(4, 1, "Using built-in ignore list");
1519     return @default_global_ignore_regexps;
1520 }
1521
1522 my %ignore_file_regexps;
1523
1524 sub get_ignore_regexps_from_file {
1525     my $self = shift;
1526     my ($file) = @_;
1527
1528     if (exists $ignore_file_regexps{$file}) {
1529         debug(4, 2, "Using memoized regexps from $file");
1530         return @{ $ignore_file_regexps{$file} };
1531     }
1532
1533     if (! open(REGEXPS, $file)) {
1534         debug(4, 2, "Failed to open $file: $!");
1535         return undef;
1536     }
1537
1538     my @regexps = $self->get_ignore_regexps_from_fh(\*REGEXPS);
1539     close(REGEXPS);
1540
1541     $ignore_file_regexps{$file} = [ @regexps ];
1542     return @regexps;
1543 }
1544
1545 =head2 invalidate_memoized_regexp($file)
1546
1547 For efficiency of performance, regular expressions are compiled from
1548 each ignore list file the first time it is used by the Stow process,
1549 and then memoized for future use.  If you expect the contents of these
1550 files to change during a single run, you will need to invalidate the
1551 memoized value from this cache.  This method allows you to do that.
1552
1553 =cut
1554
1555 sub invalidate_memoized_regexp {
1556     my $self = shift;
1557     my ($file) = @_;
1558     if (exists $ignore_file_regexps{$file}) {
1559         debug(4, 2, "Invalidated memoized regexp for $file");
1560         delete $ignore_file_regexps{$file};
1561     }
1562     else {
1563         debug(2, 1, "WARNING: no memoized regexp for $file to invalidate");
1564     }
1565 }
1566
1567 sub get_ignore_regexps_from_fh {
1568     my $self = shift;
1569     my ($fh) = @_;
1570     my %regexps;
1571     while (<$fh>) {
1572         chomp;
1573         s/^\s+//;
1574         s/\s+$//;
1575         next if /^#/ or length($_) == 0;
1576         s/\s+#.+//; # strip comments to right of pattern
1577         s/\\#/#/g;
1578         $regexps{$_}++;
1579     }
1580
1581     # Local ignore lists should *always* stay within the stow directory,
1582     # because this is the only place stow looks for them.
1583     $regexps{"^/\Q$LOCAL_IGNORE_FILE\E\$"}++;
1584
1585     return $self->compile_ignore_regexps(%regexps);
1586 }
1587
1588 sub compile_ignore_regexps {
1589     my $self = shift;
1590     my (%regexps) = @_;
1591
1592     my @segment_regexps;
1593     my @path_regexps;
1594     for my $regexp (keys %regexps) {
1595         if (index($regexp, '/') < 0) {
1596             # No / found in regexp, so use it for matching against basename
1597             push @segment_regexps, $regexp;
1598         }
1599         else {
1600             # / found in regexp, so use it for matching against full path
1601             push @path_regexps, $regexp;
1602         }
1603     }
1604
1605     my $segment_regexp = join '|', @segment_regexps;
1606     my $path_regexp    = join '|', @path_regexps;
1607     $segment_regexp = @segment_regexps ?
1608         $self->compile_regexp("^($segment_regexp)\$") : undef;
1609     $path_regexp    = @path_regexps    ?
1610         $self->compile_regexp("(^|/)($path_regexp)(/|\$)") : undef;
1611
1612     return ($path_regexp, $segment_regexp);
1613 }
1614
1615 sub compile_regexp {
1616     my $self = shift;
1617     my ($regexp) = @_;
1618     my $compiled = eval { qr/$regexp/ };
1619     die "Failed to compile regexp: $@\n" if $@;
1620     return $compiled;
1621 }
1622
1623 sub get_default_global_ignore_regexps {
1624     my $class = shift;
1625     # Bootstrap issue - first time we stow, we will be stowing
1626     # .cvsignore so it might not exist in ~ yet, or if it does, it could
1627     # be an old version missing the entries we need.  So we make sure
1628     # they are there by hardcoding some crucial entries.
1629     return $class->get_ignore_regexps_from_fh(\*DATA);
1630 }
1631
1632 =head2 defer($path)
1633
1634 Determine if the given path matches a regex in our C<defer> list
1635
1636 =over 4
1637
1638 =item $path
1639
1640 =back
1641
1642 Returns boolean.
1643
1644 =cut
1645
1646 sub defer {
1647     my $self = shift;
1648     my ($path) = @_;
1649
1650     for my $prefix (@{ $self->{defer} }) {
1651         return 1 if $path =~ m/$prefix/;
1652     }
1653     return 0;
1654 }
1655
1656 =head2 override($path)
1657
1658 Determine if the given path matches a regex in our C<override> list
1659
1660 =over 4
1661
1662 =item $path
1663
1664 =back
1665
1666 Returns boolean
1667
1668 =cut
1669
1670 sub override {
1671     my $self = shift;
1672     my ($path) = @_;
1673
1674     for my $regex (@{ $self->{override} }) {
1675         return 1 if $path =~ m/$regex/;
1676     }
1677     return 0;
1678 }
1679
1680 ##############################################################################
1681 #
1682 # The following code provides the abstractions that allow us to defer operating
1683 # on the filesystem until after all potential conflcits have been assessed.
1684 #
1685 ##############################################################################
1686
1687 =head2 process_tasks()
1688
1689 Process each task in the tasks list
1690
1691 =over 4
1692
1693 =item none
1694
1695 =back
1696
1697 Returns : n/a
1698 Throws    : fatal error if tasks list is corrupted or a task fails
1699
1700 =cut
1701
1702 sub process_tasks {
1703     my $self = shift;
1704
1705     debug(2, 0, "Processing tasks...");
1706
1707     # Strip out all tasks with a skip action
1708     $self->{tasks} = [ grep { $_->{action} ne 'skip' } @{ $self->{tasks} } ];
1709
1710     if (not @{ $self->{tasks} }) {
1711         return;
1712     }
1713
1714     $self->within_target_do(sub {
1715         for my $task (@{ $self->{tasks} }) {
1716             $self->process_task($task);
1717         }
1718     });
1719
1720     debug(2, 0, "Processing tasks... done");
1721 }
1722
1723 =head2 process_task($task)
1724
1725 Process a single task.
1726
1727 =over 4
1728
1729 =item $task => the task to process
1730
1731 =back
1732
1733 Returns : n/a
1734 Throws    : fatal error if task fails
1735 # #
1736 Must run from within target directory.  Task involve either creating
1737 or deleting dirs and symlinks an action is set to 'skip' if it is
1738 found to be redundant
1739
1740 =cut
1741
1742 sub process_task {
1743     my $self = shift;
1744     my ($task) = @_;
1745
1746     if ($task->{action} eq 'create') {
1747         if ($task->{type} eq 'dir') {
1748             mkdir($task->{path}, 0777)
1749                 or error("Could not create directory: $task->{path} ($!)");
1750             return;
1751         }
1752         elsif ($task->{type} eq 'link') {
1753             symlink $task->{source}, $task->{path}
1754                 or error(
1755                     "Could not create symlink: %s => %s ($!)",
1756                     $task->{path},
1757                     $task->{source}
1758             );
1759             return;
1760         }
1761     }
1762     elsif ($task->{action} eq 'remove') {
1763         if ($task->{type} eq 'dir') {
1764             rmdir $task->{path}
1765                 or error("Could not remove directory: $task->{path} ($!)");
1766             return;
1767         }
1768         elsif ($task->{type} eq 'link') {
1769             unlink $task->{path}
1770                 or error("Could not remove link: $task->{path} ($!)");
1771             return;
1772         }
1773     }
1774     elsif ($task->{action} eq 'move') {
1775         if ($task->{type} eq 'file') {
1776             # rename() not good enough, since the stow directory
1777             # might be on a different filesystem to the target.
1778             move $task->{path}, $task->{dest}
1779                 or error("Could not move $task->{path} -> $task->{dest} ($!)");
1780             return;
1781         }
1782     }
1783
1784     # Should never happen.
1785     internal_error("bad task action: $task->{action}");
1786 }
1787
1788 =head2 link_task_action($path)
1789
1790 Finds the link task action for the given path, if there is one
1791
1792 =over 4
1793
1794 =item $path
1795
1796 =back
1797
1798 Returns C<'remove'>, C<'create'>, or C<''> if there is no action.
1799 Throws a fatal exception if an invalid action is found.
1800
1801 =cut
1802
1803 sub link_task_action {
1804     my $self = shift;
1805     my ($path) = @_;
1806
1807     if (! exists $self->{link_task_for}{$path}) {
1808         debug(4, 4, "| link_task_action($path): no task");
1809         return '';
1810     }
1811
1812     my $action = $self->{link_task_for}{$path}->{action};
1813     internal_error("bad task action: $action")
1814         unless $action eq 'remove' or $action eq 'create';
1815
1816     debug(4, 1, "link_task_action($path): link task exists with action $action");
1817     return $action;
1818 }
1819
1820 =head2 dir_task_action($path)
1821
1822 Finds the dir task action for the given path, if there is one.
1823
1824 =over 4
1825
1826 =item $path
1827
1828 =back
1829
1830 Returns C<'remove'>, C<'create'>, or C<''> if there is no action.
1831 Throws a fatal exception if an invalid action is found.
1832
1833 =cut
1834
1835 sub dir_task_action {
1836     my $self = shift;
1837     my ($path) = @_;
1838
1839     if (! exists $self->{dir_task_for}{$path}) {
1840         debug(4, 4, "| dir_task_action($path): no task");
1841         return '';
1842     }
1843
1844     my $action = $self->{dir_task_for}{$path}->{action};
1845     internal_error("bad task action: $action")
1846         unless $action eq 'remove' or $action eq 'create';
1847
1848     debug(4, 4, "| dir_task_action($path): dir task exists with action $action");
1849     return $action;
1850 }
1851
1852 =head2 parent_link_scheduled_for_removal($path)
1853
1854 Determine whether the given path or any parent thereof is a link
1855 scheduled for removal
1856
1857 =over 4
1858
1859 =item $path
1860
1861 =back
1862
1863 Returns boolean
1864
1865 =cut
1866
1867 sub parent_link_scheduled_for_removal {
1868     my $self = shift;
1869     my ($path) = @_;
1870
1871     my $prefix = '';
1872     for my $part (split m{/+}, $path) {
1873         $prefix = join_paths($prefix, $part);
1874         debug(5, 4, "| parent_link_scheduled_for_removal($path): prefix $prefix");
1875         if (exists $self->{link_task_for}{$prefix} and
1876              $self->{link_task_for}{$prefix}->{action} eq 'remove') {
1877             debug(4, 4, "| parent_link_scheduled_for_removal($path): link scheduled for removal");
1878             return 1;
1879         }
1880     }
1881
1882     debug(4, 4, "| parent_link_scheduled_for_removal($path): returning false");
1883     return 0;
1884 }
1885
1886 =head2 is_a_link($path)
1887
1888 Determine if the given path is a current or planned link.
1889
1890 =over 4
1891
1892 =item $path
1893
1894 =back
1895
1896 Returns false if an existing link is scheduled for removal and true if
1897 a non-existent link is scheduled for creation.
1898
1899 =cut
1900
1901 sub is_a_link {
1902     my $self = shift;
1903     my ($path) = @_;
1904     debug(4, 2, "is_a_link($path)");
1905
1906     if (my $action = $self->link_task_action($path)) {
1907         if ($action eq 'remove') {
1908             debug(4, 2, "is_a_link($path): returning 0 (remove action found)");
1909             return 0;
1910         }
1911         elsif ($action eq 'create') {
1912             debug(4, 2, "is_a_link($path): returning 1 (create action found)");
1913             return 1;
1914         }
1915     }
1916
1917     if (-l $path) {
1918         # Check if any of its parent are links scheduled for removal
1919         # (need this for edge case during unfolding)
1920         debug(4, 2, "is_a_link($path): is a real link");
1921         return $self->parent_link_scheduled_for_removal($path) ? 0 : 1;
1922     }
1923
1924     debug(4, 2, "is_a_link($path): returning 0");
1925     return 0;
1926 }
1927
1928 =head2 is_a_dir($path)
1929
1930 Determine if the given path is a current or planned directory
1931
1932 =over 4
1933
1934 =item $path
1935
1936 =back
1937
1938 Returns false if an existing directory is scheduled for removal and
1939 true if a non-existent directory is scheduled for creation.  We also
1940 need to be sure we are not just following a link.
1941
1942 =cut
1943
1944 sub is_a_dir {
1945     my $self = shift;
1946     my ($path) = @_;
1947     debug(4, 1, "is_a_dir($path)");
1948
1949     if (my $action = $self->dir_task_action($path)) {
1950         if ($action eq 'remove') {
1951             return 0;
1952         }
1953         elsif ($action eq 'create') {
1954             return 1;
1955         }
1956     }
1957
1958     return 0 if $self->parent_link_scheduled_for_removal($path);
1959
1960     if (-d $path) {
1961         debug(4, 1, "is_a_dir($path): real dir");
1962         return 1;
1963     }
1964
1965     debug(4, 1, "is_a_dir($path): returning false");
1966     return 0;
1967 }
1968
1969 =head2 is_a_node($path)
1970
1971 Determine whether the given path is a current or planned node.
1972
1973 =over 4
1974
1975 =item $path
1976
1977 =back
1978
1979 Returns false if an existing node is scheduled for removal, or true if
1980 a non-existent node is scheduled for creation.  We also need to be
1981 sure we are not just following a link.
1982
1983 =cut
1984
1985 sub is_a_node {
1986     my $self = shift;
1987     my ($path) = @_;
1988     debug(4, 4, "| Checking whether $path is a current/planned node");
1989
1990     my $laction = $self->link_task_action($path);
1991     my $daction = $self->dir_task_action($path);
1992
1993     if ($laction eq 'remove') {
1994         if ($daction eq 'remove') {
1995             internal_error("removing link and dir: $path");
1996             return 0;
1997         }
1998         elsif ($daction eq 'create') {
1999             # Assume that we're unfolding $path, and that the link
2000             # removal action is earlier than the dir creation action
2001             # in the task queue.  FIXME: is this a safe assumption?
2002             return 1;
2003         }
2004         else { # no dir action
2005             return 0;
2006         }
2007     }
2008     elsif ($laction eq 'create') {
2009         if ($daction eq 'remove') {
2010             # Assume that we're folding $path, and that the dir
2011             # removal action is earlier than the link creation action
2012             # in the task queue.  FIXME: is this a safe assumption?
2013             return 1;
2014         }
2015         elsif ($daction eq 'create') {
2016             internal_error("creating link and dir: $path");
2017             return 1;
2018         }
2019         else { # no dir action
2020             return 1;
2021         }
2022     }
2023     else {
2024         # No link action
2025         if ($daction eq 'remove') {
2026             return 0;
2027         }
2028         elsif ($daction eq 'create') {
2029             return 1;
2030         }
2031         else { # no dir action
2032             # fall through to below
2033         }
2034     }
2035
2036     return 0 if $self->parent_link_scheduled_for_removal($path);
2037
2038     if (-e $path) {
2039         debug(4, 3, "| is_a_node($path): really exists");
2040         return 1;
2041     }
2042
2043     debug(4, 3, "| is_a_node($path): returning false");
2044     return 0;
2045 }
2046
2047 =head2 read_a_link($link)
2048
2049 Return the destination of a current or planned link.
2050
2051 =over 4
2052
2053 =item $link
2054
2055 Path to the link target.
2056
2057 =back
2058
2059 Returns the destination of the given link.  Throws a fatal exception
2060 if the given path is not a current or planned link.
2061
2062 =cut
2063
2064 sub read_a_link {
2065     my $self = shift;
2066     my ($link) = @_;
2067
2068     if (my $action = $self->link_task_action($link)) {
2069         debug(4, 2, "read_a_link($link): task exists with action $action");
2070
2071         if ($action eq 'create') {
2072             return $self->{link_task_for}{$link}->{source};
2073         }
2074         elsif ($action eq 'remove') {
2075             internal_error(
2076                 "read_a_link() passed a path that is scheduled for removal: $link"
2077             );
2078         }
2079     }
2080     elsif (-l $link) {
2081         debug(4, 2, "read_a_link($link): real link");
2082         my $link_dest = readlink $link or error("Could not read link: $link ($!)");
2083         return $link_dest;
2084     }
2085     internal_error("read_a_link() passed a non-link path: $link\n");
2086 }
2087
2088 =head2 do_link($link_dest, $link_src)
2089
2090 Wrap 'link' operation for later processing
2091
2092 =over 4
2093
2094 =item $link_dest
2095
2096 the existing file to link to
2097
2098 =item $link_src
2099
2100 the file to link
2101
2102 =back
2103
2104 Throws an error if this clashes with an existing planned operation.
2105 Cleans up operations that undo previous operations.
2106
2107 =cut
2108
2109 sub do_link {
2110     my $self = shift;
2111     my ($link_dest, $link_src) = @_;
2112
2113     if (exists $self->{dir_task_for}{$link_src}) {
2114         my $task_ref = $self->{dir_task_for}{$link_src};
2115
2116         if ($task_ref->{action} eq 'create') {
2117             if ($task_ref->{type} eq 'dir') {
2118                 internal_error(
2119                     "new link (%s => %s) clashes with planned new directory",
2120                     $link_src,
2121                     $link_dest,
2122                 );
2123             }
2124         }
2125         elsif ($task_ref->{action} eq 'remove') {
2126             # We may need to remove a directory before creating a link so continue.
2127         }
2128         else {
2129             internal_error("bad task action: $task_ref->{action}");
2130         }
2131     }
2132
2133     if (exists $self->{link_task_for}{$link_src}) {
2134         my $task_ref = $self->{link_task_for}{$link_src};
2135
2136         if ($task_ref->{action} eq 'create') {
2137             if ($task_ref->{source} ne $link_dest) {
2138                 internal_error(
2139                     "new link clashes with planned new link: %s => %s",
2140                     $task_ref->{path},
2141                     $task_ref->{source},
2142                 )
2143             }
2144             else {
2145                 debug(1, 0, "LINK: $link_src => $link_dest (duplicates previous action)");
2146                 return;
2147             }
2148         }
2149         elsif ($task_ref->{action} eq 'remove') {
2150             if ($task_ref->{source} eq $link_dest) {
2151                 # No need to remove a link we are going to recreate
2152                 debug(1, 0, "LINK: $link_src => $link_dest (reverts previous action)");
2153                 $self->{link_task_for}{$link_src}->{action} = 'skip';
2154                 delete $self->{link_task_for}{$link_src};
2155                 return;
2156             }
2157             # We may need to remove a link to replace it so continue
2158         }
2159         else {
2160             internal_error("bad task action: $task_ref->{action}");
2161         }
2162     }
2163
2164     # Creating a new link
2165     debug(1, 0, "LINK: $link_src => $link_dest");
2166     my $task = {
2167         action  => 'create',
2168         type    => 'link',
2169         path    => $link_src,
2170         source  => $link_dest,
2171     };
2172     push @{ $self->{tasks} }, $task;
2173     $self->{link_task_for}{$link_src} = $task;
2174
2175     return;
2176 }
2177
2178 =head2 do_unlink($file)
2179
2180 Wrap 'unlink' operation for later processing
2181
2182 =over 4
2183
2184 =item $file
2185
2186 the file to unlink
2187
2188 =back
2189
2190 Throws an error if this clashes with an existing planned operation.
2191 Will remove an existing planned link.
2192
2193 =cut
2194
2195 sub do_unlink {
2196     my $self = shift;
2197     my ($file) = @_;
2198
2199     if (exists $self->{link_task_for}{$file}) {
2200         my $task_ref = $self->{link_task_for}{$file};
2201         if ($task_ref->{action} eq 'remove') {
2202             debug(1, 0, "UNLINK: $file (duplicates previous action)");
2203             return;
2204         }
2205         elsif ($task_ref->{action} eq 'create') {
2206             # Do need to create a link then remove it
2207             debug(1, 0, "UNLINK: $file (reverts previous action)");
2208             $self->{link_task_for}{$file}->{action} = 'skip';
2209             delete $self->{link_task_for}{$file};
2210             return;
2211         }
2212         else {
2213             internal_error("bad task action: $task_ref->{action}");
2214         }
2215     }
2216
2217     if (exists $self->{dir_task_for}{$file} and $self->{dir_task_for}{$file} eq 'create') {
2218         internal_error(
2219             "new unlink operation clashes with planned operation: %s dir %s",
2220             $self->{dir_task_for}{$file}->{action},
2221             $file
2222         );
2223     }
2224
2225     # Remove the link
2226     debug(1, 0, "UNLINK: $file");
2227
2228     my $source = readlink $file or error("could not readlink $file ($!)");
2229
2230     my $task = {
2231         action  => 'remove',
2232         type    => 'link',
2233         path    => $file,
2234         source  => $source,
2235     };
2236     push @{ $self->{tasks} }, $task;
2237     $self->{link_task_for}{$file} = $task;
2238
2239     return;
2240 }
2241
2242 =head2 do_mkdir($dir)
2243
2244 Wrap 'mkdir' operation
2245
2246 =over 4
2247
2248 =item $dir
2249
2250 the directory to remove
2251
2252 =back
2253
2254 Throws a fatal exception if operation fails.  Outputs a message if
2255 'verbose' option is set.  Does not perform operation if 'simulate'
2256 option is set.  Cleans up operations that undo previous operations.
2257
2258 =cut
2259
2260 sub do_mkdir {
2261     my $self = shift;
2262     my ($dir) = @_;
2263
2264     if (exists $self->{link_task_for}{$dir}) {
2265         my $task_ref = $self->{link_task_for}{$dir};
2266
2267         if ($task_ref->{action} eq 'create') {
2268             internal_error(
2269                 "new dir clashes with planned new link (%s => %s)",
2270                 $task_ref->{path},
2271                 $task_ref->{source},
2272             );
2273         }
2274         elsif ($task_ref->{action} eq 'remove') {
2275             # May need to remove a link before creating a directory so continue
2276         }
2277         else {
2278             internal_error("bad task action: $task_ref->{action}");
2279         }
2280     }
2281
2282     if (exists $self->{dir_task_for}{$dir}) {
2283         my $task_ref = $self->{dir_task_for}{$dir};
2284
2285         if ($task_ref->{action} eq 'create') {
2286             debug(1, 0, "MKDIR: $dir (duplicates previous action)");
2287             return;
2288         }
2289         elsif ($task_ref->{action} eq 'remove') {
2290             debug(1, 0, "MKDIR: $dir (reverts previous action)");
2291             $self->{dir_task_for}{$dir}->{action} = 'skip';
2292             delete $self->{dir_task_for}{$dir};
2293             return;
2294         }
2295         else {
2296             internal_error("bad task action: $task_ref->{action}");
2297         }
2298     }
2299
2300     debug(1, 0, "MKDIR: $dir");
2301     my $task = {
2302         action  => 'create',
2303         type    => 'dir',
2304         path    => $dir,
2305         source  => undef,
2306     };
2307     push @{ $self->{tasks} }, $task;
2308     $self->{dir_task_for}{$dir} = $task;
2309
2310     return;
2311 }
2312
2313 =head2 do_rmdir($dir)
2314
2315 Wrap 'rmdir' operation
2316
2317 =over 4
2318
2319 =item $dir
2320
2321 the directory to remove
2322
2323 =back
2324
2325 Throws a fatal exception if operation fails.  Outputs a message if
2326 'verbose' option is set.  Does not perform operation if 'simulate'
2327 option is set.
2328
2329 =cut
2330
2331 sub do_rmdir {
2332     my $self = shift;
2333     my ($dir) = @_;
2334
2335     if (exists $self->{link_task_for}{$dir}) {
2336         my $task_ref = $self->{link_task_for}{$dir};
2337         internal_error(
2338             "rmdir clashes with planned operation: %s link %s => %s",
2339             $task_ref->{action},
2340             $task_ref->{path},
2341             $task_ref->{source}
2342         );
2343     }
2344
2345     if (exists $self->{dir_task_for}{$dir}) {
2346         my $task_ref = $self->{link_task_for}{$dir};
2347
2348         if ($task_ref->{action} eq 'remove') {
2349             debug(1, 0, "RMDIR $dir (duplicates previous action)");
2350             return;
2351         }
2352         elsif ($task_ref->{action} eq 'create') {
2353             debug(1, 0, "MKDIR $dir (reverts previous action)");
2354             $self->{link_task_for}{$dir}->{action} = 'skip';
2355             delete $self->{link_task_for}{$dir};
2356             return;
2357         }
2358         else {
2359             internal_error("bad task action: $task_ref->{action}");
2360         }
2361     }
2362
2363     debug(1, 0, "RMDIR $dir");
2364     my $task = {
2365         action  => 'remove',
2366         type    => 'dir',
2367         path    => $dir,
2368         source  => '',
2369     };
2370     push @{ $self->{tasks} }, $task;
2371     $self->{dir_task_for}{$dir} = $task;
2372
2373     return;
2374 }
2375
2376 =head2 do_mv($src, $dst)
2377
2378 Wrap 'move' operation for later processing.
2379
2380 =over 4
2381
2382 =item $src
2383
2384 the file to move
2385
2386 =item $dst
2387
2388 the path to move it to
2389
2390 =back
2391
2392 Throws an error if this clashes with an existing planned operation.
2393 Alters contents of package installation image in stow dir.
2394
2395 =cut
2396
2397 sub do_mv {
2398     my $self = shift;
2399     my ($src, $dst) = @_;
2400
2401     if (exists $self->{link_task_for}{$src}) {
2402         # I don't *think* this should ever happen, but I'm not
2403         # 100% sure.
2404         my $task_ref = $self->{link_task_for}{$src};
2405         internal_error(
2406             "do_mv: pre-existing link task for $src; action: %s, source: %s",
2407             $task_ref->{action}, $task_ref->{source}
2408         );
2409     }
2410     elsif (exists $self->{dir_task_for}{$src}) {
2411         my $task_ref = $self->{dir_task_for}{$src};
2412         internal_error(
2413             "do_mv: pre-existing dir task for %s?! action: %s",
2414             $src, $task_ref->{action}
2415         );
2416     }
2417
2418     # Remove the link
2419     debug(1, 0, "MV: $src -> $dst");
2420
2421     my $task = {
2422         action  => 'move',
2423         type    => 'file',
2424         path    => $src,
2425         dest    => $dst,
2426     };
2427     push @{ $self->{tasks} }, $task;
2428
2429     # FIXME: do we need this for anything?
2430     #$self->{mv_task_for}{$file} = $task;
2431
2432     return;
2433 }
2434
2435
2436 #############################################################################
2437 #
2438 # End of methods; subroutines follow.
2439 # FIXME: Ideally these should be in a separate module.
2440
2441
2442 # ===== PRIVATE SUBROUTINE ===================================================
2443 # Name      : internal_error()
2444 # Purpose   : output internal error message in a consistent form and die
2445 =over 4
2446
2447 =item $message => error message to output
2448
2449 =back
2450
2451 Returns : n/a
2452 Throws    : n/a
2453
2454 =cut
2455
2456 sub internal_error {
2457     my ($format, @args) = @_;
2458     my $error = sprintf($format, @args);
2459     my $stacktrace = Carp::longmess();
2460     die <<EOF;
2461
2462 $ProgramName: INTERNAL ERROR: $error$stacktrace
2463
2464 This _is_ a bug. Please submit a bug report so we can fix it! :-)
2465 See http://www.gnu.org/software/stow/ for how to do this.
2466 EOF
2467 }
2468
2469 =head1 BUGS
2470
2471 =head1 SEE ALSO
2472
2473 =cut
2474
2475 1;
2476
2477 # Local variables:
2478 # mode: perl
2479 # end:
2480 # vim: ft=perl
2481
2482 #############################################################################
2483 # Default global list of ignore regexps follows
2484 # (automatically appended by the Makefile)
2485
2486 __DATA__