lib/Stow.pm.in

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