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