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